1.0.21.35: fix build / SAVE-LISP-AND-DIE on non-GENCGC platforms
[sbcl.git] / src / code / setf-funs.lisp
1 ;;;; stuff to automatically generate SETF functions for all the standard
2 ;;;; functions that are currently implemented with SETF macros
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!KERNEL")
14
15 (eval-when (:compile-toplevel :execute)
16
17 (defun compute-one-setter (name type)
18   (let* ((args (second type))
19          (res (type-specifier
20                (single-value-type
21                 (values-specifier-type (third type)))))
22          (arglist (make-gensym-list (1+ (length args)))))
23     (cond
24      ((null (intersection args sb!xc:lambda-list-keywords))
25       `(defun (setf ,name) ,arglist
26          (declare ,@(mapcar (lambda (arg type)
27                               `(type ,type ,arg))
28                             arglist
29                             (cons res args)))
30          (setf (,name ,@(rest arglist)) ,(first arglist))))
31      (t
32       (warn "hairy SETF expander for function ~S" name)
33       nil))))
34
35 ;;; FIXME: should probably become MACROLET
36 (sb!xc:defmacro define-setters (packages &rest ignore)
37   (collect ((res))
38     (dolist (pkg packages)
39       (do-external-symbols (sym pkg)
40         (when (and (fboundp sym)
41                    (eq (info :function :kind sym) :function)
42                    (or (info :setf :inverse sym)
43                        (info :setf :expander sym))
44                    (not (member sym ignore)))
45           (let ((type (type-specifier (info :function :type sym))))
46             (aver (consp type))
47             #!-sb-fluid (res `(declaim (inline (setf ,sym))))
48             (res (compute-one-setter sym type))))))
49     `(progn ,@(res))))
50
51 ) ; EVAL-WHEN
52
53 (define-setters ("COMMON-LISP")
54   ;; Semantically silly...
55   getf apply ldb mask-field logbitp subseq values
56   ;; Have explicit redundant definitions...
57   setf bit sbit get aref gethash)