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 ;;; [But can't until we fix the "lexical environment too hairy" warning.
  37 ;;;  And this environment isn't too hairy so it's especially annoying]
  38 (sb!xc:defmacro define-setters (packages &rest ignore)
  39   (collect ((res))
  40     (dolist (pkg packages)
  41       (do-external-symbols (sym pkg)
  42         (when (and (fboundp sym)
  43                    (eq (info :function :kind sym) :function)
  44                    (or (info :setf :inverse sym)
  45                        (info :setf :expander sym))
  46                    (not (member sym ignore)))
  47           (res sym))))
  48     `(progn
  49       ,@(mapcan
  50          (lambda (sym)
  51            (let ((type (type-specifier (info :function :type sym))))
  52              (aver (consp type))
  53              (list
  54               #!-sb-fluid `(declaim (inline (setf ,sym)))
  55               (compute-one-setter sym type))))
  56          (sort (res) #'string<)))))
  57
  58 ) ; EVAL-WHEN
  59
  60 (define-setters ("COMMON-LISP")
  61   ;; Semantically silly...
  62   getf apply ldb mask-field logbitp values
  63   ;; Hairy lambda list
  64   get subseq
  65   ;; Have explicit redundant definitions...
  66   bit sbit aref gethash)