src/code/defsetfs.lisp

   1 ;;;; various DEFSETFs, pulled into one file for convenience in doing
   2 ;;;; them as early in the build process as possible so as to avoid
   3 ;;;; hassles with invoking SETF FOO before DEFSETF FOO and thus
   4 ;;;; compiling a call to some nonexistent function #'(SETF FOO)
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 ;;; from alieneval.lisp
  16 (in-package "SB!ALIEN")
  17 (defsetf slot %set-slot)
  18 (defsetf deref (alien &rest indices) (value)
  19   `(%set-deref ,alien ,value ,@indices))
  20 (defsetf %heap-alien %set-heap-alien)
  21
  22 ;;; from arch-vm.lisp
  23 (in-package "SB!VM")
  24 (defsetf context-register %set-context-register)
  25 (defsetf context-float-register %set-context-float-register)
  26 ;;; from bit-bash.lisp
  27 (defsetf word-sap-ref %set-word-sap-ref)
  28
  29 ;;; from debug-int.lisp
  30 (in-package "SB!DI")
  31 (defsetf stack-ref %set-stack-ref)
  32 (defsetf debug-var-value %set-debug-var-value)
  33 (defsetf debug-var-value %set-debug-var-value)
  34 (defsetf breakpoint-info %set-breakpoint-info)
  35
  36 ;;; from bignum.lisp
  37 (in-package "SB!IMPL")
  38 (defsetf %bignum-ref %bignum-set)
  39
  40 ;;; from defstruct.lisp
  41 (defsetf %instance-ref %instance-set)
  42
  43 (defsetf %raw-instance-ref/word %raw-instance-set/word)
  44 (defsetf %raw-instance-ref/single %raw-instance-set/single)
  45 (defsetf %raw-instance-ref/double %raw-instance-set/double)
  46 (defsetf %raw-instance-ref/complex-single %raw-instance-set/complex-single)
  47 (defsetf %raw-instance-ref/complex-double %raw-instance-set/complex-double)
  48
  49 (defsetf %instance-layout %set-instance-layout)
  50 (defsetf %funcallable-instance-info %set-funcallable-instance-info)
  51 (defsetf %funcallable-instance-layout %set-funcallable-instance-layout)
  52
  53 ;;; from early-setf.lisp
  54
  55 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
  56 ;;; because they have to work with (setf (apply #'aref array subscripts))
  57 ;;; All other setfs can be done using setf-functions too, but I
  58 ;;; haven't found technical advantages or disadvantages for either
  59 ;;; scheme.
  60 (defsetf car   %rplaca)
  61 (defsetf first %rplaca)
  62 (defsetf cdr   %rplacd)
  63 (defsetf rest  %rplacd)
  64
  65 (eval-when (:compile-toplevel :load-toplevel :execute)
  66 (defun %cxr-setf-expander (sub-accessor setter)
  67   (flet ((expand (place-reader original-form)
  68            (let ((temp (make-symbol "LIST"))
  69                  (newval (make-symbol "NEW")))
  70              (values (list temp)
  71                      `((,@place-reader ,@(cdr original-form)))
  72                      (list newval)
  73                      `(,setter ,temp ,newval)
  74                      `(,(if (eq setter '%rplacd) 'cdr 'car) ,temp)))))
  75     (if (eq sub-accessor 'nthcdr) ; random N
  76         (lambda (access-form env)
  77           (declare (ignore env))
  78           (declare (sb!c::lambda-list (n list)))
  79           (destructuring-bind (n list) (cdr access-form) ; for effect
  80             (declare (ignore n list)))
  81           (expand '(nthcdr) access-form))
  82         ;; NTHCDR of fixed N, or CxxxxR composition
  83         (lambda (access-form env)
  84           (declare (ignore env))
  85           (declare (sb!c::lambda-list (list)))
  86           (destructuring-bind (list) (cdr access-form) ; for effect
  87             (declare (ignore list)))
  88           (expand sub-accessor access-form))))))
  89
  90 (macrolet ((def (name &optional alias &aux (string (string name)))
  91              `(eval-when (:compile-toplevel :load-toplevel :execute)
  92                 (let ((closure
  93                        (%cxr-setf-expander
  94                         '(,(symbolicate "C" (subseq string 2)))
  95                         ',(symbolicate "%RPLAC" (subseq string 1 2)))))
  96                   (!quietly-defsetf ',name closure nil)
  97                   ,@(when alias
  98                       `((!quietly-defsetf ',alias closure nil)))))))
  99   ;; Rather than expand into a DEFINE-SETF-EXPANDER, install a single closure
 100   ;; as the expander and capture just enough to distinguish the variations.
 101   (def caar)
 102   (def cadr second)
 103   (def cdar)
 104   (def cddr)
 105   (def caaar)
 106   (def cadar)
 107   (def cdaar)
 108   (def cddar)
 109   (def caadr)
 110   (def caddr third)
 111   (def cdadr)
 112   (def cdddr)
 113   (def caaaar)
 114   (def cadaar)
 115   (def cdaaar)
 116   (def cddaar)
 117   (def caadar)
 118   (def caddar)
 119   (def cdadar)
 120   (def cdddar)
 121   (def caaadr)
 122   (def cadadr)
 123   (def cdaadr)
 124   (def cddadr)
 125   (def caaddr)
 126   (def cadddr fourth)
 127   (def cdaddr)
 128   (def cddddr))
 129
 130 ;; FIFTH through TENTH
 131 (macrolet ((def (name subform)
 132              `(eval-when (:compile-toplevel :load-toplevel :execute)
 133                 (!quietly-defsetf ',name (%cxr-setf-expander ',subform '%rplaca)
 134                                   nil))))
 135   (def fifth   (nthcdr 4)) ; or CDDDDR
 136   (def sixth   (nthcdr 5))
 137   (def seventh (nthcdr 6))
 138   (def eighth  (nthcdr 7))
 139   (def ninth   (nthcdr 8))
 140   (def tenth   (nthcdr 9)))
 141
 142 ;; CLHS says under the entry for NTH:
 143 ;; "nth may be used to specify a place to setf. Specifically,
 144 ;;  (setf (nth n list) new-object) == (setf (car (nthcdr n list)) new-object)"
 145 ;; which means that it's wrong to use %SETNTH because in the second form,
 146 ;; (NTHCDR ...) is a subform of the CAR expression, and so must be
 147 ;; bound to a temporary variable.
 148 (eval-when (:compile-toplevel :load-toplevel :execute)
 149   (!quietly-defsetf 'nth (%cxr-setf-expander 'nthcdr '%rplaca) nil))
 150
 151 (defsetf elt %setelt)
 152 (defsetf row-major-aref %set-row-major-aref)
 153 (defsetf svref %svset)
 154 (defsetf char %charset)
 155 (defsetf schar %scharset)
 156 (defsetf %array-dimension %set-array-dimension)
 157 (defsetf %vector-raw-bits %set-vector-raw-bits)
 158 (defsetf symbol-value set)
 159 (defsetf symbol-global-value set-symbol-global-value)
 160 (defsetf symbol-plist %set-symbol-plist)
 161 (defsetf fill-pointer %set-fill-pointer)
 162 (defsetf sap-ref-8 %set-sap-ref-8)
 163 (defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
 164 (defsetf sap-ref-16 %set-sap-ref-16)
 165 (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
 166 (defsetf sap-ref-32 %set-sap-ref-32)
 167 (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 168 (defsetf sap-ref-64 %set-sap-ref-64)
 169 (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
 170 (defsetf sap-ref-word %set-sap-ref-word)
 171 (defsetf signed-sap-ref-word %set-signed-sap-ref-word)
 172 (defsetf sap-ref-sap %set-sap-ref-sap)
 173 (defsetf sap-ref-lispobj %set-sap-ref-lispobj)
 174 (defsetf sap-ref-single %set-sap-ref-single)
 175 (defsetf sap-ref-double %set-sap-ref-double)
 176 #!+long-float (defsetf sap-ref-long %set-sap-ref-long)
 177 (defsetf subseq (sequence start &optional end) (v)
 178   `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v))
 179
 180 ;;; from fdefinition.lisp
 181 (defsetf fdefinition %set-fdefinition)
 182
 183 ;;; from kernel.lisp
 184 (defsetf code-header-ref code-header-set)