;;; .EnTete "Le-Lisp (c) version 15.2" " " "Fichier de test de setf"
;;; .EnPied "setf.ll" "%" " "
;;;
;;; .SuperTitre "Generalized Variables"
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
;;; .Centre "*****************************************************************"

; .Centre "$Header: setf.ll,v 4.4 88/11/20 22:38:37 nuyens Exp $"

(defvar #:sys-package:colon 'setf)

(add-feature 'setf)

;;; Secret Plist !?!?
(defmacro system-put (a i v)
  `(progn (putprop ,a ,v ,i)
	  ,a))
(defmacro system-get (a i)
  `(getprop ,a ,i))

;;; Setf's interface
;; for define-setf-method
(defmacro push-setf-method (n f)
  `(system-put ,n 'setf-method ,f))
(defmacro pop-setf-method (n)
  `(system-get ,n 'setf-method))

(defun :setf-method-p (f)
  (pop-setf-method f))

;; for simple defsetf
(defmacro push-setf-inverse (n f)
  `(system-put ,n 'setf-inverse ,f))
(defmacro pop-setf-inverse (n)
  `(system-get ,n 'setf-inverse))

(defun :setf-inverse-p (n)
  (pop-setf-inverse n))

;; for complex defsetf
(defmacro push-setf-expander (n f)
  `(system-put ,n 'setf-expander ,f))
(defmacro pop-setf-expander (n)
  `(system-get ,n 'setf-expander))

;;; Define-Setf-Method
(defmacro define-setf-method (access-fn lambda-list . body)
  ;; defining and stock the code which return the 5 values describe
  ;; in GET-SETF-METHOD
  ;(verification des arguments: lambda-list: comme defmacro)
  `(progn (push-setf-method ',access-fn
			    #'(lambda ,lambda-list ,@body))
	  ',access-fn))

;;; Get-Setf-Method
;;; Implementation notes: 
;;;  GET-SETF-METHOD returns 5 values which are defined with DEFINE-SETF-METHOD
;;;  or extracted from the information of DEFSETF, or directly from a symbol.
(defun get-setf-method (form)
  ;;  (GET-SETF-METHOD <s-expr>)
  ;; <form> is a access lisp form to a structure (symbol, list, defstruct ...)
  ;; The result is 5 values which permit to construct in any cases
  ;; a correct update form to this structure.
  ;; Description of the 5 values:
  ;;  1- liste of temporary variables which will bound to parameters of
  ;;     access form. this permit to guaranty once evaluation of each
  ;;     parameter, and in the correct order.
  ;;  2- liste of parameters of access form.
  ;;  3- liste of one temporary variable which will bound to new value.
  ;;     It's a list to prevent futures extentions. 
  ;;  4- update form: lisp form, normally using all temporary variables
  ;;     predefined (first and third result), which update the structure.
  ;;  5- access form: lisp form, normally using the temporary variables
  ;;     of the first result, which access the structure.
  (cond
   ((symbolp form)   ; cas simple qu'on n'a pas besoin de stocker
    (let ((v (gensym)))
      (list () () (list v)`(setq ,form ,v) form)))
   ((and (listp form); une forme Lisp: normallement un accesseur
	 (symbolp (car form)))
    (let (tmp)
      (cond   ; doit-on bien avoir les clauses dans cet ordre ?!?!
       ((macro-function (car form))
	(get-setf-method
	 (macroexpand form));il faudrait:(macroexpand form environment)!?!?
	)
       ((setq tmp                            ; me'thodes de'finies par
	      (pop-setf-method (car form)))  ;  define-setf-method
        (apply tmp (cdr form)))
       ((setq tmp                            ; me'thodes de'finies par
	      (pop-setf-inverse (car form))) ;  defsetf simple
	(let ((v (gensym))
	      (lp (mapcar #'(lambda &nobind (gensym)) (cdr form))) )
	  (list lp
		(cdr form)
		(list v)
		`(,tmp ,@lp ,v)
		(cons (car form) lp))))
       ((setq tmp                            ; me'thodes de'finies par
	      (pop-setf-expander (car form)));  defsetf complexe
	(let ((largs (cdr form)))
	  (let ((temp-list (mapcar #'(lambda &nobind (gensym)) largs))
		(temp-value (gensym)))
	    (list temp-list
		    largs
		    (list temp-value)
		    (apply tmp
			   (cons temp-value temp-list))
		    (cons (car form) temp-list))
	    )))
       (t
	(error 'get-setf-method 'ERRGEN form)))))
   ; ?!?! et ((foo a) b c) !?!?
   (t                ; methodes inconnues
    (error 'get-setf-method 'ERRBPA form))))

;;; Setf
; ?!?! je ne sais pas dans quelle mesure on peut accepter le cas de APPLY
; ?!?! avec SETF. En effet CL exige: (APPLY (FUNCTION <fnt>) ...)
; ?!?! pour que ca fonctionne, or en V16 on a pas le droit a une
; ?!?! telle construction.
(defmacro setf l
  (cond
   ((cddr l)
    ; construction des paires
    (do ((lpairs l (cddr lpairs))
	 (lsetf (list 'progn)
		(if (cdr lpairs)
		    (nconc lsetf
			   `((setf ,(car lpairs),(cadr lpairs))))
		  (error 'setf 'ERRWNA l))) )
	((null lpairs) lsetf)))
   ((cdr l)
    ; (SETF <PLACE> <VALUE>)
    (let ((x (car l))(y (cadr l)))
      (cond
       ((symbolp x)
	`(setq ,x ,y))
       ((and (listp x)
	     (symbolp (car x)))
	(let (tmp)
	  (cond
	   ((setq tmp (pop-setf-inverse (car x))) ; defsetf simple
	    `(,tmp ,@(cdr x) ,y))
	   (t				          ; define-setf-method
	    ;; use destructuring-let in the style of mvbind
	    (let (((vars vals stores store-form access-form)
		   (get-setf-method x)))
	      (if vars
		  `(let* ; LET* pour garantir l'ordre
		       ; d'e'valuation droite/gauche
		       ,(mapcar #'list vars vals) ;
		     (let ((,@stores ,y))
		       ,store-form))
		(if stores
		    `(let ((,@stores ,y))
		       ,store-form)
		  store-form)) ))
	   )))
       ;; ((foo a) ...) ?!?!?
       (t (error 'setf 'ERRBPA x)))))
   (t (error 'setf 'ERRWNA l))))


;;; Defsetf
(defmacro defsetf (access . rest)
  ; ?!?! manque: l'analyse de la lambda-list
  (cond
   ((not (symbolp access))  ; cas d'erreur
    (error 'defsetf 'ERRNAA access))
   ((listp (car rest))      ; cas complexe: (defsetf foo  lambda-list
                            ;                        (new-value)
                            ;                      . body)
    (unless (listp (cadr rest))
	    (error 'defsetf 'ERRBPA (cadr rest)))
    `(push-setf-expander ',access
			 (lambda (,@(cadr rest) ,@(car rest))
			   ,@(cddr rest)))
    )
   ((symbolp (car rest))    ; cas simple: (defsetf f g)
    `(push-setf-inverse ',access ',(car rest)) )
   (t                       ; cas d'erreur
    (error 'defsetf 'ERRBAL (car rest)))
   ))

;;; Define-Modify-Macro
; ?!?! On doit pouvoir faire mieux que ce gaspillage de gensym
;      lors du multiple-value-bind (c'est pour e'viter des collisons de noms)
(defmacro define-modify-macro (name lambda-list fct)
  `(defmacro ,name (ref ,@lambda-list)
     (cond
      ((symbolp ref)
       `(setq ,ref ,(:make-call ',fct ref ,@lambda-list)))
      ((consp ref)
       ,(let ((lv (list (gensym)(gensym)(gensym)(gensym)(gensym))))
	  `(let ((,lv (get-setf-method ref)))
	     `(let* ,(mapcar #'(lambda(x y)
				 `(,x ,y))
			     ,(car lv),(cadr lv))
		(let ((,(car ,(caddr lv))
		       ,(:make-call ',fct ,(nth 4 lv) ,@lambda-list)))
		  ,,(nth 3 lv))))))
      (t
       (error 'define-modify-macro 'ERRBPA ref))))
  )

;; MAKE-CALL construct a call to <fct> with the <arg1> and <argl> arguments
;; where <argl> can exist with &rest and &optional keywords
; !?!? devra prendre en compte les &optional et &rest
(defun :make-call (fct arg1 . argl)
    `(,fct ,arg1 ,@argl))

;;; Initialisations

; Pour voir si ca marche bien, on de'crit CAR et CDR diffe'remment
; Mais dans les 2 cas il serait pre'fe'rable de disposer de SET-CAR
; et SET-CDR, idem pour GET, AREF, NTH etc

(define-setf-method car (list)
  (let ((plist (gensym))
	(new-val (gensym)))
    (list (list plist)
	    (list list)
	    (list new-val)
	    `(progn (rplaca ,plist ,new-val)
		    ,new-val)
	    `(car ,plist))))

(defsetf cdr (list)(new-val)
  `(progn (rplacd ,list ,new-val)
	  ,new-val))

(defsetf caar (list)(new-val)
  `(progn (rplaca (car ,list) ,new-val)
	  ,new-val))

(defsetf cadr (list)(new-val)
  `(progn (rplaca (cdr ,list) ,new-val)
	  ,new-val))

(defsetf cdar (list)(new-val)
  `(progn (rplacd (car ,list) ,new-val)
	  ,new-val))

(defsetf cddr (list)(new-val)
  `(progn (rplacd (cdr ,list) ,new-val)
	  ,new-val))

(defsetf get (symbol indicator)(new-val)
  `(putprop ,symbol ,new-val ,indicator))

(defsetf getprop (symbol indicator)(new-val)
  `(putprop ,symbol ,new-val ,indicator))

(defsetf vref vset)

(define-setf-method nth (index list)
  (let ((pindex (gensym))
	(plist (gensym))
	(new-val (gensym)))
    (list (list pindex plist)
	    (list index list)
	    (list new-val)
	    `(progn (rplaca (nthcdr ,pindex ,plist) ,new-val)
		    ,new-val)
	    `(nth ,pindex ,plist))))

(define-modify-macro incf (x) +)
(defsetf dynamic setq)

;(defsetf symbol-value set-symbol-value)
;(defsetf symbol-function set-symbol-function)


;;;; ajout fg le 7 11 88


(defun macro-function (x)
  (and (symbolp x)
       (memq (typefn x) '(dmacro dmsubr macro msubr))
       (cons 'lambda (valfn x))))

(defsetf valfn (symb) (new-val) `(progn (setfn ,symb 'expr ,new-val) ,new-val))

(defsetf plist (symb) (new-val) `(progn (plist ,symb ,new-val) ,new-val))