(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)))))
(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*)
(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))
`(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)))))
(%defsetf ,access-form ,(length store-variables)
(lambda (,whole)
,body)))
+ ',lambda-list
nil
',doc))))))
(t
(lambda (,whole ,environment)
,@local-decs
,body)
+ ',lambda-list
nil
',doc)))))
`(,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)))))))
(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)