X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-setf.lisp;h=3cddab43f5904ec4a489a441072a99400f9cfff7;hb=2fcf367a1f73ad306404d2d2cbe24e9995853881;hp=7fe66bb44791cc271c8ba7d60cebe0bb4b82d7f6;hpb=14dbe4cc37ff6847e14ec90e9a75664bb281be3c;p=sbcl.git diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 7fe66bb..3cddab4 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -70,25 +70,6 @@ (t (expand-or-get-setf-inverse form environment))))) -;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited -;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not -;;; use it, we just define it in terms of ANSI's GET-SETF-EXPANSION (or -;;; actually, the cross-compiler version of that, i.e. -;;; SB!XC:GET-SETF-EXPANSION). -(declaim (ftype (function (t &optional (or null sb!c::lexenv))) get-setf-method)) -(defun get-setf-method (form &optional environment) - #!+sb-doc - "This is a specialized-for-one-value version of GET-SETF-EXPANSION (and -a relic from pre-ANSI Common Lisp). Portable ANSI code should use -GET-SETF-EXPANSION directly." - (multiple-value-bind (temps value-forms store-vars store-form access-form) - (sb!xc:get-setf-expansion form environment) - (when (cdr store-vars) - (error "GET-SETF-METHOD used for a form with multiple store ~ - variables:~% ~S" - form)) - (values temps value-forms store-vars store-form access-form))) - ;;; If a macro, expand one level and try again. If not, go for the ;;; SETF function. (declaim (ftype (function (t (or null sb!c::lexenv))) @@ -112,7 +93,7 @@ GET-SETF-EXPANSION directly." (cond ((sb!xc:constantp x environment) (push x args)) (t - (let ((temp (gensym "TMP"))) + (let ((temp (gensymify x))) (push temp args) (push temp vars) (push x vals))))) @@ -357,7 +338,8 @@ GET-SETF-EXPANSION directly." (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) + (defun assign-setf-macro (name expander expander-lambda-list inverse doc) + #+sb-xc-host (declare (ignore expander-lambda-list)) (with-single-package-locked-error (:symbol name "defining a setf-expander for ~A")) (cond ((gethash name sb!c:*setf-assumed-fboundp*) @@ -373,6 +355,9 @@ GET-SETF-EXPANSION directly." (style-warn "defining setf macro for ~S when ~S is fbound" name `(setf ,name)))) (remhash name sb!c:*setf-assumed-fboundp*) + #-sb-xc-host + (when expander + (setf (%fun-lambda-list expander) expander-lambda-list)) ;; FIXME: It's probably possible to join these checks into one form which ;; is appropriate both on the cross-compilation host and on the target. (when (or inverse (info :setf :inverse name)) @@ -391,6 +376,7 @@ GET-SETF-EXPANSION directly." `(eval-when (:load-toplevel :compile-toplevel :execute) (assign-setf-macro ',access-fn nil + nil ',(car rest) ,(when (and (car rest) (stringp (cadr rest))) `',(cadr rest))))) @@ -412,6 +398,7 @@ GET-SETF-EXPANSION directly." (%defsetf ,access-form ,(length store-variables) (lambda (,whole) ,body))) + ',lambda-list nil ',doc)))))) (t @@ -462,6 +449,7 @@ GET-SETF-EXPANSION directly." (lambda (,whole ,environment) ,@local-decs ,body) + ',lambda-list nil ',doc))))) @@ -470,14 +458,16 @@ GET-SETF-EXPANSION directly." &environment env) (declare (type sb!c::lexenv env)) (multiple-value-bind (temps values stores set get) - (get-setf-method place env) + (sb!xc:get-setf-expansion place env) (let ((newval (gensym)) (ptemp (gensym)) (def-temp (if default (gensym)))) (values `(,@temps ,ptemp ,@(if default `(,def-temp))) `(,@values ,prop ,@(if default `(,default))) `(,newval) - `(let ((,(car stores) (%putf ,get ,ptemp ,newval))) + `(let ((,(car stores) (%putf ,get ,ptemp ,newval)) + ,@(cdr stores)) + ,def-temp ;; prevent unused style-warning ,set ,newval) `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) @@ -485,30 +475,32 @@ GET-SETF-EXPANSION directly." (sb!xc:define-setf-expander get (symbol prop &optional default) (let ((symbol-temp (gensym)) (prop-temp (gensym)) - (def-temp (gensym)) + (def-temp (if default (gensym))) (newval (gensym))) (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp))) `(,symbol ,prop ,@(if default `(,default))) (list newval) - `(%put ,symbol-temp ,prop-temp ,newval) + `(progn ,def-temp ;; prevent unused style-warning + (%put ,symbol-temp ,prop-temp ,newval)) `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) (sb!xc:define-setf-expander gethash (key hashtable &optional default) (let ((key-temp (gensym)) (hashtable-temp (gensym)) - (default-temp (gensym)) + (default-temp (if default (gensym))) (new-value-temp (gensym))) (values `(,key-temp ,hashtable-temp ,@(if default `(,default-temp))) `(,key ,hashtable ,@(if default `(,default))) `(,new-value-temp) - `(%puthash ,key-temp ,hashtable-temp ,new-value-temp) + `(progn ,default-temp ;; prevent unused style-warning + (%puthash ,key-temp ,hashtable-temp ,new-value-temp)) `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp)))))) (sb!xc:define-setf-expander logbitp (index int &environment env) (declare (type sb!c::lexenv env)) (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-method int env) + (sb!xc:get-setf-expansion int env) (let ((ind (gensym)) (store (gensym)) (stemp (first stores))) @@ -517,7 +509,8 @@ GET-SETF-EXPANSION directly." ,@vals) (list store) `(let ((,stemp - (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) + (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)) + ,@(cdr stores)) ,store-form ,store) `(logbitp ,ind ,access-form))))) @@ -552,7 +545,7 @@ GET-SETF-EXPANSION directly." place with bits from the low-order end of the new value." (declare (type sb!c::lexenv env)) (multiple-value-bind (dummies vals newval setter getter) - (get-setf-method place env) + (sb!xc:get-setf-expansion place env) (if (and (consp bytespec) (eq (car bytespec) 'byte)) (let ((n-size (gensym)) (n-pos (gensym)) @@ -561,7 +554,8 @@ GET-SETF-EXPANSION directly." (list* (second bytespec) (third bytespec) vals) (list n-new) `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) - ,getter))) + ,getter)) + ,@(cdr newval)) ,setter ,n-new) `(ldb (byte ,n-size ,n-pos) ,getter))) @@ -582,13 +576,14 @@ GET-SETF-EXPANSION directly." with bits from the corresponding position in the new value." (declare (type sb!c::lexenv env)) (multiple-value-bind (dummies vals newval setter getter) - (get-setf-method place env) + (sb!xc:get-setf-expansion place env) (let ((btemp (gensym)) (gnuval (gensym))) (values (cons btemp dummies) (cons bytespec vals) (list gnuval) - `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)) + ,@(cdr newval)) ,setter ,gnuval) `(mask-field ,btemp ,getter)))))