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