"STRING<*" "STRING/=*" "%SVSET"
"%SP-STRING-COMPARE" "%SETNTH" "%SETELT"
"%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER"
- "%SET-FDEFINITION" "%SCHARSET" "%SBITSET"
- "%RPLACD" "%RPLACA" "%PUT" "%CHARSET" "%BITSET"
- "%ASET"))
+ "%SET-FDEFINITION" "%SCHARSET"
+ "%RPLACD" "%RPLACA" "%PUT" "%CHARSET"))
#s(sb-cold:package-data
:name "SB!THREAD"
(declare (truly-dynamic-extent subscripts))
(row-major-aref array (%array-row-major-index array subscripts)))
-(defun %aset (array &rest stuff)
- (declare (truly-dynamic-extent stuff))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref array (%array-row-major-index array subscripts))
- new-value)))
-
-;;; FIXME: What's supposed to happen with functions
-;;; like AREF when we (DEFUN (SETF FOO) ..) when
-;;; DEFSETF FOO is also defined? It seems as though the logical
-;;; thing to do would be to nuke the macro definition for (SETF FOO)
-;;; and replace it with the (SETF FOO) function, issuing a warning,
-;;; just as for ordinary functions
-;;; * (LISP-IMPLEMENTATION-VERSION)
-;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
-;;; * (DEFMACRO ZOO (X) `(+ ,X ,X))
-;;; ZOO
-;;; * (DEFUN ZOO (X) (* 3 X))
-;;; Warning: ZOO previously defined as a macro.
-;;; ZOO
-;;; But that doesn't seem to be what happens in CMU CL.
-;;;
-;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS
-;;; 5.1.2.5) requires implementations to support
-;;; (SETF (APPLY #'AREF ...) ...)
-;;; [and also #'BIT and #'SBIT]. Yes, this is terrifying, and it's
-;;; also terrifying that this sequence of definitions causes it to
-;;; work.
-;;;
-;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
-;;; has a setf expansion and/or a setf function defined.
-
-#!-sb-fluid (declaim (inline (setf aref)))
+;;; (setf aref/bit/sbit) are implemented using setf-functions,
+;;; because they have to work with (setf (apply #'aref array subscripts))
+;;; All other setfs can be done using setf-functions too, but I
+;;; haven't found technical advantages or disatvantages for either
+;;; scheme.
(defun (setf aref) (new-value array &rest subscripts)
- (declare (truly-dynamic-extent subscripts))
- (declare (type array array))
+ (declare (truly-dynamic-extent subscripts)
+ (type array array))
(setf (row-major-aref array (%array-row-major-index array subscripts))
new-value))
(defun bit (bit-array &rest subscripts)
#!+sb-doc
"Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
- (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (declare (type (array bit) bit-array)
+ (optimize (safety 1)))
(row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
-(defun %bitset (bit-array &rest stuff)
- (declare (type (array bit) bit-array) (optimize (safety 1)))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref bit-array
- (%array-row-major-index bit-array subscripts))
- new-value)))
-
-#!-sb-fluid (declaim (inline (setf bit)))
(defun (setf bit) (new-value bit-array &rest subscripts)
- (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (declare (type (array bit) bit-array)
+ (type bit new-value)
+ (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
(defun sbit (simple-bit-array &rest subscripts)
#!+sb-doc
"Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
- (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
+ (declare (type (simple-array bit) simple-bit-array)
+ (optimize (safety 1)))
(row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts)))
-;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
-;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
-;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
-;;; -- WHN 19990911
-(defun %sbitset (simple-bit-array &rest stuff)
- (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
- (let ((subscripts (butlast stuff))
- (new-value (car (last stuff))))
- (setf (row-major-aref simple-bit-array
- (%array-row-major-index simple-bit-array subscripts))
- new-value)))
-
-#!-sb-fluid (declaim (inline (setf sbit)))
(defun (setf sbit) (new-value bit-array &rest subscripts)
- (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
+ (declare (type (simple-array bit) bit-array)
+ (type bit new-value)
+ (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
;;; from early-setf.lisp
(in-package "SB!IMPL")
-;;; KLUDGE: Various of these (e.g. AREF and BIT) have DEFUN (SETF FOO) versions
-;;; too. Do we really need both? -- WHN 19990921
+;;; (setf aref/bit/sbit) are implemented using setf-functions,
+;;; because they have to work with (setf (apply #'aref array subscripts))
+;;; All other setfs can be done using setf-functions too, but I
+;;; haven't found technical advantages or disatvantages for either
+;;; scheme.
#-sb-xc-host (defsetf car %rplaca)
#-sb-xc-host (defsetf cdr %rplacd)
#-sb-xc-host (defsetf caar (x) (v) `(%rplaca (car ,x) ,v))
#-sb-xc-host (defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v))
#-sb-xc-host (defsetf rest %rplacd)
#-sb-xc-host (defsetf elt %setelt)
-#-sb-xc-host (defsetf aref %aset)
#-sb-xc-host (defsetf row-major-aref %set-row-major-aref)
#-sb-xc-host (defsetf svref %svset)
#-sb-xc-host (defsetf char %charset)
-#-sb-xc-host (defsetf bit %bitset)
#-sb-xc-host (defsetf schar %scharset)
-#-sb-xc-host (defsetf sbit %sbitset)
(defsetf %array-dimension %set-array-dimension)
(defsetf sb!kernel:%vector-raw-bits sb!kernel:%set-vector-raw-bits)
#-sb-xc-host (defsetf symbol-value set)
(assert-array-rank array (length indices))
(derive-aref-type array))
-(defoptimizer (%aset derive-type) ((array &rest stuff))
- (assert-array-rank array (1- (length stuff)))
- (assert-new-value-type (car (last stuff)) array))
+(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts))
+ (assert-array-rank array (length subscripts))
+ (assert-new-value-type new-value array))
(macrolet ((define (name)
`(defoptimizer (,name derive-type) ((array index))
\f
;;;; array accessors
-;;; We convert all typed array accessors into AREF and %ASET with type
+;;; We convert all typed array accessors into AREF and (SETF AREF) with type
;;; assertions on the array.
-(macrolet ((define-bit-frob (reffer setter simplep)
+(macrolet ((define-bit-frob (reffer simplep)
`(progn
(define-source-transform ,reffer (a &rest i)
`(aref (the (,',(if simplep 'simple-array 'array)
bit
,(mapcar (constantly '*) i))
,a) ,@i))
- (define-source-transform ,setter (a &rest i)
- `(%aset (the (,',(if simplep 'simple-array 'array)
- bit
- ,(cdr (mapcar (constantly '*) i)))
- ,a) ,@i)))))
- (define-bit-frob sbit %sbitset t)
- (define-bit-frob bit %bitset nil))
+ (define-source-transform (setf ,reffer) (value a &rest i)
+ `(setf (aref (the (,',(if simplep 'simple-array 'array)
+ bit
+ ,(mapcar (constantly '*) i))
+ ,a) ,@i)
+ ,value)))))
+ (define-bit-frob sbit t)
+ (define-bit-frob bit nil))
+
(macrolet ((define-frob (reffer setter type)
`(progn
(define-source-transform ,reffer (a i)
`(aref (the ,',type ,a) ,i))
(define-source-transform ,setter (a i v)
- `(%aset (the ,',type ,a) ,i ,v)))))
+ `(setf (aref (the ,',type ,a) ,i) ,v)))))
(define-frob schar %scharset simple-string)
(define-frob char %charset string))
(push (make-symbol (format nil "DIM-~D" i)) dims))
(setf n-indices (nreverse n-indices))
(setf dims (nreverse dims))
- `(lambda (,',array ,@n-indices
- ,@',(when new-value (list new-value)))
+ `(lambda (,@',(when new-value (list new-value))
+ ,',array ,@n-indices)
(let* (,@(let ((,index -1))
(mapcar (lambda (name)
`(,name (array-dimension
(with-row-major-index (array indices index)
index))
- ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
+ ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or
;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
;; expression for the row major index.
(deftransform aref ((array &rest indices))
(with-row-major-index (array indices index)
(hairy-data-vector-ref array index)))
- (deftransform %aset ((array &rest stuff))
- (let ((indices (butlast stuff)))
- (with-row-major-index (array indices index new-value)
- (hairy-data-vector-set array index new-value)))))
+ (deftransform (setf aref) ((new-value array &rest subscripts))
+ (with-row-major-index (array subscripts index new-value)
+ (hairy-data-vector-set array index new-value))))
;; For AREF of vectors we do the bounds checking in the callee. This
;; lets us do a significantly more efficient check for simple-arrays
`(hairy-data-vector-ref array index))
(t `(hairy-data-vector-ref/check-bounds array index)))))
-(deftransform %aset ((array index new-value) (t t t) * :node node)
+(deftransform (setf aref) ((new-value array index) (t t t) * :node node)
(if (policy node (zerop insert-array-bounds-checks))
`(hairy-data-vector-set array index new-value)
`(hairy-data-vector-set/check-bounds array index new-value)))
\f
;;;; SETF inverses
-(defknown %aset (array &rest t) t ()
- :destroyed-constant-args (nth-constant-args 1))
+(defknown (setf aref) (t array &rest index) t ()
+ :destroyed-constant-args (nth-constant-args 2)
+ :derive-type #'result-type-first-arg)
(defknown %set-row-major-aref (array index t) t ()
:destroyed-constant-args (nth-constant-args 1))
(defknown (%rplaca %rplacd) (cons t) t ()
:derive-type #'result-type-last-arg)
(defknown %svset (simple-vector index t) t ()
:destroyed-constant-args (nth-constant-args 1))
-(defknown %bitset ((array bit) &rest index) bit ()
- :destroyed-constant-args (nth-constant-args 1))
-(defknown %sbitset ((simple-array bit) &rest index) bit ()
- :destroyed-constant-args (nth-constant-args 1))
+(defknown (setf bit) (bit (array bit) &rest index) bit ()
+ :destroyed-constant-args (nth-constant-args 2))
+(defknown (setf sbit) (bit (simple-array bit) &rest index) bit ()
+ :destroyed-constant-args (nth-constant-args 2))
(defknown %charset (string index character) character ()
:destroyed-constant-args (nth-constant-args 1))
(defknown %scharset (simple-string index character) character ()
(defmacro defoptimizer (what (lambda-list &optional (n-node (sb!xc:gensym))
&rest vars)
&body body)
- (let ((name (if (symbolp what) what
- (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
-
- (let ((n-args (gensym)))
- `(progn
- (defun ,name (,n-node ,@vars)
- (declare (ignorable ,@vars))
- (let ((,n-args (basic-combination-args ,n-node)))
- ,(parse-deftransform lambda-list body n-args
- `(return-from ,name nil))))
- ,@(when (consp what)
- `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
- (symbolicate "FUN-INFO-" (second what)))
- (fun-info-or-lose ',(first what)))
- #',name)))))))
+ (flet ((function-name (name)
+ (etypecase name
+ (symbol name)
+ ((cons (eql setf) (cons symbol null))
+ (symbolicate (car name) "-" (cadr name))))))
+ (let ((name (if (symbolp what)
+ what
+ (symbolicate (function-name (first what))
+ "-" (second what) "-OPTIMIZER"))))
+
+ (let ((n-args (gensym)))
+ `(progn
+ (defun ,name (,n-node ,@vars)
+ (declare (ignorable ,@vars))
+ (let ((,n-args (basic-combination-args ,n-node)))
+ ,(parse-deftransform lambda-list body n-args
+ `(return-from ,name nil))))
+ ,@(when (consp what)
+ `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
+ (symbolicate "FUN-INFO-" (second what)))
+ (fun-info-or-lose ',(first what)))
+ #',name))))))))
\f
;;;; IR groveling macros
'(nth i s))
(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
- '(%aset s i v))
+ '(setf (aref s i) v))
(deftransform %setelt ((s i v) (list * *) * :policy (< safety 3))
'(setf (car (nthcdr i s)) v))
rest)))))
(dotimes (i limit)
(test-function (make-function i) i)))))
+
+(with-test (:name :apply-aref)
+ (flet ((test (form)
+ (let (warning)
+ (handler-bind ((warning (lambda (c) (setf warning c))))
+ (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
+ (assert (not warning)))))
+ (test `(lambda (x y) (setf (apply #'aref x y) 21)))
+ (test `(lambda (x y) (setf (apply #'bit x y) 1)))
+ (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
projects / sbcl.git / commitdiff