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 (file-comment
  16   "$Header$")
  17
  18 (eval-when (:compile-toplevel :execute)
  19
  20 (defun compute-one-setter (name type)
  21   (let* ((args (second type))
  22          (res (type-specifier
  23                (single-value-type
  24                 (values-specifier-type (third type)))))
  25          (arglist (loop repeat (1+ (length args)) collect (gensym))))
  26     (cond
  27      ((null (intersection args lambda-list-keywords))
  28       `(defun (setf ,name) ,arglist
  29          (declare ,@(mapcar #'(lambda (arg type)
  30                                 `(type ,type ,arg))
  31                             arglist
  32                             (cons res args)))
  33          (setf (,name ,@(rest arglist)) ,(first arglist))))
  34      (t
  35       (warn "hairy SETF expander for function ~S" name)
  36       nil))))
  37
  38 ;;; FIXME: should probably become MACROLET
  39 (sb!xc:defmacro define-setters (packages &rest ignore)
  40   (collect ((res))
  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))))
  49             (assert (consp type))
  50             #!-sb-fluid (res `(declaim (inline (setf ,sym))))
  51             (res (compute-one-setter sym type))))))
  52     `(progn ,@(res))))
  53
  54 ); eval-when (compile eval)
  55
  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)