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 ;;; Fix unknown types in globaldb
  16 (let ((l nil))
  17   (do-all-symbols (s)
  18     (when (and (fboundp s) (not (macro-function s)))
  19       (let ((ftype (info :function :type s)))
  20         (when (contains-unknown-type-p ftype)
  21           (setf (info :function :type s)
  22                 (specifier-type (type-specifier ftype)))
  23           (push s l)))))
  24   (let ((*print-pretty* nil)
  25         (*print-length* nil))
  26     (format t "~&; Fixed ftypes: ~S~%" (sort l #'string<))))
  27
  28 (eval-when (:compile-toplevel :execute)
  29
  30 (defun compute-one-setter (name type)
  31   (let ((args (second type)))
  32     (cond
  33      ((null (intersection args lambda-list-keywords))
  34       (let ((res (type-specifier
  35                   (single-value-type
  36                    (values-specifier-type (third type)))))
  37             (arglist (cons 'newval (or (sb-kernel:%fun-lambda-list
  38                                         (symbol-function name))
  39                                        ;; For low debug builds
  40                                        (make-gensym-list (length args))))))
  41         `(locally
  42           (declare (muffle-conditions
  43                     ;; Expect SETF macro + function warnings.
  44                     (and style-warning
  45                          ;; Expect none of these,
  46                          ;; but just to make sure, show them.
  47                          (not sb-c:inlining-dependency-failure))))
  48           (defun (setf ,name) ,arglist
  49             (declare ,@(mapcar (lambda (arg type) `(type ,type ,arg))
  50                                arglist (cons res args)))
  51             (setf (,name ,@(rest arglist)) ,(first arglist))))))
  52      (t
  53       (warn "hairy SETF expander for function ~S" name)
  54       nil))))
  55
  56 ;;; FIXME: should probably become MACROLET, but inline functions
  57 ;;; within a macrolet capture the whole macrolet, which is dumb.
  58 (defmacro define-setters (packages &rest ignore)
  59   (collect ((res))
  60     (dolist (pkg packages)
  61       (do-external-symbols (sym pkg)
  62         (when (and (fboundp sym)
  63                    (eq (info :function :kind sym) :function)
  64                    (info :setf :expander sym)
  65                    (not (memq sym ignore)))
  66           (res sym))))
  67     `(progn
  68       ,@(mapcan
  69          (lambda (sym)
  70            (let ((type (type-specifier (proclaimed-ftype sym))))
  71              (aver (consp type))
  72              (list
  73               #-sb-fluid `(declaim (inline (setf ,sym)))
  74               (compute-one-setter sym type))))
  75          (sort (res) #'string<)))))
  76
  77 ) ; EVAL-WHEN
  78
  79 (define-setters ("COMMON-LISP")
  80   ;; Semantically silly...
  81   getf apply ldb mask-field logbitp values
  82   ;; Hairy lambda list
  83   get subseq
  84   ;; Have explicit redundant definitions...
  85   bit sbit aref gethash)