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")
18 (eval-when (:compile-toplevel :execute)
20 (defun compute-one-setter (name type)
21 (let* ((args (second type))
24 (values-specifier-type (third type)))))
25 (arglist (loop repeat (1+ (length args)) collect (gensym))))
27 ((null (intersection args lambda-list-keywords))
28 `(defun (setf ,name) ,arglist
29 (declare ,@(mapcar #'(lambda (arg type)
33 (setf (,name ,@(rest arglist)) ,(first arglist))))
35 (warn "hairy SETF expander for function ~S" name)
38 ;;; FIXME: should probably become MACROLET
39 (sb!xc:defmacro define-setters (packages &rest ignore)
41 (dolist (pkg packages)
42 (do-external-symbols (sym pkg)
43 (when (and (fboundp sym)
44 (eq (info :function :kind sym) :function)
45 (or (info :setf :inverse sym)
46 (info :setf :expander sym))
47 (not (member sym ignore)))
48 (let ((type (type-specifier (info :function :type sym))))
50 #!-sb-fluid (res `(declaim (inline (setf ,sym))))
51 (res (compute-one-setter sym type))))))
54 ); eval-when (compile eval)
56 (define-setters ("COMMON-LISP")
57 ;; Semantically silly...
58 getf apply ldb mask-field logbitp subseq values
59 ;; Have explicit redundant definitions...
60 setf bit sbit get aref gethash)