1 ;;;; stuff to automatically generate SETF functions for all the standard
2 ;;;; functions that are currently implemented with SETF macros
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!KERNEL")
15 (eval-when (:compile-toplevel
:execute
)
17 (defun compute-one-setter (name type
)
18 (let* ((args (second type
))
21 (values-specifier-type (third type
)))))
22 (arglist (make-gensym-list (1+ (length args
)))))
24 ((null (intersection args sb
!xc
:lambda-list-keywords
))
25 `(defun (setf ,name
) ,arglist
26 (declare ,@(mapcar (lambda (arg type
)
30 (setf (,name
,@(rest arglist
)) ,(first arglist
))))
32 (warn "hairy SETF expander for function ~S" name
)
35 ;;; FIXME: should probably become MACROLET
36 ;;; [But can't until we fix the "lexical environment too hairy" warning.
37 ;;; And this environment isn't too hairy so it's especially annoying]
38 (sb!xc
:defmacro define-setters
(packages &rest ignore
)
40 (dolist (pkg packages
)
41 (do-external-symbols (sym pkg
)
42 (when (and (fboundp sym
)
43 (eq (info :function
:kind sym
) :function
)
44 (or (info :setf
:inverse sym
)
45 (info :setf
:expander sym
))
46 ;; Use STRING= because (NEQ 'LDB 'SB!XC:LDB) etc.
47 (not (member sym ignore
:test
#'string
=)))
52 (let ((type (type-specifier (proclaimed-ftype sym
))))
55 #!-sb-fluid
`(declaim (inline (setf ,sym
)))
56 (compute-one-setter sym type
))))
57 (sort (res) #'string
<)))))
61 (define-setters ("COMMON-LISP")
62 ;; Semantically silly...
63 getf apply ldb mask-field logbitp values
66 ;; Have explicit redundant definitions...
67 bit sbit aref gethash
)