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 (make-symbol "LIST"))
  70                  (newval (make-symbol "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           (declare (sb!c::lambda-list (n list)))
  80           (destructuring-bind (n list) (cdr access-form) ; for effect
  81             (declare (ignore n list)))
  82           (expand '(nthcdr) access-form))
  83         ;; NTHCDR of fixed N, or CxxxxR composition
  84         (lambda (access-form env)
  85           (declare (ignore env))
  86           (declare (sb!c::lambda-list (list)))
  87           (destructuring-bind (list) (cdr access-form) ; for effect
  88             (declare (ignore list)))
  89           (expand sub-accessor access-form))))))
  90
  91 #-sb-xc-host
  92 (macrolet ((def (name &optional alias &aux (string (string name)))
  93              `(eval-when (:compile-toplevel :load-toplevel :execute)
  94                 (let ((closure
  95                        (%cxr-setf-expander
  96                         '(,(symbolicate "C" (subseq string 2)))
  97                         ',(symbolicate "%RPLAC" (subseq string 1 2)))))
  98                   (!quietly-defsetf ',name closure nil)
  99                   ,@(when alias
 100                       `((!quietly-defsetf ',alias closure nil)))))))
 101   ;; Rather than expand into a DEFINE-SETF-EXPANDER, install a single closure
 102   ;; as the expander and capture just enough to distinguish the variations.
 103   (def caar)
 104   (def cadr second)
 105   (def cdar)
 106   (def cddr)
 107   (def caaar)
 108   (def cadar)
 109   (def cdaar)
 110   (def cddar)
 111   (def caadr)
 112   (def caddr third)
 113   (def cdadr)
 114   (def cdddr)
 115   (def caaaar)
 116   (def cadaar)
 117   (def cdaaar)
 118   (def cddaar)
 119   (def caadar)
 120   (def caddar)
 121   (def cdadar)
 122   (def cdddar)
 123   (def caaadr)
 124   (def cadadr)
 125   (def cdaadr)
 126   (def cddadr)
 127   (def caaddr)
 128   (def cadddr fourth)
 129   (def cdaddr)
 130   (def cddddr))
 131
 132 ;; FIFTH through TENTH
 133 #-sb-xc-host
 134 (macrolet ((def (name subform)
 135              `(eval-when (:compile-toplevel :load-toplevel :execute)
 136                 (!quietly-defsetf ',name (%cxr-setf-expander ',subform '%rplaca)
 137                                   nil))))
 138   (def fifth   (nthcdr 4)) ; or CDDDDR
 139   (def sixth   (nthcdr 5))
 140   (def seventh (nthcdr 6))
 141   (def eighth  (nthcdr 7))
 142   (def ninth   (nthcdr 8))
 143   (def tenth   (nthcdr 9)))
 144
 145 ;; CLHS says under the entry for NTH:
 146 ;; "nth may be used to specify a place to setf. Specifically,
 147 ;;  (setf (nth n list) new-object) == (setf (car (nthcdr n list)) new-object)"
 148 ;; which means that it's wrong to use %SETNTH because in the second form,
 149 ;; (NTHCDR ...) is a subform of the CAR expression, and so must be
 150 ;; bound to a temporary variable.
 151 #-sb-xc-host
 152 (eval-when (:compile-toplevel :load-toplevel :execute)
 153   (!quietly-defsetf 'nth (%cxr-setf-expander 'nthcdr '%rplaca) nil))
 154
 155 #-sb-xc-host (defsetf elt %setelt)
 156 #-sb-xc-host (defsetf row-major-aref %set-row-major-aref)
 157 #-sb-xc-host (defsetf svref %svset)
 158 #-sb-xc-host (defsetf char %charset)
 159 #-sb-xc-host (defsetf schar %scharset)
 160 (defsetf %array-dimension %set-array-dimension)
 161 (defsetf %vector-raw-bits %set-vector-raw-bits)
 162 #-sb-xc-host (defsetf symbol-value set)
 163 #-sb-xc-host (defsetf symbol-global-value set-symbol-global-value)
 164 #-sb-xc-host (defsetf symbol-plist %set-symbol-plist)
 165 #-sb-xc-host (defsetf fill-pointer %set-fill-pointer)
 166 (defsetf sap-ref-8 %set-sap-ref-8)
 167 (defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
 168 (defsetf sap-ref-16 %set-sap-ref-16)
 169 (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
 170 (defsetf sap-ref-32 %set-sap-ref-32)
 171 (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
 172 (defsetf sap-ref-64 %set-sap-ref-64)
 173 (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
 174 (defsetf sap-ref-word %set-sap-ref-word)
 175 (defsetf signed-sap-ref-word %set-signed-sap-ref-word)
 176 (defsetf sap-ref-sap %set-sap-ref-sap)
 177 (defsetf sap-ref-lispobj %set-sap-ref-lispobj)
 178 (defsetf sap-ref-single %set-sap-ref-single)
 179 (defsetf sap-ref-double %set-sap-ref-double)
 180 #!+long-float (defsetf sap-ref-long %set-sap-ref-long)
 181 #-sb-xc-host (defsetf subseq (sequence start &optional (end nil)) (v)
 182             `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
 183                     ,v))
 184
 185 ;;; from fdefinition.lisp
 186 (in-package "SB!IMPL")
 187 #-sb-xc-host (defsetf fdefinition %set-fdefinition)
 188
 189 ;;; from kernel.lisp
 190 (in-package "SB!KERNEL")
 191 (defsetf code-header-ref code-header-set)
 192
 193 ;;; from x86-vm.lisp
 194 (in-package "SB!VM")
 195 (defsetf context-register %set-context-register)
 196 (defsetf context-float-register %set-context-float-register)
 197
 198
 199 (sb!int:/show0 "leaving defsetfs.lisp")