Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv14541
Modified Files:
setf.lisp
Log Message:
Add (a hackish) support for (setf the).
--- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/03/02 22:01:33 1.5
+++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/04/13 23:29:31 1.6
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Thu Feb 8 20:43:20 2001
;;;;
-;;;; $Id: setf.lisp,v 1.5 2007/03/02 22:01:33 ffjeld Exp $
+;;;; $Id: setf.lisp,v 1.6 2007/04/13 23:29:31 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -33,32 +33,32 @@
(expander (and name (movitz::movitz-env-get name 'setf-expander nil environment))))
(if expander
(funcall expander place environment)
- (multiple-value-bind (expansion expanded-p)
- (movitz::movitz-macroexpand-1 place environment)
- (cond
- (expanded-p
- (when (eq expansion place)
- (warn "exp place are eq! ~S" place))
- (get-setf-expansion expansion environment))
- ((symbolp place)
- (let ((store-var (gensym "store-var-")))
- (values nil nil (list store-var) `(setq ,place ,store-var) place)))
- ((assert (consp place)))
- (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist)
- (loop for sub-form in (cdr place)
- as tmp-var = (gensym "tmp-var-")
- if (movitz:movitz-constantp sub-form environment)
- collect sub-form into arglist
- else collect tmp-var into tmp-vars
- and collect sub-form into tmp-var-init-forms
- and collect tmp-var into arglist
- finally (return (values tmp-vars tmp-var-init-forms arglist)))
- (let ((store-var (gensym "store-var-")))
- (values tmp-vars
- tmp-var-init-forms
- (list store-var)
- `(funcall #'(setf ,(car place)) ,store-var ,@arglist)
- (list* (car place) arglist)))))))))))
+ (multiple-value-bind (expansion expanded-p)
+ (movitz::movitz-macroexpand-1 place environment)
+ (cond
+ (expanded-p
+ (when (eq expansion place)
+ (warn "exp place are eq! ~S" place))
+ (get-setf-expansion expansion environment))
+ ((symbolp place)
+ (let ((store-var (gensym "store-var-")))
+ (values nil nil (list store-var) `(setq ,place ,store-var) place)))
+ ((assert (consp place)))
+ (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist)
+ (loop for sub-form in (cdr place)
+ as tmp-var = (gensym "tmp-var-")
+ if (movitz:movitz-constantp sub-form environment)
+ collect sub-form into arglist
+ else collect tmp-var into tmp-vars
+ and collect sub-form into tmp-var-init-forms
+ and collect tmp-var into arglist
+ finally (return (values tmp-vars tmp-var-init-forms arglist)))
+ (let ((store-var (gensym "store-var-")))
+ (values tmp-vars
+ tmp-var-init-forms
+ (list store-var)
+ `(funcall #'(setf ,(car place)) ,store-var ,@arglist)
+ (list* (car place) arglist)))))))))))
;;;(defsetf subseq (sequence start &optional end) (new-sequence)
@@ -87,53 +87,53 @@
(defmacro defsetf (access-fn &rest more-args)
(cond
- ((symbolp (first more-args))
- ;; short form XXX not really good.
- `(defun (setf ,access-fn) (fu foo)
- (,(first more-args) fu foo)))
- (t ;; long form
- (destructuring-bind (lambda-list store-variables &body body-decl-docstring)
- more-args
- (multiple-value-bind (body declarations docstring)
- (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare)
- (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl)))
- (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes)
- (movitz::decode-macro-lambda-list movitz-lambda)
- (assert (null restvar))
- (assert (null envvars))
- (assert (null wholevars))
- (assert (null auxes))
- (assert (null keys))
- (let* ((req-tmps (mapcar (lambda (x) (list x (gensym)))
- reqvars))
- (opt-vars (mapcar #'movitz::decode-optional-formal
- optionalvars))
- (opt-tmps (mapcar (lambda (x) (list x (gensym)))
- opt-vars))
- (tmp-lets (append (mapcar (lambda (rt)
- (list (second rt) '(gensym)))
- req-tmps)
- (mapcar (lambda (rt)
- (list (second rt) '(gensym)))
- opt-tmps)
- `((init-form (list ,@reqvars ,@opt-vars)))
- (mapcar (lambda (rt)
- (list rt '(gensym)))
- store-variables)))
- (lambda-lets (append req-tmps opt-tmps)))
- `(define-setf-expander ,access-fn ,movitz-lambda
- (declare ,@declarations)
- ,@(when docstring (list docstring))
- (let ,tmp-lets
- (let ,lambda-lets
- (values (list ,@(mapcar #'second req-tmps)
- ,@(mapcar #'second opt-tmps))
- init-form
- (list ,@store-variables)
- (progn ,@body)
- (list ',access-fn
- ,@(mapcar #'first req-tmps)
- ,@(mapcar #'first opt-tmps))))))))))))))
+ ((symbolp (first more-args))
+ ;; short form XXX not really good.
+ `(defun (setf ,access-fn) (fu foo)
+ (,(first more-args) fu foo)))
+ (t ;; long form
+ (destructuring-bind (lambda-list store-variables &body body-decl-docstring)
+ more-args
+ (multiple-value-bind (body declarations docstring)
+ (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare)
+ (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl)))
+ (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes)
+ (movitz::decode-macro-lambda-list movitz-lambda)
+ (assert (null restvar))
+ (assert (null envvars))
+ (assert (null wholevars))
+ (assert (null auxes))
+ (assert (null keys))
+ (let* ((req-tmps (mapcar (lambda (x) (list x (gensym)))
+ reqvars))
+ (opt-vars (mapcar #'movitz::decode-optional-formal
+ optionalvars))
+ (opt-tmps (mapcar (lambda (x) (list x (gensym)))
+ opt-vars))
+ (tmp-lets (append (mapcar (lambda (rt)
+ (list (second rt) '(gensym)))
+ req-tmps)
+ (mapcar (lambda (rt)
+ (list (second rt) '(gensym)))
+ opt-tmps)
+ `((init-form (list ,@reqvars ,@opt-vars)))
+ (mapcar (lambda (rt)
+ (list rt '(gensym)))
+ store-variables)))
+ (lambda-lets (append req-tmps opt-tmps)))
+ `(define-setf-expander ,access-fn ,movitz-lambda
+ (declare ,@declarations)
+ ,@(when docstring (list docstring))
+ (let ,tmp-lets
+ (let ,lambda-lets
+ (values (list ,@(mapcar #'second req-tmps)
+ ,@(mapcar #'second opt-tmps))
+ init-form
+ (list ,@store-variables)
+ (progn ,@body)
+ (list ',access-fn
+ ,@(mapcar #'first req-tmps)
+ ,@(mapcar #'first opt-tmps))))))))))))))
(defmacro define-modify-macro (name lambda-list function &optional documentation)
@@ -147,8 +147,8 @@
(multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)
(get-setf-expansion place env)
(assert (= 1 (length store-vars)) ()
- "Don't know how to modify a place with ~D cells."
- (length store-vars))
+ "Don't know how to modify a place with ~D cells."
+ (length store-vars))
`(let ,(mapcar #'list tmp-vars tmp-var-init-forms)
;; We love backquote..
(let ((,(first store-vars) (,',function
@@ -163,36 +163,37 @@
(defmacro setf (&environment env &rest pairs)
(let ((num-pairs (length pairs)))
(cond
- ((= 2 num-pairs)
- (destructuring-bind (place new-value-form)
- pairs
- ;; 5.1.2 Kinds of Places
- (cond
- ((symbolp place) ; 5.1.2.1 Variable Names as Places
- (multiple-value-bind (expansion expanded-p)
- (movitz::movitz-macroexpand-1 place env)
- (if expanded-p
- `(setf ,expansion ,new-value-form)
- `(setq ,place ,new-value-form))))
- (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form)
- (get-setf-expansion place env)
- (case (length store-vars)
- (0 `(progn ,@tmp-forms ,new-value-form nil))
- (1 `(let (,@(loop for tmp-var in tmp-vars
- for tmp-form in tmp-forms
- collect `(,tmp-var ,tmp-form))
- (,(first store-vars) ,new-value-form))
- (declare (ignorable ,@tmp-vars))
- ,setter-form))
- (t `(let ,(loop for tmp-var in tmp-vars
- for tmp-form in tmp-forms
- collect `(,tmp-var ,tmp-form))
- (multiple-value-bind ,store-vars
- ,new-value-form
- ,setter-form)))))))))
- ((evenp num-pairs)
- (cons 'progn
- (loop for (place newvalue) on pairs by #'cddr
- collect `(setf ,place ,newvalue))))
- (t (error "Odd number of arguments to SETF.")))))
-
+ ((= 2 num-pairs)
+ (destructuring-bind (place new-value-form)
+ pairs
+ ;; 5.1.2 Kinds of Places
+ (typecase place
+ (symbol ; 5.1.2.1 Variable Names as Places
+ (multiple-value-bind (expansion expanded-p)
+ (movitz::movitz-macroexpand-1 place env)
+ (if expanded-p
+ `(setf ,expansion ,new-value-form)
+ `(setq ,place ,new-value-form))))
+ ((cons (eql the))
+ `(setf ,(third place) (the ,(second place) ,new-value-form)))
+ (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form)
+ (get-setf-expansion place env)
+ (case (length store-vars)
+ (0 `(progn ,@tmp-forms ,new-value-form nil))
+ (1 `(let (,@(loop for tmp-var in tmp-vars
+ for tmp-form in tmp-forms
+ collect `(,tmp-var ,tmp-form))
+ (,(first store-vars) ,new-value-form))
+ (declare (ignorable ,@tmp-vars))
+ ,setter-form))
+ (t `(let ,(loop for tmp-var in tmp-vars
+ for tmp-form in tmp-forms
+ collect `(,tmp-var ,tmp-form))
+ (multiple-value-bind ,store-vars
+ ,new-value-form
+ ,setter-form)))))))))
+ ((evenp num-pairs)
+ (cons 'progn
+ (loop for (place newvalue) on pairs by #'cddr
+ collect `(setf ,place ,newvalue))))
+ (t (error "Odd number of arguments to SETF.")))))
