;;; -*- Mode: Lisp; Package: LISP -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "setf")

(in-package "lisp")

(export '(defsetf define-setf-method get-setf-method-multiple-value
	  get-setf-method setf psetf shiftf rotatef push pushnew pop
	  define-modify-macro remf incf decf))

(defmacro defsetf (access-fn &rest forms)
  (if (and (car forms)
	   (or (symbolp (car forms))
	       (functionp (car forms))))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (si:*putprop ',access-fn ',(car forms) 'setf-update)
	 (remprop ',access-fn 'setf-lambda)
	 (remprop ',access-fn 'setf-method)
	 (si:*putprop ',access-fn ',(cadr forms) 'setf-documentation)
	 '(setf ,access-fn))
    (let ((doc (find-documentation (cddr forms))))
      (unless (= (list-length (cadr forms)) 1)
	(error "格納変数がありません"))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (si:*putprop ',access-fn ',forms 'setf-lambda)
	 (remprop ',access-fn 'setf-method)
	 (remprop ',access-fn 'setf-update)
	 (si:*putprop ',access-fn ,doc 'setf-documentation)
	 '(setf ,access-fn)))))

(defun find-&environment (list)
  (let (args)
    (do ((l list (cdr l)))
	((atom l) (values list nil))
      (when (eq (car l) '&environment)
	(return (values (nconc (nreverse args) (cddr l)) (cadr l))))
      (push (car l) args))))

(defmacro define-setf-method (access-fn lambda-list &body body)
  (multiple-value-bind (args env)
      (find-&environment lambda-list)
    (push (if env env (gensym)) args)
    (let ((doc (find-documentation body)))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (si:*putprop ',access-fn #'(lambda ,args ,@body) 'setf-method)
	 (remprop ',access-fn 'setf-lambda)
	 (remprop ',access-fn 'setf-update)
	 (si:*putprop ',access-fn ,doc 'setf-documentation)
	 '(setf ,access-fn)))))

(defun get-setf-method-multiple-value (form &optional env)
  (let (tem)
    (cond ((symbolp form)
	   (let ((store (gensym)))
	     (values nil nil (list store) (list 'setq form store) form)))
	  ((or (not (consp form))
	       (not (symbolp (car form))))
	   (error "~Sのsetfメソッドはありません" form))
	  ((si:*find-in-environment form env)
	   ;(setq tem (assoc (car form) env))
	   (setq tem (macroexpand-1 form env))
	   (if (eq tem form)
	       (error "~Sのsetfメソッドはありません" form))
	   (get-setf-method-multiple-value tem env))
	  ((get (car form) 'setf-method)
	   (apply (get (car form) 'setf-method) env (cdr form)))
	  ((get (car form) 'setf-update)
	   (let ((vars (mapcar #'(lambda (x) (gensym)) (cdr form)))
		 (store (gensym)))
	     (values vars (cdr form) (list store)
		     `(,(get (car form) 'setf-update) ,@vars ,store)
		     (cons (car form) vars))))
	  ((get (car form) 'setf-lambda)
	   (let* ((vars (mapcar #'(lambda (x) (gensym)) (cdr form)))
		  (store (gensym))
		  (f (get (car form) 'setf-lambda)))
	     (values vars (cdr form) (list store)
		     (apply `(lambda (,@(cadr f) ,@(car f)) ,@(cddr f))
			    (cons store vars))
		     (cons (car form) vars))))
	  ((and (not (special-form-p (car form)))
		(macro-function (car form)))
	   (setq tem (macroexpand-1 form env))
	   (if (eq tem form)
	       (error "~Sのsetfメソッドはありません" form))
	   (get-setf-method-multiple-value tem env))
	  (t
	   (error "setfフォームを展開できません: ~S." form)))))

(defun get-setf-method (form &optional env)
  (multiple-value-bind (vars vals stores store-form access-form)
      (get-setf-method-multiple-value form env)
    (unless (= (list-length stores) 1)
      (error "複数の格納変数があります"))
    (values vars vals stores store-form access-form)))

(defun optimize-setf-method (vars vals stores store-form access-form newvalues)
  (let ((new-vars '())
	(new-vals '())
	(new-stores '())
	(new-newvalues '()))
    (do ((var vars (cdr var))
	 (val vals (cdr val)))
	((endp var))
      (cond ((or (constantp (car val))
		 (symbolp (car val)))
	     (setq store-form (nsubst (car val) (car var) store-form :test #'eq))
	     (setq access-form (nsubst (car val) (car var) access-form :test #'eq)))
	    (t
	     (push (car var) new-vars)
	     (push (car val) new-vals))))
    (do ((store stores (cdr store))
	 (newvalue newvalues (cdr newvalue)))
	((endp store))
      (if (or (constantp (car newvalue))
	      (symbolp (car newvalue)))
	  (setq store-form (nsubst (car newvalue) (car store) store-form :test #'eq))
	(progn
	  (push (car store) new-stores)
	  (push (car newvalue) new-newvalues))))
    (values new-vars new-vals new-stores store-form access-form new-newvalues)))

;;;(defun setf-expand-1 (place newvalue env)
;;;  (if (atom place)
;;;      `(setq ,place ,newvalue)
;;;    (let (f)
;;;      (when (and (null (get (car place) 'setf-update))
;;;		 (null (get (car place) 'setf-lambda)))
;;;	(multiple-value-setq (place f) (macroexpand-1 place env))
;;;	(if f
;;;	    (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
;;;      (if (setq f (get (car place) 'setf-update))
;;;	  (return-from setf-expand-1 `(,f ,@(cdr place) ,newvalue)))
;;;      (multiple-value-bind (vars vals stores store-form access-form)
;;;	  (get-setf-method place env)
;;;	`(let* ,(mapcar #'list
;;;			(append vars stores)
;;;			(append vals (list newvalue)))
;;;	   ,store-form)))))

(defun setf-expand-1 (place newvalue env)
  (if (atom place)
      `(setq ,place ,newvalue)
    (let (f)
      (when (and (null (get (car place) 'setf-update))
		 (null (get (car place) 'setf-lambda)))
	(multiple-value-setq (place f) (macroexpand-1 place env))
	(if f
	    (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
      (if (setq f (get (car place) 'setf-update))
	  (return-from setf-expand-1 `(,f ,@(cdr place) ,newvalue)))
      (multiple-value-bind (vars vals stores store-form access-form)
	  (get-setf-method place env)
	(multiple-value-setq (vars vals stores store-form access-form newvalue)
			     (optimize-setf-method vars vals stores store-form
						   access-form (list newvalue)))
	(if (or vars stores)
	    `(let* ,(mapcar #'list
			    (append vars stores)
			    (append vals newvalue))
	       ,store-form)
	  store-form)))))


(defun setf-expand (args env)
  (do ((al args (cddr al))
       (result '()))
      ((endp al) (nreverse result))
    (if (endp (cdr al))
	(error "~S: 不正なsetfフォームです" al))
    (setq result (cons (setf-expand-1 (car al) (cadr al) env) result))))

(defmacro setf (&rest args &environment env)
  (cond ((endp args)
	 'nil)
	((endp (cdr args))
	 (error "~S: 不正なsetfフォームです" args))
	((endp (cddr args))
	 (setf-expand-1 (car args) (cadr args) env))
	(t (cons 'progn (setf-expand args env)))))

(defmacro psetf (&rest args &environment env)
  (cond ((endp args)
	 'nil)
	((endp (cdr args))
	 (error "~S: 不正なpsetfフォームです" args))
	((endp (cddr args))
	 `(progn
	    ,(setf-expand-1 (car args) (cadr args) env)
	    nil))
	(t
	 (do ((x args (cddr x))
	      (bindings nil)
	      (store-forms nil))
	     ((endp x)
	      `(let* ,bindings
		 ,@(nreverse store-forms)
		 nil))
	   (when (endp (cdr x))
	     (error "~S: 不正なpsetfフォームです" args))
	   (multiple-value-bind (vars vals stores store-form access-form)
	       (get-setf-method (car x) env)
	     (push store-form store-forms)
	     (setq bindings
		   (nconc bindings
			  (mapcar #'list
				  (append vars stores)
				  (append vals (list (cadr x)))))))))))

(defmacro shiftf (&rest args &environment env)
  (when (null args)
    (error 'too-few-arguments))
  (do ((x args (cdr x))
       (tem (gensym))
       (bindings nil)
       (stores nil)
       (store-forms nil)
       (access-forms))
      ((endp (cdr x))
       (let ((store-n (car stores)))
	 (setq access-forms (nreverse access-forms))
	 `(let* ,(nconc bindings
			`((,tem ,(car access-forms)))
			(mapcar #'list (nreverse stores) (cdr access-forms))
			`((,store-n ,(car x))))
	    ,@(nreverse store-forms)
	    ,tem)))
    (multiple-value-bind (vars vals xstores store-form access-form)
	(get-setf-method (car x) env)
      (setq bindings (nconc bindings (mapcar #'list vars vals)))
      (push (car xstores) stores)
      (push store-form store-forms)
      (push access-form access-forms))))

(defmacro rotatef (&rest args &environment env)
  (do ((x args (cdr x))
       (bindings nil)
       (stores nil)
       (store-forms nil)
       (access-forms))
      ((endp x)
       (let ((store-n (car stores)))
	 (setq access-forms (nreverse access-forms))
	 `(let* ,(nconc bindings
			`((,store-n ,(car access-forms)))
			(mapcar #'list (nreverse stores) (cdr access-forms)))
	    ,@(nreverse store-forms)
	    ,store-n)))
    (multiple-value-bind (vars vals xstores store-form access-form)
	(get-setf-method (car x) env)
      (setq bindings (nconc bindings (mapcar #'list vars vals)))
      (push (car xstores) stores)
      (push store-form store-forms)
      (push access-form access-forms))))

(defmacro push (item place &environment env)
  (if (symbolp place)
      `(setq ,place (cons ,item ,place))
    (multiple-value-bind (vars vals stores store-form access-form)
	(get-setf-method place env)
      `(let* ,(mapcar #'list
		      (append vars stores)
		      (append vals (list (list 'cons item access-form))))
	 ,store-form))))

(defmacro pushnew (item place &rest keys &environment env)
  (if (symbolp place)
      `(setq ,place (adjoin ,item ,place ,@keys))
    (multiple-value-bind (vars vals stores store-form access-form)
	(get-setf-method place env)
      `(let* ,(mapcar #'list
		      (append vars stores)
		      (append vals
			      (list (list* 'adjoin item access-form keys))))
	 ,store-form))))

(defmacro pop (place &environment env)
  (if (symbolp place)
      `(let ((#1=#:var (car ,place)))
	 (setq ,place (cdr ,place))
	 #1#)
    (multiple-value-bind (vars vals stores store-form access-form)
	(get-setf-method place env)
      `(let* ,(mapcar #'list
		      (append vars stores)
		      (append vals (list (list 'cdr access-form))))
	 (prog1
	     (car ,access-form)
	   ,store-form)))))

(defmacro define-modify-macro (name lambda-list function &optional doc-string)
  (let ((value-form
	 (do ((l lambda-list (cdr l))
	      (vars nil))
	     ((null l)
	      ``(,',function ,%access-form ,,@(nreverse vars)))
	   (let ((var (car l)))
	     (cond ((eq var '&optional))
		   ((eq var '&whole))
		   ((or (eq var '&rest)
			(eq var '&body))
		    (return ``(,',function ,%access-form ,,@(nreverse vars) ,@,(cadr l))))
		   ((symbolp var)
		    (push var vars))
		   (t
		    (push (car var) vars)
		    (if (caddr var)
			(push (caddr var) vars))))))))
    `(defmacro ,name (&environment %env %reference . ,lambda-list)
       ,@(when doc-string
	   (list doc-string))
       (if (symbolp %reference)
	   (let ((%access-form %reference))
	     `(setq ,%reference ,,value-form))
	 (multiple-value-bind (%vars %vals %stores %store-form %access-form)
	     (get-setf-method %reference %env)
	   `(let* ,(mapcar #'list
			   (append %vars %stores)
			   (append %vals (list ,value-form)))
	      ,%store-form))))))

(defmacro remf (place indicator &environment env)
  (multiple-value-bind (vars vals stores store-form access-form)
      (get-setf-method place env)
    `(let* ,(mapcar #'list vars vals)
       (multiple-value-bind (,(car stores) f)
	   (si:*remf ,access-form ,indicator)
         ,store-form
         f))))

(define-setf-method getf (place indicator &optional default &environment env)
   (multiple-value-bind (vars vals stores store-form access-form)
       (get-setf-method place env)
     (let ((temp (gensym))
	   (store (gensym)))
       (values (cons temp vars)
	       (cons indicator vals)
	       (list store)
	       `(let ((,(car stores) (si:*putf ,access-form ,store ,temp)))
		  ,store-form
		  ,store)
	       `(getf ,access-form ,temp ,default)))))

(define-modify-macro incf (&optional (delta 1)) +)
(define-modify-macro decf (&optional (delta 1)) -)

(defsetf aref (vector &rest i) (v) `(si:*aset ,vector ,v ,@i))
(defsetf nth (n x) (y) `(progn (rplaca (nthcdr ,n ,x) ,y) ,y))
(defsetf elt si:*set-elt)
(defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))

(defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))
(defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
(defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
(defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
(defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
(defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
(defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
(defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
(defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
(defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))

(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
(defsetf cdr (x) (y) `(progn (rplacd ,x ,y) ,y))
(defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
(defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
(defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
(defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
(defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
(defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
(defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
(defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
(defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
(defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
(defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
(defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
(defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
(defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
(defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
(defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
(defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
(defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
(defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
(defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
(defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
(defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
(defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
(defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
(defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
(defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
(defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
(defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))

(defsetf svref si:*svset)
(defsetf get (symbol indicator &optional default) (value)
  `(si:*putprop ,symbol ,value ,indicator))
(defsetf gethash (key hash-table &optional default) (x)
  `(si:*puthash ,key ,hash-table ,x))
(defsetf fill-pointer si:*set-fill-pointer)
(defsetf symbol-value set)
(defsetf symbol-function si:*fset)
(defsetf symbol-plist si:*set-symbol-plist)

(defsetf row-major-aref si:*row-major-aset)
(defsetf char si:*set-char)
(defsetf schar si:*set-schar)
(defsetf subseq (sequence start &optional end) (new-sequence)
  `(progn
     (replace ,sequence ,new-sequence :start1 ,start :end1 ,end)
     ,new-sequence))

(defsetf default-value set-default)

(define-setf-method ldb (bytespec int &environment env)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int env)
    (let ((btemp (gensym))
	  (store (gensym))
	  (stemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(let ((,stemp (dpb ,store ,btemp ,access-form)))
		 ,store-form
		 ,store)
	      `(ldb ,btemp ,access-form)))))

(define-setf-method mask-field (bytespec int &environment env)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int env)
    (let ((btemp (gensym))
	  (store (gensym))
	  (stemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
		 ,store-form
		 ,store)
	      `(mask-field ,btemp ,access-form)))))

(define-setf-method apply (fn &rest rest &environment env)
  (unless (and (consp fn)
	       (eq (car fn) 'function)
	       (symbolp (cadr fn))
	       (null (cddr fn)))
    (error "~Sのsetfメソッドを取得できません" fn))
  (multiple-value-bind (vars vals stores store-form access-form)
      (get-setf-method (cons (cadr fn) rest) env)
    (cond ((eq (car (last store-form)) (car (last vars)))
	   (values vars vals stores
                   `(apply #',(car store-form) ,@(cdr store-form))
                   `(apply #',(cadr fn) ,@(cdr access-form))))
          ((eq (car (last (butlast store-form))) (car (last vars)))
           (values vars vals stores
                   `(apply #',(car store-form)
                           ,@(cdr (butlast store-form 2))
                           (append ,(car (last (butlast store-form)))
                                   (list ,(car (last store-form)))))
                   `(apply #',(cadr fn) ,@(cdr access-form))))
          (t
	   (error "~Sのsetfメソッドを取得できません" fn)))))
