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