X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=36ceafbfa5a0f6df45f00bcb0b68f05c109de2ae;hb=aa61c7571b33b86981301f34d3acdb66666f53a3;hp=38c10fc9da93c7e6c355334ce32966941cbf350d;hpb=031ae238d37250e935dabaf2a3efb6e0305dd3e7;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 38c10fc..36ceafb 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -63,8 +63,8 @@ (sb!xc:defmacro pick-vector-type (type &rest specs) `(cond ,@(mapcar #'(lambda (spec) `(,(if (eq (car spec) t) - t - `(subtypep ,type ',(car spec))) + t + `(subtypep ,type ',(car spec))) ,@(cdr spec))) specs)))) @@ -75,7 +75,7 @@ ;;; MAKE-ARRAY for any non-simple array. Thus, there's some value to ;;; making this somewhat efficient, at least not doing full calls to ;;; SUBTYPEP in the easy cases. -(defun %vector-type-code (type) +(defun %vector-widetag-and-n-bits (type) (case type ;; Pick off some easy common cases. ;; @@ -84,66 +84,67 @@ ;; on smarter compiler transforms which do the calculation once ;; and for all in any reasonable user programs.) ((t) - (values #.sb!vm:simple-vector-type #.sb!vm:word-bits)) + (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)) ((character base-char standard-char) - (values #.sb!vm:simple-string-type #.sb!vm:byte-bits)) + (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits)) ((bit) - (values #.sb!vm:simple-bit-vector-type 1)) + (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. (t ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-vector-type type - (base-char (values #.sb!vm:simple-string-type #.sb!vm:byte-bits)) - (bit (values #.sb!vm:simple-bit-vector-type 1)) + (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits)) + (bit (values #.sb!vm:simple-bit-vector-widetag 1)) ((unsigned-byte 2) - (values #.sb!vm:simple-array-unsigned-byte-2-type 2)) + (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2)) ((unsigned-byte 4) - (values #.sb!vm:simple-array-unsigned-byte-4-type 4)) + (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4)) ((unsigned-byte 8) - (values #.sb!vm:simple-array-unsigned-byte-8-type 8)) + (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8)) ((unsigned-byte 16) - (values #.sb!vm:simple-array-unsigned-byte-16-type 16)) + (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16)) ((unsigned-byte 32) - (values #.sb!vm:simple-array-unsigned-byte-32-type 32)) + (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32)) ((signed-byte 8) - (values #.sb!vm:simple-array-signed-byte-8-type 8)) + (values #.sb!vm:simple-array-signed-byte-8-widetag 8)) ((signed-byte 16) - (values #.sb!vm:simple-array-signed-byte-16-type 16)) + (values #.sb!vm:simple-array-signed-byte-16-widetag 16)) ((signed-byte 30) - (values #.sb!vm:simple-array-signed-byte-30-type 32)) + (values #.sb!vm:simple-array-signed-byte-30-widetag 32)) ((signed-byte 32) - (values #.sb!vm:simple-array-signed-byte-32-type 32)) - (single-float (values #.sb!vm:simple-array-single-float-type 32)) - (double-float (values #.sb!vm:simple-array-double-float-type 64)) + (values #.sb!vm:simple-array-signed-byte-32-widetag 32)) + (single-float (values #.sb!vm:simple-array-single-float-widetag 32)) + (double-float (values #.sb!vm:simple-array-double-float-widetag 64)) #!+long-float (long-float - (values #.sb!vm:simple-array-long-float-type #!+x86 96 #!+sparc 128)) + (values #.sb!vm:simple-array-long-float-widetag + #!+x86 96 #!+sparc 128)) ((complex single-float) - (values #.sb!vm:simple-array-complex-single-float-type 64)) + (values #.sb!vm:simple-array-complex-single-float-widetag 64)) ((complex double-float) - (values #.sb!vm:simple-array-complex-double-float-type 128)) + (values #.sb!vm:simple-array-complex-double-float-widetag 128)) #!+long-float ((complex long-float) - (values #.sb!vm:simple-array-complex-long-float-type + (values #.sb!vm:simple-array-complex-long-float-widetag #!+x86 192 #!+sparc 256)) - (t (values #.sb!vm:simple-vector-type #.sb!vm:word-bits)))))) -(defun %complex-vector-type-code (type) + (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)))))) +(defun %complex-vector-widetag (type) (case type ;; Pick off some easy common cases. ((t) - #.sb!vm:complex-vector-type) + #.sb!vm:complex-vector-widetag) ((character base-char) - #.sb!vm:complex-string-type) + #.sb!vm:complex-string-widetag) ((bit) - #.sb!vm:complex-bit-vector-type) + #.sb!vm:complex-bit-vector-widetag) ;; OK, we have to wade into SUBTYPEPing after all. (t (pick-vector-type type - (base-char #.sb!vm:complex-string-type) - (bit #.sb!vm:complex-bit-vector-type) - (t #.sb!vm:complex-vector-type))))) + (base-char #.sb!vm:complex-string-widetag) + (bit #.sb!vm:complex-bit-vector-widetag) + (t #.sb!vm:complex-vector-widetag))))) (defun make-array (dimensions &key (element-type t) @@ -160,18 +161,19 @@ (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) (if (and simple (= array-rank 1)) ;; Its a (simple-array * (*)) - (multiple-value-bind (type bits) (%vector-type-code element-type) + (multiple-value-bind (type n-bits) + (%vector-widetag-and-n-bits element-type) (declare (type (unsigned-byte 8) type) - (type (integer 1 256) bits)) + (type (integer 1 256) n-bits)) (let* ((length (car dimensions)) (array (allocate-vector type length - (ceiling (* (if (= type sb!vm:simple-string-type) + (ceiling (* (if (= type sb!vm:simple-string-widetag) (1+ length) length) - bits) - sb!vm:word-bits)))) + n-bits) + sb!vm:n-word-bits)))) (declare (type index length)) (when initial-element-p (fill array initial-element)) @@ -194,9 +196,9 @@ initial-contents initial-element initial-element-p))) (array (make-array-header (cond ((= array-rank 1) - (%complex-vector-type-code element-type)) - (simple sb!vm:simple-array-type) - (t sb!vm:complex-array-type)) + (%complex-vector-widetag element-type)) + (simple sb!vm:simple-array-widetag) + (t sb!vm:complex-array-widetag)) array-rank))) (cond (fill-pointer (unless (= array-rank 1) @@ -372,7 +374,7 @@ (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Returns T if the Subscipts are in bounds for the Array, Nil otherwise." + "Return T if the Subscipts are in bounds for the Array, Nil otherwise." (if (%array-row-major-index array subscripts nil) t)) @@ -381,7 +383,7 @@ (defun aref (array &rest subscripts) #!+sb-doc - "Returns the element of the Array specified by the Subscripts." + "Return the element of the Array specified by the Subscripts." (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) @@ -416,7 +418,7 @@ (defun row-major-aref (array index) #!+sb-doc - "Returns the element of array corressponding to the row-major index. This is + "Return the element of array corressponding to the row-major index. This is SETF'able." (declare (optimize (safety 1))) (row-major-aref array index)) @@ -427,7 +429,7 @@ (defun svref (simple-vector index) #!+sb-doc - "Returns the Index'th element of the given Simple-Vector." + "Return the INDEX'th element of the given Simple-Vector." (declare (optimize (safety 1))) (aref simple-vector index)) @@ -437,7 +439,7 @@ (defun bit (bit-array &rest subscripts) #!+sb-doc - "Returns the bit from the Bit-Array at the specified Subscripts." + "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS." (declare (type (array bit) bit-array) (optimize (safety 1))) (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) @@ -458,7 +460,7 @@ (defun sbit (simple-bit-array &rest subscripts) #!+sb-doc - "Returns the bit from the Simple-Bit-Array at the specified Subscripts." + "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." (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))) @@ -486,8 +488,8 @@ (defun array-element-type (array) #!+sb-doc - "Returns the type of the elements of the array" - (let ((type (get-type array))) + "Return the type of the elements of the array" + (let ((widetag (widetag-of array))) (macrolet ((pick-element-type (&rest stuff) `(cond ,@(mapcar #'(lambda (stuff) (cons @@ -496,38 +498,42 @@ t) ((listp item) (cons 'or - (mapcar #'(lambda (x) - `(= type ,x)) + (mapcar (lambda (x) + `(= widetag ,x)) item))) (t - `(= type ,item)))) + `(= widetag ,item)))) (cdr stuff))) stuff)))) ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-element-type - ((sb!vm:simple-string-type sb!vm:complex-string-type) 'base-char) - ((sb!vm:simple-bit-vector-type sb!vm:complex-bit-vector-type) 'bit) - (sb!vm:simple-vector-type t) - (sb!vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2)) - (sb!vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4)) - (sb!vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8)) - (sb!vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16)) - (sb!vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32)) - (sb!vm:simple-array-signed-byte-8-type '(signed-byte 8)) - (sb!vm:simple-array-signed-byte-16-type '(signed-byte 16)) - (sb!vm:simple-array-signed-byte-30-type '(signed-byte 30)) - (sb!vm:simple-array-signed-byte-32-type '(signed-byte 32)) - (sb!vm:simple-array-single-float-type 'single-float) - (sb!vm:simple-array-double-float-type 'double-float) + ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char) + ((sb!vm:simple-bit-vector-widetag + sb!vm:complex-bit-vector-widetag) 'bit) + (sb!vm:simple-vector-widetag t) + (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2)) + (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4)) + (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8)) + (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16)) + (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32)) + (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8)) + (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16)) + (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30)) + (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32)) + (sb!vm:simple-array-single-float-widetag 'single-float) + (sb!vm:simple-array-double-float-widetag 'double-float) #!+long-float - (sb!vm:simple-array-long-float-type 'long-float) - (sb!vm:simple-array-complex-single-float-type '(complex single-float)) - (sb!vm:simple-array-complex-double-float-type '(complex double-float)) + (sb!vm:simple-array-long-float-widetag 'long-float) + (sb!vm:simple-array-complex-single-float-widetag + '(complex single-float)) + (sb!vm:simple-array-complex-double-float-widetag + '(complex double-float)) #!+long-float - (sb!vm:simple-array-complex-long-float-type '(complex long-float)) - ((sb!vm:simple-array-type sb!vm:complex-vector-type - sb!vm:complex-array-type) + (sb!vm:simple-array-complex-long-float-widetag '(complex long-float)) + ((sb!vm:simple-array-widetag + sb!vm:complex-vector-widetag + sb!vm:complex-array-widetag) (with-array-data ((array array) (start) (end)) (declare (ignore start end)) (array-element-type array))) @@ -543,7 +549,7 @@ (defun array-dimension (array axis-number) #!+sb-doc - "Returns the length of dimension AXIS-NUMBER of ARRAY." + "Return the length of dimension AXIS-NUMBER of ARRAY." (declare (array array) (type index axis-number)) (cond ((not (array-header-p array)) (unless (= axis-number 0)