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 (sb!int:/show0 "entering defsetfs.lisp")
  16
  17 ;;; from alieneval.lisp
  18 (in-package "SB!ALIEN")
  19 (defsetf slot %set-slot)
  20 (defsetf deref (alien &rest indices) (value)
  21   `(%set-deref ,alien ,value ,@indices))
  22 (defsetf %heap-alien %set-heap-alien)
  23
  24 ;;; from bignum.lisp
  25 (in-package "SB!BIGNUM")
  26 (defsetf %bignum-ref %bignum-set)
  27
  28 ;;; from bit-bash.lisp
  29 (in-package "SB!VM")
  30 (defsetf word-sap-ref %set-word-sap-ref)
  31
  32 ;;; from debug-int.lisp
  33 (in-package "SB!DI")
  34 (defsetf stack-ref %set-stack-ref)
  35 (defsetf debug-var-value %set-debug-var-value)
  36 (defsetf debug-var-value %set-debug-var-value)
  37 (defsetf breakpoint-info %set-breakpoint-info)
  38
  39 ;;; from defstruct.lisp
  40 (in-package "SB!KERNEL")
  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 (in-package "SB!IMPL")
  55
  56 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
  57 ;;; because they have to work with (setf (apply #'aref array subscripts))
  58 ;;; All other setfs can be done using setf-functions too, but I
  59 ;;; haven't found technical advantages or disadvantages for either
  60 ;;; scheme.
  61 #-sb-xc-host (defsetf car   %rplaca)
  62 #-sb-xc-host (defsetf first %rplaca)
  63 #-sb-xc-host (defsetf cdr   %rplacd)
  64 #-sb-xc-host (defsetf rest  %rplacd)
  65
  66 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
  67 (defun %cxr-setf-expander (sub-accessor setter)
  68   (flet ((expand (place-reader original-form)
  69            (let ((temp (sb!xc:gensym "LIST"))
  70                  (newval (sb!xc:gensym "NEW")))
  71              (values (list temp)
  72                      `((,@place-reader ,@(cdr original-form)))
  73                      (list newval)
  74                      `(,setter ,temp ,newval)
  75                      `(,(if (eq setter '%rplacd) 'cdr 'car) ,temp)))))
  76     (if (eq sub-accessor 'nthcdr) ; random N
  77         (lambda (access-form env)
  78           (declare (ignore env))
  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           (destructuring-bind (list) (cdr access-form) ; for effect
  86             (declare (ignore list)))
  87           (expand sub-accessor access-form))))))
  88
  89 #-sb-xc-host
  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 '(list) nil nil)
  97                   ,@(when alias
  98                       `((!quietly-defsetf ',alias closure '(list) nil 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 #-sb-xc-host
 132 (macrolet ((def (name subform)
 133              `(eval-when (:compile-toplevel :load-toplevel :execute)
 134                 (!quietly-defsetf ',name (%cxr-setf-expander ',subform '%rplaca)
 135                                   '(list) nil nil))))
 136   (def fifth   (nthcdr 4)) ; or CDDDDR
 137   (def sixth   (nthcdr 5))
 138   (def seventh (nthcdr 6))
 139   (def eighth  (nthcdr 7))
 140   (def ninth   (nthcdr 8))
 141   (def tenth   (nthcdr 9)))
 142
 143 ;; CLHS says under the entry for NTH:
 144 ;; "nth may be used to specify a place to setf. Specifically,
 145 ;;  (setf (nth n list) new-object) == (setf (car (nthcdr n list)) new-object)"
 146 ;; which means that it's wrong to use %SETNTH because in the second form,
 147 ;; (NTHCDR ...) is a subform of the CAR expression, and so must be
 148 ;; bound to a temporary variable.
 149 #-sb-xc-host
 150 (eval-when (:compile-toplevel :load-toplevel :execute)
 151   (!quietly-defsetf 'nth (%cxr-setf-expander 'nthcdr '%rplaca) '(n list)
 152                     nil nil))
 153
 154 #-sb-xc-host (defsetf elt %setelt)
 155 #-sb-xc-host (defsetf row-major-aref %set-row-major-aref)
 156 #-sb-xc-host (defsetf svref %svset)
 157 #-sb-xc-host (defsetf char %charset)
 158 #-sb-xc-host (defsetf schar %scharset)
 159 (defsetf %array-dimension %set-array-dimension)
 160 (defsetf %vector-raw-bits %set-vector-raw-bits)
 161 #-sb-xc-host (defsetf symbol-value set)
 162 #-sb-xc-host (defsetf symbol-global-value set-symbol-global-value)
 163 #-sb-xc-host (defsetf symbol-plist %set-symbol-plist)
 164 #-sb-xc-host (defsetf fill-pointer %set-fill-pointer)
 165 (defsetf sap-ref-8 %set-sap-ref-8)
 166 (defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
 167 (defsetf sap-ref-16 %set-sap-ref-16)
 168 (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
 169 (defsetf sap-ref-32 %set-sap-ref-32)
 170 (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 171 (defsetf sap-ref-64 %set-sap-ref-64)
 172 (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
 173 (defsetf sap-ref-word %set-sap-ref-word)
 174 (defsetf signed-sap-ref-word %set-signed-sap-ref-word)
 175 (defsetf sap-ref-sap %set-sap-ref-sap)
 176 (defsetf sap-ref-lispobj %set-sap-ref-lispobj)
 177 (defsetf sap-ref-single %set-sap-ref-single)
 178 (defsetf sap-ref-double %set-sap-ref-double)
 179 #!+long-float (defsetf sap-ref-long %set-sap-ref-long)
 180 #-sb-xc-host (defsetf subseq (sequence start &optional (end nil)) (v)
 181             `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
 182                     ,v))
 183
 184 ;;; from fdefinition.lisp
 185 (in-package "SB!IMPL")
 186 #-sb-xc-host (defsetf fdefinition %set-fdefinition)
 187
 188 ;;; from kernel.lisp
 189 (in-package "SB!KERNEL")
 190 (defsetf code-header-ref code-header-set)
 191
 192 ;;; from x86-vm.lisp
 193 (in-package "SB!VM")
 194 (defsetf context-register %set-context-register)
 195 (defsetf context-float-register %set-context-float-register)
 196
 197
 198 (sb!int:/show0 "leaving defsetfs.lisp")