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 (sb-kernel:%fun-lambda-list
  38                                     (symbol-function name)))))
  39         `(locally
  40           (declare (muffle-conditions
  41                     ;; Expect SETF macro + function warnings.
  42                     (and style-warning
  43                          ;; Expect none of these,
  44                          ;; but just to make sure, show them.
  45                          (not sb-c:inlining-dependency-failure))))
  46           (defun (setf ,name) ,arglist
  47             (declare ,@(mapcar (lambda (arg type) `(type ,type ,arg))
  48                                arglist (cons res args)))
  49             (setf (,name ,@(rest arglist)) ,(first arglist))))))
  50      (t
  51       (warn "hairy SETF expander for function ~S" name)
  52       nil))))
  53
  54 ;;; FIXME: should probably become MACROLET, but inline functions
  55 ;;; within a macrolet capture the whole macrolet, which is dumb.
  56 (defmacro define-setters (packages &rest ignore)
  57   (collect ((res))
  58     (dolist (pkg packages)
  59       (do-external-symbols (sym pkg)
  60         (when (and (fboundp sym)
  61                    (eq (info :function :kind sym) :function)
  62                    (info :setf :expander sym)
  63                    (not (memq sym ignore)))
  64           (res sym))))
  65     `(progn
  66       ,@(mapcan
  67          (lambda (sym)
  68            (let ((type (type-specifier (proclaimed-ftype sym))))
  69              (aver (consp type))
  70              (list
  71               #-sb-fluid `(declaim (inline (setf ,sym)))
  72               (compute-one-setter sym type))))
  73          (sort (res) #'string<)))))
  74
  75 ) ; EVAL-WHEN
  76
  77 (define-setters ("COMMON-LISP")
  78   ;; Semantically silly...
  79   getf apply ldb mask-field logbitp values
  80   ;; Hairy lambda list
  81   get subseq
  82   ;; Have explicit redundant definitions...
  83   bit sbit aref gethash)