;;; .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))