(defun compute-one-setter (name type)
(let* ((args (second type))
- (res (type-specifier
- (single-value-type
- (values-specifier-type (third type)))))
- (arglist (make-gensym-list (1+ (length args)))))
+ (res (type-specifier
+ (single-value-type
+ (values-specifier-type (third type)))))
+ (arglist (make-gensym-list (1+ (length args)))))
(cond
((null (intersection args sb!xc:lambda-list-keywords))
`(defun (setf ,name) ,arglist
- (declare ,@(mapcar #'(lambda (arg type)
- `(type ,type ,arg))
- arglist
- (cons res args)))
- (setf (,name ,@(rest arglist)) ,(first arglist))))
+ (declare ,@(mapcar (lambda (arg type)
+ `(type ,type ,arg))
+ arglist
+ (cons res args)))
+ (setf (,name ,@(rest arglist)) ,(first arglist))))
(t
(warn "hairy SETF expander for function ~S" name)
nil))))
(collect ((res))
(dolist (pkg packages)
(do-external-symbols (sym pkg)
- (when (and (fboundp sym)
- (eq (info :function :kind sym) :function)
- (or (info :setf :inverse sym)
- (info :setf :expander sym))
- (not (member sym ignore)))
- (let ((type (type-specifier (info :function :type sym))))
- (aver (consp type))
- #!-sb-fluid (res `(declaim (inline (setf ,sym))))
- (res (compute-one-setter sym type))))))
- `(progn ,@(res))))
+ (when (and (fboundp sym)
+ (eq (info :function :kind sym) :function)
+ (or (info :setf :inverse sym)
+ (info :setf :expander sym))
+ (not (member sym ignore)))
+ (res sym))))
+ `(progn
+ ,@(mapcan
+ (lambda (sym)
+ (let ((type (type-specifier (info :function :type sym))))
+ (aver (consp type))
+ (list
+ #!-sb-fluid `(declaim (inline (setf ,sym)))
+ (compute-one-setter sym type))))
+ (sort (res) #'string<)))))
-); eval-when (compile eval)
+) ; EVAL-WHEN
(define-setters ("COMMON-LISP")
;; Semantically silly...