[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv24161

Modified Files:
	setf.lisp 
Log Message:
Sort of implemented defsetf short form.


--- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp	2004/02/18 14:38:14	1.3
+++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp	2006/04/07 21:49:47	1.4
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Thu Feb  8 20:43:20 2001
 ;;;;                
-;;;; $Id: setf.lisp,v 1.3 2004/02/18 14:38:14 ffjeld Exp $
+;;;; $Id: setf.lisp,v 1.4 2006/04/07 21:49:47 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -86,45 +86,54 @@
 ;;;	      `(subseq ,tmp-sequence ,tmp-start ,tmp-end)))))
 
 (defmacro defsetf (access-fn &rest more-args)
-  ;; long form
-  (destructuring-bind (lambda-list store-variables &body body)
-      more-args
-    (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 , at reqvars , at opt-vars)))
-				 (mapcar (lambda (rt)
-					   (list rt '(gensym)))
-					 store-variables)))
-	       (lambda-lets (append req-tmps opt-tmps)))
-	  `(define-setf-expander ,access-fn ,movitz-lambda
-	     (let ,tmp-lets
-	       (let ,lambda-lets
-		 (values (list ,@(mapcar #'second req-tmps)
-			       ,@(mapcar #'second opt-tmps))
-			 init-form
-			 (list , at store-variables)
-			 (progn , at body)
-			 (list ',access-fn
-			       ,@(mapcar #'first req-tmps)
-			       ,@(mapcar #'first opt-tmps)))))))))))
+  (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 , at reqvars , at 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 , at declarations)
+		 ,@(when docstring (list docstring))
+		 (let ,tmp-lets
+		   (let ,lambda-lets
+		     (values (list ,@(mapcar #'second req-tmps)
+				   ,@(mapcar #'second opt-tmps))
+			     init-form
+			     (list , at store-variables)
+			     (progn , at body)
+			     (list ',access-fn
+				   ,@(mapcar #'first req-tmps)
+				   ,@(mapcar #'first opt-tmps))))))))))))))
 
 
 (defmacro define-modify-macro (name lambda-list function &optional documentation)