X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=d3c09c1ac743077806c33723f8bcde56306b9697;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=733b8c36b735f03c19e1379156c7384e81a73ae8;hpb=084168e1524a6493bc0f9d1697753d31239b158d;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 733b8c3..d3c09c1 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)) @@ -229,7 +244,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 +269,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) @@ -538,7 +553,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 +676,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 +691,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 +723,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 +744,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 +828,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 +869,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 @@ -972,10 +1012,10 @@ #!+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))