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 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 (compile eval)
  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)