X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=e829b6a5a70025200053c2cf3fc57e1494e7ca98;hb=fedd9f4e92ddb1b599695043eb1dafe356475afc;hp=7f6dce7f067f2ae127c7e4f4d16f52cc11a56447;hpb=9ef5be5321618ef470f17d274c1a64b2b487d54f;p=sbcl.git

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 7f6dce7..e829b6a 100644
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -85,7 +85,7 @@ GET-SETF-EXPANSION directly."
       (sb!xc:get-setf-expansion form environment)
     (when (cdr store-vars)
       (error "GET-SETF-METHOD used for a form with multiple store ~
-	      variables:~%  ~S"
+              variables:~%  ~S"
 	     form))
     (values temps value-forms store-vars store-form access-form)))
 
@@ -257,8 +257,9 @@ GET-SETF-EXPANSION directly."
 	  (local1 (gensym))
 	  (local2 (gensym)))
 	 ((null d)
-	  (push (list (car newval) getter) let-list)
+          ;; See ANSI 5.1.3 for why we do out-of-order evaluation
 	  (push (list ind-temp indicator) let-list)
+	  (push (list (car newval) getter) let-list)
 	  `(let* ,(nreverse let-list)
 	     (do ((,local1 ,(car newval) (cddr ,local1))
 		  (,local2 nil ,local1))
@@ -273,6 +274,31 @@ GET-SETF-EXPANSION directly."
 			       ,setter
 			       (return t))))))))
       (push (list (car d) (car v)) let-list))))
+
+;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
+(defmacro-mundanely incf (place &optional (delta 1) &environment env)
+  #!+sb-doc
+  "The first argument is some location holding a number. This number is
+  incremented by the second argument, DELTA, which defaults to 1."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (+ ,getter ,d)))
+         ,setter))))
+
+(defmacro-mundanely decf (place &optional (delta 1) &environment env)
+  #!+sb-doc
+  "The first argument is some location holding a number. This number is
+  decremented by the second argument, DELTA, which defaults to 1."
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (- ,getter ,d)))
+         ,setter))))
 
 ;;;; DEFINE-MODIFY-MACRO stuff
 
@@ -321,26 +347,18 @@ GET-SETF-EXPANSION directly."
 		    let-list)
 	      `(let* ,(nreverse let-list)
 		 ,setter)))))))
-
-(sb!xc:define-modify-macro incf (&optional (delta 1)) +
-  #!+sb-doc
-  "The first argument is some location holding a number. This number is
-  incremented by the second argument, DELTA, which defaults to 1.")
-
-(sb!xc:define-modify-macro decf (&optional (delta 1)) -
-  #!+sb-doc
-  "The first argument is some location holding a number. This number is
-  decremented by the second argument, DELTA, which defaults to 1.")
 
 ;;;; DEFSETF
 
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   ;;; Assign SETF macro information for NAME, making all appropriate checks.
   (defun assign-setf-macro (name expander inverse doc)
+    (with-single-package-locked-error
+	(:symbol name "defining a setf-expander for ~A"))
     (cond ((gethash name sb!c:*setf-assumed-fboundp*)
 	   (warn
 	    "defining setf macro for ~S when ~S was previously ~
-	     treated as a function"
+             treated as a function"
 	    name
 	    `(setf ,name)))
 	  ((not (fboundp `(setf ,name)))
@@ -426,11 +444,11 @@ GET-SETF-EXPANSION directly."
 ;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
 (def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
   #!+sb-doc
-  "Syntax like DEFMACRO, but creates a Setf-Method generator. The body
-  must be a form that returns the five magical values."
+  "Syntax like DEFMACRO, but creates a setf expander function. The body
+  of the definition must be a form that returns five appropriate values."
   (unless (symbolp access-fn)
-    (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
-	   access-fn))
+    (error "~S access-function name ~S is not a symbol."
+           'sb!xc:define-setf-expander access-fn))
   (with-unique-names (whole environment)
     (multiple-value-bind (body local-decs doc)
 	(parse-defmacro lambda-list whole body access-fn
@@ -574,10 +592,10 @@ GET-SETF-EXPANSION directly."
 
 (sb!xc:define-setf-expander the (type place &environment env)
   (declare (type sb!c::lexenv env))
-  (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-method place env)
-    (values dummies
-	      vals
-	      newval
-	      (subst `(the ,type ,(car newval)) (car newval) setter)
-	      `(the ,type ,getter))))
+  (multiple-value-bind (temps subforms store-vars setter getter)
+      (sb!xc:get-setf-expansion place env)
+    (values temps subforms store-vars
+            `(multiple-value-bind ,store-vars
+                 (the ,type (values ,@store-vars))
+               ,setter)
+            `(the ,type ,getter))))