X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=9f1eb0f748f7534def3306fa5064a09721cbef2a;hb=dc33d6a6b84f8338e603759cec8e25da29055d50;hp=71ce324fbd28e3acd1c2d0d4965e392ea05323e3;hpb=a6103aace1e40d0948aeb090f7b5d5ca77fc293a;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 71ce324..9f1eb0f 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -91,8 +91,11 @@ ;; and for all in any reasonable user programs.) ((t) (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)) - ((base-char standard-char) + ((base-char standard-char #!-sb-unicode character) (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) + #!+sb-unicode + ((character) + (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits)) ((bit) (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. @@ -110,8 +113,11 @@ ;; Pick off some easy common cases. ((t) #.sb!vm:complex-vector-widetag) - ((base-char) + ((base-char #!-sb-unicode character) #.sb!vm:complex-base-string-widetag) + #!+sb-unicode + ((character) + #.sb!vm:complex-character-string-widetag) ((nil) #.sb!vm:complex-vector-nil-widetag) ((bit) @@ -120,7 +126,12 @@ (t (pick-vector-type type (nil #.sb!vm:complex-vector-nil-widetag) + #!-sb-unicode + (character #.sb!vm:complex-base-string-widetag) + #!+sb-unicode (base-char #.sb!vm:complex-base-string-widetag) + #!+sb-unicode + (character #.sb!vm:complex-character-string-widetag) (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) @@ -148,23 +159,27 @@ (array (allocate-vector type length - (ceiling (* (if (= type sb!vm:simple-base-string-widetag) - (1+ length) - length) - n-bits) - sb!vm:n-word-bits)))) + (ceiling + (* (if (or (= type sb!vm:simple-base-string-widetag) + #!+sb-unicode + (= type + sb!vm:simple-character-string-widetag)) + (1+ length) + length) + n-bits) + sb!vm:n-word-bits)))) (declare (type index length)) (when initial-element-p (fill array initial-element)) (when initial-contents-p (when initial-element-p - (error "can't specify both :INITIAL-ELEMENT and ~ - :INITIAL-CONTENTS")) - (unless (= length (length initial-contents)) - (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ - the vector length is ~W." - (length initial-contents) - length)) + (error "can't specify both :INITIAL-ELEMENT and ~ + :INITIAL-CONTENTS")) + (unless (= length (length initial-contents)) + (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ + the vector length is ~W." + (length initial-contents) + length)) (replace array initial-contents)) array)) ;; it's either a complex array or a multidimensional array. @@ -205,7 +220,7 @@ (cond (displaced-to (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ - can be specified along with :DISPLACED-TO")) + can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -220,6 +235,51 @@ (incf axis))) array)))) +(defun make-static-vector (length &key + (element-type '(unsigned-byte 8)) + (initial-contents nil initial-contents-p) + (initial-element nil initial-element-p)) + "Allocate vector of LENGTH elements in static space. Only allocation +of specialized arrays is supported." + ;; STEP 1: check inputs fully + ;; + ;; This way of doing explicit checks before the vector is allocated + ;; is expensive, but probably worth the trouble as once we've allocated + ;; the vector we have no way to get rid of it anymore... + (when (eq t (upgraded-array-element-type element-type)) + (error "Static arrays of type ~S not supported." + element-type)) + (when initial-contents-p + (when initial-element-p + (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) + (unless (= length (length initial-contents)) + (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~ + vector length is ~W." + (length initial-contents) + length)) + (unless (every (lambda (x) (typep x element-type)) initial-contents) + (error ":INITIAL-CONTENTS contains elements not of type ~S." + element-type))) + (when initial-element-p + (unless (typep initial-element element-type) + (error ":INITIAL-ELEMENT ~S is not of type ~S." + initial-element element-type))) + ;; STEP 2 + ;; + ;; Allocate and possibly initialize the vector. + (multiple-value-bind (type n-bits) + (sb!impl::%vector-widetag-and-n-bits element-type) + (let ((vector + (allocate-static-vector type length + (ceiling (* length n-bits) + sb!vm:n-word-bits)))) + (cond (initial-element-p + (fill vector initial-element)) + (initial-contents-p + (replace vector initial-contents)) + (t + vector))))) + ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of @@ -229,7 +289,7 @@ initial-element initial-element-p) (when (and initial-contents-p initial-element-p) (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to - either MAKE-ARRAY or ADJUST-ARRAY.")) + either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p (make-array total-size :element-type element-type @@ -254,13 +314,13 @@ (incf index)) (t (unless (typep contents 'sequence) - (error "malformed :INITIAL-CONTENTS: ~S is not a ~ - sequence, but ~W more layer~:P needed." + (error "malformed :INITIAL-CONTENTS: ~S is not a ~ + sequence, but ~W more layer~:P needed." contents (- (length dimensions) axis))) (unless (= (length contents) (car dims)) - (error "malformed :INITIAL-CONTENTS: Dimension of ~ - axis ~W is ~W, but ~S is ~W long." + (error "malformed :INITIAL-CONTENTS: Dimension of ~ + axis ~W is ~W, but ~S is ~W long." axis (car dims) contents (length contents))) (if (listp contents) (dolist (content contents) @@ -318,6 +378,7 @@ sb!vm:*specialized-array-element-type-properties*) #'> :key #'sb!vm:saetp-importance))))) +;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed (defun %array-row-major-index (array subscripts &optional (invalid-index-error-p t)) (declare (array array) @@ -368,14 +429,17 @@ t)) (defun array-row-major-index (array &rest subscripts) + (declare (dynamic-extent subscripts)) (%array-row-major-index array subscripts)) (defun aref (array &rest subscripts) #!+sb-doc "Return the element of the ARRAY specified by the SUBSCRIPTS." + (declare (dynamic-extent subscripts)) (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) + (declare (dynamic-extent stuff)) (let ((subscripts (butlast stuff)) (new-value (car (last stuff)))) (setf (row-major-aref array (%array-row-major-index array subscripts)) @@ -408,6 +472,7 @@ #!-sb-fluid (declaim (inline (setf aref))) (defun (setf aref) (new-value array &rest subscripts) + (declare (dynamic-extent subscripts)) (declare (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) @@ -538,7 +603,25 @@ (error "Axis number ~W is too big; ~S only has ~D dimension~:P." axis-number array (%array-rank array))) (t - (%array-dimension array axis-number)))) + ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): + ;; + ;; "If A is displaced to B, the consequences are + ;; unspecified if B is adjusted in such a way that it no + ;; longer has enough elements to satisfy A. + ;; + ;; In situations where this matters we should be doing a + ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so + ;; this seems like a good place to signal an error. + (multiple-value-bind (target offset) (array-displacement array) + (when (and target + (> (array-total-size array) + (- (array-total-size target) offset))) + (error 'displaced-to-array-too-small-error + :format-control "~@" + :format-arguments (list (array-total-size array) + (- (array-total-size target) offset)))) + (%array-dimension array axis-number))))) (defun array-dimensions (array) #!+sb-doc @@ -643,7 +726,9 @@ (declare (fixnum fill-pointer)) (when (= fill-pointer (%array-available-elements vector)) (adjust-array vector (+ fill-pointer extension))) - (setf (aref vector fill-pointer) new-element) + ;; disable bounds checking + (locally (declare (optimize (safety 0))) + (setf (aref vector fill-pointer) new-element)) (setf (%array-fill-pointer vector) (1+ fill-pointer)) fill-pointer)) @@ -656,9 +741,12 @@ (declare (fixnum fill-pointer)) (if (zerop fill-pointer) (error "There is nothing left to pop.") - (aref array - (setf (%array-fill-pointer array) - (1- fill-pointer)))))) + ;; disable bounds checking (and any fixnum test) + (locally (declare (optimize (safety 0))) + (aref array + (setf (%array-fill-pointer array) + (1- fill-pointer))))))) + ;;;; ADJUST-ARRAY @@ -685,8 +773,8 @@ (cond (initial-contents-p ;; array former contents replaced by INITIAL-CONTENTS (if (or initial-element-p displaced-to) - (error "INITIAL-CONTENTS may not be specified with ~ - the :INITIAL-ELEMENT or :DISPLACED-TO option.")) + (error "INITIAL-CONTENTS may not be specified with ~ + the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type @@ -706,11 +794,11 @@ (displaced-to ;; We already established that no INITIAL-CONTENTS was supplied. (when initial-element - (error "The :INITIAL-ELEMENT option may not be specified ~ - with :DISPLACED-TO.")) - (unless (subtypep element-type (array-element-type displaced-to)) - (error "can't displace an array of type ~S into another of ~ - type ~S" + (error "The :INITIAL-ELEMENT option may not be specified ~ + with :DISPLACED-TO.")) + (unless (subtypep element-type (array-element-type displaced-to)) + (error "can't displace an array of type ~S into another of ~ + type ~S" element-type (array-element-type displaced-to))) (let ((displacement (or displaced-index-offset 0)) (array-size (apply #'* dimensions))) @@ -790,19 +878,19 @@ (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ - smaller than its fill pointer (~S)" + smaller than its fill pointer (~S)" old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) ((not (array-has-fill-pointer-p old-array)) (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ - in ADJUST-ARRAY unless the array (~S) was originally ~ - created with a fill pointer" + in ADJUST-ARRAY unless the array (~S) was originally ~ + created with a fill pointer" fill-pointer old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ - than the new length of the vector (~S)" + than the new length of the vector (~S)" fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) @@ -831,7 +919,9 @@ ,@(map 'list (lambda (saetp) `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) - ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char) + ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character) + #!+sb-unicode + (eq (sb!vm:saetp-specifier saetp) 'base-char)) *default-init-char-form* (sb!vm:saetp-initial-element-default saetp)))) (remove-if-not @@ -969,12 +1059,13 @@ (defmacro def-bit-array-op (name function) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) + #!+sb-doc ,(format nil "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ - BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ - If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ - RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ - All the arrays must have the same rank and dimensions." + BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ + If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ + RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ + All the arrays must have the same rank and dimensions." (symbol-name function)) (declare (type (array bit) bit-array-1 bit-array-2) (type (or (array bit) (member t nil)) result-bit-array))