From: Christophe Rhodes Date: Wed, 16 Jul 2003 08:25:59 +0000 (+0000) Subject: 0.8.1.34: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=403bacffd903f8c5787a182f4133cffc69b55dc0;hp=-c;p=sbcl.git 0.8.1.34: Merge vector_nil_string_branch ... many other incremental fixes, including * decrease of number of places array properties need to be specified; * rework of build order so that unknown types are never specialized; * primitive types need to know the specifier, not the ctype, so make it so; * fixes to the kernel classoid hierarchy, so more likely to be consistent internally. The good news is that, should it prove necessary, reverting this patch so that (vector nil) isn't a string is probably not very much work; all that needs to be changed are the kernel classoid supertypes and the STRING and SIMPLE-STRING definitions (and unparses). On the other hand, I'd be interested in trying to fix any performance problem "the right way" before reverting this behaviour. --- 403bacffd903f8c5787a182f4133cffc69b55dc0 diff --combined build-order.lisp-expr index 043e449,82c49dd..55a52cf --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@@ -73,7 -73,6 +73,7 @@@ ;;; supplied by basic machinery ("src/code/cross-misc" :not-target) + ("src/code/cross-char" :not-target) ("src/code/cross-byte" :not-target) ("src/code/cross-float" :not-target) ("src/code/cross-io" :not-target) @@@ -335,6 -334,7 +335,7 @@@ ;; in class.lisp. ("src/code/condition" :not-host) + ("src/compiler/generic/vm-array") ("src/compiler/generic/primtype") ;; the implementation of the compiler-affecting part of forms like @@@ -376,6 -376,8 +377,8 @@@ ("src/code/cross-type" :not-target) ("src/compiler/generic/vm-type") ("src/compiler/proclaim") + + ("src/code/class-init") ("src/code/typecheckfuns") ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in @@@ -399,6 -401,9 +402,9 @@@ ("src/compiler/compiler-error") ("src/code/type-init") + ;; Now that the type system is initialized, fix up UNKNOWN types that + ;; have crept in. + ("src/compiler/fixup-type") ;; These define target types needed by fndb.lisp. ("src/code/package") diff --combined package-data-list.lisp-expr index 2c8b88f,e5627f0..41f624c --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@@ -884,7 -884,6 +884,7 @@@ retained, possibly temporariliy, becaus "EVAL-IN-LEXENV" "DEBUG-NAMIFY" "FORCE" "DELAY" "PROMISE-READY-P" + "FIND-RESTART-OR-CONTROL-ERROR" ;; These could be moved back into SB!EXT if someone has ;; compelling reasons, but hopefully we can get by @@@ -1027,7 -1026,7 +1027,7 @@@ is a good idea, but see SB-SYS re. blur "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" "ARRAY-TYPE-P" "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX" - "ASSERT-ERROR" "BASE-CHAR-P" + "ASSERT-ERROR" "BASE-CHAR-P" "BASE-STRING-P" "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX" "BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE" @@@ -1081,9 -1080,7 +1081,9 @@@ "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" "FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION" - "FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" + "FORM" + "FORMAT-CONTROL" + "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" "FUN-CODE-HEADER" "FUN-TYPE" "FUN-TYPE-ALLOWP" "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" @@@ -1095,8 -1092,8 +1095,8 @@@ "GENERALIZED-BOOLEAN" "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" - "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" - "WIDETAG-OF" + "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF" + "GET-MACHINE-VERSION" "HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE" "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER" "HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" @@@ -1170,6 -1167,7 +1170,7 @@@ "NUMERIC-TYPE-FORMAT" "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR" + "OBJECT-NOT-BASE-STRING-ERROR" "OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR" "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-COMPLEX-FLOAT-ERROR" @@@ -1211,6 -1209,7 +1212,7 @@@ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR" "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR" "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR" + "OBJECT-NOT-SIMPLE-BASE-STRING-ERROR" "OBJECT-NOT-SIMPLE-STRING-ERROR" "OBJECT-NOT-SIMPLE-VECTOR-ERROR" "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR" @@@ -1229,7 -1228,6 +1231,7 @@@ #!+x86 "*PSEUDO-ATOMIC-INTERRUPTED*" "PUNT-PRINT-IF-TOO-LONG" "READER-IMPOSSIBLE-NUMBER-ERROR" "READER-PACKAGE-ERROR" + "RESTART-DESIGNATOR" "SCALE-DOUBLE-FLOAT" #!+long-float "SCALE-LONG-FLOAT" "SCALE-SINGLE-FLOAT" @@@ -1254,6 -1252,7 +1256,7 @@@ "SIMPLE-ARRAY-SIGNED-BYTE-30-P" "SIMPLE-ARRAY-SIGNED-BYTE-32-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P" + "SIMPLE-BASE-STRING-P" "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" @@@ -1294,14 -1293,14 +1297,15 @@@ "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" "VALUES-TYPE" "VALUES-TYPE-ERROR" + "VALUES-TYPE-IN" "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-OPTIONAL" + "VALUES-TYPE-OUT" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" "VALUES-TYPE-TYPES" "VALUES-TYPES" - "VALUES-TYPE-START" "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P" + "VECTOR-NIL-P" "VECTOR-TO-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" @@@ -1405,6 -1404,7 +1409,7 @@@ "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT" "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT" "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT" + "!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT" "!RANDOM-COLD-INIT" "!READER-COLD-INIT" "!TYPECHECKFUNS-COLD-INIT" "STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT" @@@ -1918,7 -1918,8 +1923,8 @@@ structure representations "COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT" "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-WIDETAG" "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER" - "COMPLEX-SIZE" "COMPLEX-STRING-WIDETAG" "COMPLEX-WIDETAG" + "COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" "COMPLEX-WIDETAG" + "COMPLEX-VECTOR-NIL-WIDETAG" "COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT" "CONS-SIZE" "CONSTANT-SC-NUMBER" "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER" @@@ -2008,6 -2009,11 +2014,11 @@@ "*READ-ONLY-SPACE-FREE-POINTER*" "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-WIDETAG" "RETURN-PC-RETURN-POINT-OFFSET" "RETURN-PC-SAVE-OFFSET" + "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT" + "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME" + "SAETP-N-PAD-ELEMENTS" "SAETP-SPECIFIER" + "SAETP-COMPLEX-TYPECODE" "SAETP-IMPORTANCE" + "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*" "SANCTIFY-FOR-EXECUTION" "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE" "SAP-STACK-SC-NUMBER" "SAP-WIDETAG" @@@ -2029,7 -2035,7 +2040,7 @@@ "SIMPLE-ARRAY-SIGNED-BYTE-32-WIDETAG" "SIMPLE-ARRAY-SIGNED-BYTE-8-WIDETAG" "SIMPLE-BIT-VECTOR-WIDETAG" - "SIMPLE-STRING-WIDETAG" + "SIMPLE-BASE-STRING-WIDETAG" "SIMPLE-VECTOR-WIDETAG" "SINGLE-FLOAT-BIAS" "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE" "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX" diff --combined src/code/array.lisp index d8d04e9,1484340..c8e0c86 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@@ -65,6 -65,15 +65,6 @@@ (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?")) ;;;; MAKE-ARRAY -(defun upgraded-array-element-type (spec &optional environment) - #!+sb-doc - "Return the element type that will actually be used to implement an array - with the specifier :ELEMENT-TYPE Spec." - (declare (ignore environment)) - (if (unknown-type-p (specifier-type spec)) - (error "undefined type: ~S" spec) - (type-specifier (array-type-specialized-element-type - (specifier-type `(array ,spec)))))) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro pick-vector-type (type &rest specs) `(cond ,@(mapcar (lambda (spec) @@@ -91,65 -100,36 +91,36 @@@ ;; and for all in any reasonable user programs.) ((t) (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)) - ((character base-char standard-char) - (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits)) + ((base-char standard-char) + (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) ((bit) (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 - (nil (values #.sb!vm:simple-array-nil-widetag 0)) - (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-widetag 2)) - ((unsigned-byte 4) - (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4)) - ((unsigned-byte 8) - (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8)) - ((unsigned-byte 16) - (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16)) - ((unsigned-byte 32) - (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32)) - ((signed-byte 8) - (values #.sb!vm:simple-array-signed-byte-8-widetag 8)) - ((signed-byte 16) - (values #.sb!vm:simple-array-signed-byte-16-widetag 16)) - ((signed-byte 30) - (values #.sb!vm:simple-array-signed-byte-30-widetag 32)) - ((signed-byte 32) - (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-widetag - #!+x86 96 #!+sparc 128)) - ((complex single-float) - (values #.sb!vm:simple-array-complex-single-float-widetag 64)) - ((complex double-float) - (values #.sb!vm:simple-array-complex-double-float-widetag 128)) - #!+long-float - ((complex long-float) - (values #.sb!vm:simple-array-complex-long-float-widetag - #!+x86 192 - #!+sparc 256)) - (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)))))) + #.`(pick-vector-type type + ,@(map 'list + (lambda (saetp) + `(,(sb!vm:saetp-specifier saetp) + (values ,(sb!vm:saetp-typecode saetp) + ,(sb!vm:saetp-n-bits saetp)))) + sb!vm:*specialized-array-element-type-properties*))))) + (defun %complex-vector-widetag (type) (case type ;; Pick off some easy common cases. ((t) #.sb!vm:complex-vector-widetag) - ((character base-char) - #.sb!vm:complex-string-widetag) + ((base-char) + #.sb!vm:complex-base-string-widetag) + ((nil) + #.sb!vm:complex-vector-nil-widetag) ((bit) #.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-widetag) + (nil #.sb!vm:complex-vector-nil-widetag) + (base-char #.sb!vm:complex-base-string-widetag) (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) @@@ -176,7 -156,7 +147,7 @@@ (array (allocate-vector type length - (ceiling (* (if (= type sb!vm:simple-string-widetag) + (ceiling (* (if (= type sb!vm:simple-base-string-widetag) (1+ length) length) n-bits) @@@ -302,39 -282,20 +273,20 @@@ (coerce (the list objects) 'simple-vector)) ;;;; accessor/setter functions - - (eval-when (:compile-toplevel :execute) - (defparameter *specialized-array-element-types* - '(t - character - bit - (unsigned-byte 2) - (unsigned-byte 4) - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - (signed-byte 8) - (signed-byte 16) - (signed-byte 30) - (signed-byte 32) - single-float - double-float - #!+long-float long-float - (complex single-float) - (complex double-float) - #!+long-float (complex long-float) - nil))) - (defun hairy-data-vector-ref (array index) (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(mapcar (lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-ref (the ,atype vector) - index)))) - *specialized-array-element-types*)))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-ref (the ,atype vector) index)))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function @@@ -346,20 -307,23 +298,23 @@@ (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(mapcar (lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-set (the ,atype vector) - index - (the ,type - new-value)) - ;; For specialized arrays, the return - ;; from data-vector-set would have to - ;; be reboxed to be a (Lisp) return - ;; value; instead, we use the - ;; already-boxed value as the return. - new-value))) - *specialized-array-element-types*)))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-set (the ,atype vector) index + (the ,type new-value)) + ;; For specialized arrays, the return from + ;; data-vector-set would have to be + ;; reboxed to be a (Lisp) return value; + ;; instead, we use the already-boxed value + ;; as the return. + new-value))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) (defun %array-row-major-index (array subscripts &optional (invalid-index-error-p t)) @@@ -379,7 -343,7 +334,7 @@@ (let ((index (car subs)) (dim (%array-dimension array axis))) (declare (fixnum dim)) - (unless (< -1 index dim) + (unless (and (fixnump index) (< -1 index dim)) (if invalid-index-error-p (error 'simple-type-error :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" @@@ -391,7 -355,7 +346,7 @@@ (setf chunk-size (* chunk-size dim)))) (let ((index (first subscripts)) (length (length (the (simple-array * (*)) array)))) - (unless (< -1 index length) + (unless (and (fixnump index) (< -1 index length)) (if invalid-index-error-p ;; FIXME: perhaps this should share a format-string ;; with INVALID-ARRAY-INDEX-ERROR or @@@ -406,7 -370,7 +361,7 @@@ (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Return 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)) @@@ -415,7 -379,7 +370,7 @@@ (defun aref (array &rest subscripts) #!+sb-doc - "Return 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) @@@ -544,41 -508,23 +499,23 @@@ `(= widetag ,item)))) (cdr stuff))) stuff)))) - ;; FIXME: The data here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (pick-element-type - (sb!vm:simple-array-nil-widetag nil) - ((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-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-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))) - (t - (error 'type-error :datum array :expected-type 'array)))))) + #.`(pick-element-type + ,@(map 'list + (lambda (saetp) + `(,(if (sb!vm:saetp-complex-typecode saetp) + (list (sb!vm:saetp-typecode saetp) + (sb!vm:saetp-complex-typecode saetp)) + (sb!vm:saetp-typecode saetp)) + ',(sb!vm:saetp-specifier saetp))) + sb!vm:*specialized-array-element-type-properties*) + ((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))) + (t + (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) #!+sb-doc @@@ -866,8 -812,7 +803,7 @@@ (unless (array-header-p vector) (macrolet ((frob (name &rest things) `(etypecase ,name - ((simple-array nil (*)) (error 'cell-error - :name 'nil-array-element)) + ((simple-array nil (*)) (error 'nil-array-accessed-error)) ,@(mapcar (lambda (thing) (destructuring-bind (type-spec fill-value) thing @@@ -876,33 -821,16 +812,16 @@@ ,fill-value :start new-length)))) things)))) - ;; FIXME: The associations between vector types and initial - ;; values here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (frob vector - (simple-vector 0) - (simple-base-string #.*default-init-char-form*) - (simple-bit-vector 0) - ((simple-array (unsigned-byte 2) (*)) 0) - ((simple-array (unsigned-byte 4) (*)) 0) - ((simple-array (unsigned-byte 8) (*)) 0) - ((simple-array (unsigned-byte 16) (*)) 0) - ((simple-array (unsigned-byte 32) (*)) 0) - ((simple-array (signed-byte 8) (*)) 0) - ((simple-array (signed-byte 16) (*)) 0) - ((simple-array (signed-byte 30) (*)) 0) - ((simple-array (signed-byte 32) (*)) 0) - ((simple-array single-float (*)) (coerce 0 'single-float)) - ((simple-array double-float (*)) (coerce 0 'double-float)) - #!+long-float - ((simple-array long-float (*)) (coerce 0 'long-float)) - ((simple-array (complex single-float) (*)) - (coerce 0 '(complex single-float))) - ((simple-array (complex double-float) (*)) - (coerce 0 '(complex double-float))) - #!+long-float - ((simple-array (complex long-float) (*)) - (coerce 0 '(complex long-float)))))) + #.`(frob vector + ,@(map 'list + (lambda (saetp) + `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) + ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char) + *default-init-char-form* + (sb!vm:saetp-initial-element-default saetp)))) + (remove-if-not + #'sb!vm:saetp-specifier + sb!vm:*specialized-array-element-type-properties*))))) ;; Only arrays have fill-pointers, but vectors have their length ;; parameter in the same place. (setf (%array-fill-pointer vector) new-length) diff --combined src/code/deftypes-for-target.lisp index 44438c0,87f6d3e..0928858 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@@ -54,7 -54,7 +54,7 @@@ (sb!xc:deftype extended-char () #!+sb-doc - "Type of characters that aren't base-char's. None in CMU CL." + "Type of CHARACTERs that aren't BASE-CHARs." '(and character (not base-char))) (sb!xc:deftype standard-char () @@@ -87,10 -87,12 +87,12 @@@ `(simple-array base-char (,size))) (sb!xc:deftype string (&optional size) `(or (array character (,size)) - (base-string ,size))) + (array nil (,size)) + (base-string ,size))) (sb!xc:deftype simple-string (&optional size) `(or (simple-array character (,size)) - (simple-base-string ,size))) + (simple-array nil (,size)) + (simple-base-string ,size))) (sb!xc:deftype bit-vector (&optional size) `(array bit (,size))) @@@ -104,20 -106,6 +106,12 @@@ ;;; semistandard types (sb!xc:deftype generalized-boolean () t) +(sb!xc:deftype format-control () + '(or string function)) + +(sb!xc:deftype restart-designator () + '(or (and symbol (not null)) restart)) + - ;;; a type specifier - ;;; - ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS. - ;;; However, the CL:CLASS type is only defined once PCL is loaded, - ;;; which is before this is evaluated. Once PCL is moved into cold - ;;; init, this might be fixable. - (sb!xc:deftype type-specifier () '(or list symbol sb!kernel:instance)) - ;;; array rank, total size... (sb!xc:deftype array-rank () `(integer 0 (,sb!xc:array-rank-limit))) (sb!xc:deftype array-total-size () diff --combined src/code/early-extensions.lisp index ff5fb92,523754f..e195215 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@@ -79,6 -79,14 +79,14 @@@ (t `(values ,@(cdr result) &optional))))) `(function ,args ,result))) + ;;; a type specifier + ;;; + ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS. + ;;; However, the CL:CLASS type is only defined once PCL is loaded, + ;;; which is before this is evaluated. Once PCL is moved into cold + ;;; init, this might be fixable. + (def!type type-specifier () '(or list symbol sb!kernel:instance)) + ;;; the default value used for initializing character data. The ANSI ;;; spec says this is arbitrary, so we use the value that falls ;;; through when we just let the low-level consing code initialize @@@ -816,7 -824,7 +824,7 @@@ which can be found at " + :format-control "~@<~S ~_is not a ~_~S~:>" :format-arguments (list value type))) ;;; Return a function like FUN, but expecting its (two) arguments in diff --combined src/code/late-type.lisp index 296d88c,b8d83ee..e0b7317 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@@ -25,11 -25,6 +25,11 @@@ ;;; There are all sorts of nasty problems with open bounds on FLOAT ;;; types (and probably FLOAT types in general.) +;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that +;;; compiler warnings can be emitted as appropriate. +(define-condition parse-unknown-type (condition) + ((specifier :reader parse-unknown-type-specifier :initarg :specifier))) + ;;; FIXME: This really should go away. Alas, it doesn't seem to be so ;;; simple to make it go away.. (See bug 123 in BUGS file.) (defvar *use-implementation-types* t ; actually initialized in cold init @@@ -182,7 -177,20 +182,7 @@@ (return (values nil t)))))) (!define-type-method (values :simple-=) (type1 type2) - (let ((rest1 (args-type-rest type1)) - (rest2 (args-type-rest type2))) - (cond ((and rest1 rest2 (type/= rest1 rest2)) - (type= rest1 rest2)) - ((or rest1 rest2) - (values nil t)) - (t - (multiple-value-bind (req-val req-win) - (type=-list (values-type-required type1) - (values-type-required type2)) - (multiple-value-bind (opt-val opt-win) - (type=-list (values-type-optional type1) - (values-type-optional type2)) - (values (and req-val opt-val) (and req-win opt-win)))))))) + (type=-args type1 type2)) (!define-type-class function) @@@ -225,14 -233,10 +225,14 @@@ ((fun-type-wild-args type1) (cond ((fun-type-keyp type2) (values nil nil)) ((not (fun-type-rest type2)) (values nil t)) - ((not (null (fun-type-required type2))) (values nil t)) - (t (and/type (type= *universal-type* (fun-type-rest type2)) - (every/type #'type= *universal-type* - (fun-type-optional type2)))))) + ((not (null (fun-type-required type2))) + (values nil t)) + (t (and/type (type= *universal-type* + (fun-type-rest type2)) + (every/type #'type= + *universal-type* + (fun-type-optional + type2)))))) ((not (and (fun-type-simple-p type1) (fun-type-simple-p type2))) (values nil nil)) @@@ -241,12 -245,10 +241,12 @@@ (cond ((or (> max1 max2) (< min1 min2)) (values nil t)) ((and (= min1 min2) (= max1 max2)) - (and/type (every-csubtypep (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep (fun-type-optional type1) - (fun-type-optional type2)))) + (and/type (every-csubtypep + (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep + (fun-type-optional type1) + (fun-type-optional type2)))) (t (every-csubtypep (concatenate 'list (fun-type-required type1) @@@ -262,36 -264,8 +262,36 @@@ (declare (ignore type1 type2)) (specifier-type 'function)) (!define-type-method (function :simple-intersection2) (type1 type2) - (declare (ignore type1 type2)) - (specifier-type 'function)) + (let ((ftype (specifier-type 'function))) + (cond ((eq type1 ftype) type2) + ((eq type2 ftype) type1) + (t (let ((rtype (values-type-intersection (fun-type-returns type1) + (fun-type-returns type2)))) + (flet ((change-returns (ftype rtype) + (declare (type fun-type ftype) (type ctype rtype)) + (make-fun-type :required (fun-type-required ftype) + :optional (fun-type-optional ftype) + :keyp (fun-type-keyp ftype) + :keywords (fun-type-keywords ftype) + :allowp (fun-type-allowp ftype) + :returns rtype))) + (cond + ((fun-type-wild-args type1) + (if (fun-type-wild-args type2) + (make-fun-type :wild-args t + :returns rtype) + (change-returns type2 rtype))) + ((fun-type-wild-args type2) + (change-returns type1 rtype)) + (t (multiple-value-bind (req opt rest) + (args-type-op type1 type2 #'type-intersection #'max) + (make-fun-type :required req + :optional opt + :rest rest + ;; FIXME: :keys + :allowp (and (fun-type-allowp type1) + (fun-type-allowp type2)) + :returns rtype)))))))))) ;;; The union or intersection of a subclass of FUNCTION with a ;;; FUNCTION type is somewhat complicated. @@@ -314,7 -288,32 +314,7 @@@ (values nil t)) ((eq (fun-type-wild-args type1) t) (values t t)) - (t (and/type - (cond ((null (fun-type-rest type1)) - (values (null (fun-type-rest type2)) t)) - ((null (fun-type-rest type2)) - (values nil t)) - (t - (compare type= rest))) - (labels ((type-list-= (l1 l2) - (cond ((null l1) - (values (null l2) t)) - ((null l2) - (values nil t)) - (t (multiple-value-bind (res winp) - (type= (first l1) (first l2)) - (cond ((not winp) - (values nil nil)) - ((not res) - (values nil t)) - (t - (type-list-= (rest l1) - (rest l2))))))))) - (and/type (and/type (compare type-list-= required) - (compare type-list-= optional)) - (if (or (fun-type-keyp type1) (fun-type-keyp type2)) - (values nil nil) - (values t t)))))))))) + (t (type=-args type1 type2)))))) (!define-type-class constant :inherits values) @@@ -432,8 -431,8 +432,8 @@@ (cond ((args-type-rest type)) (t default-type))))) -;;; If COUNT values are supplied, which types should they have? -(defun values-type-start (type count) +;;; types of values in (the (values o_1 ... o_n)) +(defun values-type-out (type count) (declare (type ctype type) (type unsigned-byte count)) (if (eq type *wild-type*) (make-list count :initial-element *universal-type*) @@@ -451,29 -450,6 +451,29 @@@ do (res rest)))) (res)))) +;;; types of variable in (m-v-bind (v_1 ... v_n) (the ... +(defun values-type-in (type count) + (declare (type ctype type) (type unsigned-byte count)) + (if (eq type *wild-type*) + (make-list count :initial-element *universal-type*) + (collect ((res)) + (let ((null-type (specifier-type 'null))) + (loop for type in (values-type-required type) + while (plusp count) + do (decf count) + do (res type)) + (loop for type in (values-type-optional type) + while (plusp count) + do (decf count) + do (res (type-union type null-type))) + (when (plusp count) + (loop with rest = (acond ((values-type-rest type) + (type-union it null-type)) + (t null-type)) + repeat count + do (res rest)))) + (res)))) + ;;; Return a list of OPERATION applied to the types in TYPES1 and ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter ;;; than TYPES2. The second value is T if OPERATION always returned a @@@ -578,34 -554,12 +578,34 @@@ (length (args-type-required type2)))) (required (subseq res 0 req)) (opt (subseq res req))) - (values (make-values-type - :required required - :optional opt - :rest rest) + (values required opt rest (and rest-exact res-exact)))))))) +(defun values-type-op (type1 type2 operation nreq) + (multiple-value-bind (required optional rest exactp) + (args-type-op type1 type2 operation nreq) + (values (make-values-type :required required + :optional optional + :rest rest) + exactp))) + +(defun type=-args (type1 type2) + (macrolet ((compare (comparator field) + (let ((reader (symbolicate '#:args-type- field))) + `(,comparator (,reader type1) (,reader type2))))) + (and/type + (cond ((null (args-type-rest type1)) + (values (null (args-type-rest type2)) t)) + ((null (args-type-rest type2)) + (values nil t)) + (t + (compare type= rest))) + (and/type (and/type (compare type=-list required) + (compare type=-list optional)) + (if (or (args-type-keyp type1) (args-type-keyp type2)) + (values nil nil) + (values t t)))))) + ;;; Do a union or intersection operation on types that might be values ;;; types. The result is optimized for utility rather than exactness, ;;; but it is guaranteed that it will be no smaller (more restrictive) @@@ -623,7 -577,7 +623,7 @@@ ((eq type1 *empty-type*) type2) ((eq type2 *empty-type*) type1) (t - (values (args-type-op type1 type2 #'type-union #'min))))) + (values (values-type-op type1 type2 #'type-union #'min))))) (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 @@@ -646,9 -600,9 +646,9 @@@ :rest (values-type-rest type1) :allowp (values-type-allowp type1)))) (t - (args-type-op type1 (coerce-to-values type2) - #'type-intersection - #'max)))) + (values-type-op type1 (coerce-to-values type2) + #'type-intersection + #'max)))) ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of ;;; works on VALUES types. Note that due to the semantics of @@@ -1183,17 -1137,8 +1183,17 @@@ (values nil nil)) (!define-type-method (hairy :complex-=) (type1 type2) - (declare (ignore type1 type2)) - (values nil nil)) + (if (and (unknown-type-p type2) + (let* ((specifier2 (unknown-type-specifier type2)) + (name2 (if (consp specifier2) + (car specifier2) + specifier2))) + (info :type :kind name2))) + (let ((type2 (specifier-type (unknown-type-specifier type2)))) + (if (unknown-type-p type2) + (values nil nil) + (type= type1 type2))) + (values nil nil))) (!define-type-method (hairy :simple-intersection2 :complex-intersection2) (type1 type2) @@@ -1664,41 -1609,17 +1664,41 @@@ ((consp low-bound) (let ((low-value (car low-bound))) (or (eql low-value high-bound) - (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0)) - (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) - (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0)) - (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) + (and (eql low-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql high-bound 0f0)) + (and (eql low-value 0f0) + (eql high-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql low-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql high-bound 0d0)) + (and (eql low-value 0d0) + (eql high-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) ((consp high-bound) (let ((high-value (car high-bound))) (or (eql high-value low-bound) - (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0)) - (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero)))) - (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0)) - (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero))))))) + (and (eql high-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql low-bound 0f0)) + (and (eql high-value 0f0) + (eql low-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql high-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql low-bound 0d0)) + (and (eql high-value 0d0) + (eql low-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) ((and (eq (numeric-type-class low) 'integer) (eq (numeric-type-class high) 'integer)) (eql (1+ low-bound) high-bound)) @@@ -2207,25 -2128,21 +2207,21 @@@ (case eltype (bit 'bit-vector) (base-char 'base-string) - (character 'string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) (base-char `(base-string ,(car dims))) - (character `(string ,(car dims))) (t `(vector ,eltype ,(car dims))))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) (base-char 'simple-base-string) - (character 'simple-string) ((t) 'simple-vector) (t `(simple-array ,eltype (*)))) (case eltype (bit `(simple-bit-vector ,(car dims))) (base-char `(simple-base-string ,(car dims))) - (character `(simple-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t @@@ -2273,8 -2190,9 +2269,9 @@@ (specialized-element-type-maybe type2)) t))))) + ;;; FIXME: is this dead? (!define-superclasses array - ((string string) + ((base-string base-string) (vector vector) (array)) !cold-init-forms) @@@ -2343,10 -2261,7 +2340,10 @@@ (mapcar (lambda (x y) (if (eq x '*) y x)) dims1 dims2))) :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) *empty-type*)) ;;; Check a supplied dimension list to determine whether it is legal, @@@ -2628,6 -2543,8 +2625,8 @@@ ((type= type (specifier-type 'real)) 'real) ((type= type (specifier-type 'sequence)) 'sequence) ((type= type (specifier-type 'bignum)) 'bignum) + ((type= type (specifier-type 'simple-string)) 'simple-string) + ((type= type (specifier-type 'string)) 'string) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each diff --combined src/code/seq.lisp index 84a9c76,bab805f..0d4a153 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@@ -61,18 -61,6 +61,18 @@@ '((start end length sequence) (start1 end1 length1 sequence1) (start2 end2 length2 sequence2))) + (key nil + nil + (and key (%coerce-callable-to-fun key)) + (or null function)) + (test #'eql + nil + (%coerce-callable-to-fun test) + function) + (test-not nil + nil + (and test-not (%coerce-callable-to-fun test-not)) + (or null function)) )) (sb!xc:defmacro define-sequence-traverser (name args &body body) @@@ -266,7 -254,20 +266,20 @@@ "Return a sequence of the given TYPE and LENGTH, with elements initialized to :INITIAL-ELEMENT." (declare (fixnum length)) - (let ((type (specifier-type type))) + (let* ((adjusted-type + (typecase type + (atom (cond + ((eq type 'string) '(vector character)) + ((eq type 'simple-string) '(simple-array character (*))) + (t type))) + (cons (cond + ((eq (car type) 'string) `(vector character ,@(cdr type))) + ((eq (car type) 'simple-string) + `(simple-array character ,@(when (cdr type) + (list (cdr type))))) + (t type))) + (t type))) + (type (specifier-type adjusted-type))) (cond ((csubtypep type (specifier-type 'list)) (cond ((type= type (specifier-type 'list)) @@@ -291,29 -292,28 +304,28 @@@ ;; it was stranger to feed that type in to MAKE-SEQUENCE. (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) - (if (typep type 'array-type) - ;; KLUDGE: the above test essentially asks "Do we know - ;; what the upgraded-array-element-type is?" [consider - ;; (OR STRING BIT-VECTOR)] - (progn - (aver (= (length (array-type-dimensions type)) 1)) - (let* ((etype (type-specifier - (array-type-specialized-element-type type))) - (etype (if (eq etype '*) t etype)) + (cond + (;; is it immediately obvious what the result type is? + (typep type 'array-type) + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let* ((etype (type-specifier + (array-type-specialized-element-type type))) + (etype (if (eq etype '*) t etype)) (type-length (car (array-type-dimensions type)))) - (unless (or (eq type-length '*) - (= type-length length)) - (sequence-type-length-mismatch-error type length)) - ;; FIXME: These calls to MAKE-ARRAY can't be - ;; open-coded, as the :ELEMENT-TYPE argument isn't - ;; constant. Probably we ought to write a - ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, - ;; 2002-07-22 - (if iep - (make-array length :element-type etype - :initial-element initial-element) - (make-array length :element-type etype)))) - (sequence-type-too-hairy (type-specifier type)))) + (unless (or (eq type-length '*) + (= type-length length)) + (sequence-type-length-mismatch-error type length)) + ;; FIXME: These calls to MAKE-ARRAY can't be + ;; open-coded, as the :ELEMENT-TYPE argument isn't + ;; constant. Probably we ought to write a + ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, + ;; 2002-07-22 + (if iep + (make-array length :element-type etype + :initial-element initial-element) + (make-array length :element-type etype))))) + (t (sequence-type-too-hairy (type-specifier type))))) (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ @@@ -618,14 -618,14 +630,14 @@@ (sb!xc:defmacro vector-nreverse (sequence) `(let ((length (length (the vector ,sequence)))) - (declare (fixnum length)) - (do ((left-index 0 (1+ left-index)) - (right-index (1- length) (1- right-index)) - (half-length (truncate length 2))) - ((= left-index half-length) ,sequence) - (declare (fixnum left-index right-index half-length)) - (rotatef (aref ,sequence left-index) - (aref ,sequence right-index))))) + (when (>= length 2) + (do ((left-index 0 (1+ left-index)) + (right-index (1- length) (1- right-index))) + ((<= right-index left-index)) + (declare (type index left-index right-index)) + (rotatef (aref ,sequence left-index) + (aref ,sequence right-index)))) + ,sequence)) (sb!xc:defmacro list-nreverse-macro (list) `(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st))) @@@ -1246,7 -1246,7 +1258,7 @@@ ) ; EVAL-WHEN (define-sequence-traverser delete - (item sequence &key from-end (test #'eql) test-not start + (item sequence &key from-end test test-not start end count key) #!+sb-doc "Return a sequence formed by destructively removing the specified ITEM from @@@ -1465,7 -1465,7 +1477,7 @@@ ) ; EVAL-WHEN (define-sequence-traverser remove - (item sequence &key from-end (test #'eql) test-not start + (item sequence &key from-end test test-not start end count key) #!+sb-doc "Return a copy of SEQUENCE with elements satisfying the test (default is @@@ -1606,7 -1606,7 +1618,7 @@@ (shrink-vector result jndex))) (define-sequence-traverser remove-duplicates - (sequence &key (test #'eql) test-not (start 0) end from-end key) + (sequence &key test test-not start end from-end key) #!+sb-doc "The elements of SEQUENCE are compared pairwise, and if any two match, the one occurring earlier is discarded, unless FROM-END is true, in @@@ -1675,7 -1675,7 +1687,7 @@@ (setq jndex (1+ jndex))))) (define-sequence-traverser delete-duplicates - (sequence &key (test #'eql) test-not (start 0) end from-end key) + (sequence &key test test-not start end from-end key) #!+sb-doc "The elements of SEQUENCE are examined, and if any two match, one is discarded. The resulting sequence, which may be formed by destroying the @@@ -1786,7 -1786,7 +1798,7 @@@ ) ; EVAL-WHEN (define-sequence-traverser substitute - (new old sequence &key from-end (test #'eql) test-not + (new old sequence &key from-end test test-not start count end key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements, @@@ -1800,28 -1800,26 +1812,28 @@@ ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT (define-sequence-traverser substitute-if - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements satisfying the TEST are replaced with NEW. See + except that all elements satisfying the PRED are replaced with NEW. See manual for details." (declare (fixnum start)) (let ((end (or end length)) + (test pred) test-not old) (declare (type index length end)) (subst-dispatch 'if))) (define-sequence-traverser substitute-if-not - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements not satisfying the TEST are replaced with NEW. + except that all elements not satisfying the PRED are replaced with NEW. See manual for details." (declare (fixnum start)) (let ((end (or end length)) + (test pred) test-not old) (declare (type index length end)) @@@ -1830,7 -1828,7 +1842,7 @@@ ;;;; NSUBSTITUTE (define-sequence-traverser nsubstitute - (new old sequence &key from-end (test #'eql) test-not + (new old sequence &key from-end test test-not end count key start) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements @@@ -1882,10 -1880,10 +1894,10 @@@ ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT (define-sequence-traverser nsubstitute-if - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements satisfying the TEST are replaced with NEW. + except that all elements satisfying the PRED are replaced with NEW. SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end length))) @@@ -1894,14 -1892,14 +1906,14 @@@ (if from-end (let ((length (length sequence))) (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) + new pred (nreverse (the list sequence)) (- length end) (- length start) count key))) - (nlist-substitute-if* new test sequence + (nlist-substitute-if* new pred sequence start end count key)) (if from-end - (nvector-substitute-if* new test sequence -1 + (nvector-substitute-if* new pred sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if* new test sequence 1 + (nvector-substitute-if* new pred sequence 1 start end count key))))) (defun nlist-substitute-if* (new test sequence start end count key) @@@ -1922,7 -1920,7 +1934,7 @@@ (setq count (1- count))))) (define-sequence-traverser nsubstitute-if-not - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying the TEST are replaced with NEW. @@@ -1934,14 -1932,14 +1946,14 @@@ (if from-end (let ((length (length sequence))) (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) + new pred (nreverse (the list sequence)) (- length end) (- length start) count key))) - (nlist-substitute-if-not* new test sequence + (nlist-substitute-if-not* new pred sequence start end count key)) (if from-end - (nvector-substitute-if-not* new test sequence -1 + (nvector-substitute-if-not* new pred sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if-not* new test sequence 1 + (nvector-substitute-if-not* new pred sequence 1 start end count key))))) (defun nlist-substitute-if-not* (new test sequence start end count key) @@@ -1986,7 -1984,7 +1998,7 @@@ (frob sequence nil)))) (typecase sequence (simple-vector (frob2)) - (simple-string (frob2)) + (simple-base-string (frob2)) (t (vector*-frob sequence)))) (declare (type (or index null) p)) (values f (and p (the index (+ p offset)))))))))) @@@ -2073,22 -2071,22 +2085,22 @@@ ) ; EVAL-WHEN -(define-sequence-traverser count-if (test sequence &key from-end start end key) +(define-sequence-traverser count-if (pred sequence &key from-end start end key) #!+sb-doc - "Return the number of elements in SEQUENCE satisfying TEST(el)." + "Return the number of elements in SEQUENCE satisfying PRED(el)." (declare (fixnum start)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence (if from-end - (list-count-if nil t test sequence) - (list-count-if nil nil test sequence)) + (list-count-if nil t pred sequence) + (list-count-if nil nil pred sequence)) (if from-end - (vector-count-if nil t test sequence) - (vector-count-if nil nil test sequence))))) + (vector-count-if nil t pred sequence) + (vector-count-if nil nil pred sequence))))) (define-sequence-traverser count-if-not - (test sequence &key from-end start end key) + (pred sequence &key from-end start end key) #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (fixnum start)) @@@ -2096,11 -2094,11 +2108,11 @@@ (declare (type index end)) (seq-dispatch sequence (if from-end - (list-count-if t t test sequence) - (list-count-if t nil test sequence)) + (list-count-if t t pred sequence) + (list-count-if t nil pred sequence)) (if from-end - (vector-count-if t t test sequence) - (vector-count-if t nil test sequence))))) + (vector-count-if t t pred sequence) + (vector-count-if t nil pred sequence))))) (define-sequence-traverser count (item sequence &key from-end start end @@@ -2206,7 -2204,7 +2218,7 @@@ (define-sequence-traverser mismatch (sequence1 sequence2 - &key from-end (test #'eql) test-not + &key from-end test test-not start1 end1 start2 end2 key) #!+sb-doc "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared @@@ -2251,29 -2249,31 +2263,29 @@@ `(do ((main ,main (cdr main)) (jndex start1 (1+ jndex)) (sub (nthcdr start1 ,sub) (cdr sub))) - ((or (null main) (null sub) (= (the fixnum end1) jndex)) + ((or (endp main) (endp sub) (<= end1 jndex)) t) - (declare (fixnum jndex)) + (declare (type (integer 0) jndex)) (compare-elements (car sub) (car main)))) (sb!xc:defmacro search-compare-list-vector (main sub) `(do ((main ,main (cdr main)) (index start1 (1+ index))) - ((or (null main) (= index (the fixnum end1))) t) - (declare (fixnum index)) + ((or (endp main) (= index end1)) t) (compare-elements (aref ,sub index) (car main)))) (sb!xc:defmacro search-compare-vector-list (main sub index) `(do ((sub (nthcdr start1 ,sub) (cdr sub)) (jndex start1 (1+ jndex)) (index ,index (1+ index))) - ((or (= (the fixnum end1) jndex) (null sub)) t) - (declare (fixnum jndex index)) + ((or (<= end1 jndex) (endp sub)) t) + (declare (type (integer 0) jndex)) (compare-elements (car sub) (aref ,main index)))) (sb!xc:defmacro search-compare-vector-vector (main sub index) `(do ((index ,index (1+ index)) (sub-index start1 (1+ sub-index))) - ((= sub-index (the fixnum end1)) t) - (declare (fixnum sub-index index)) + ((= sub-index end1) t) (compare-elements (aref ,sub sub-index) (aref ,main index)))) (sb!xc:defmacro search-compare (main-type main sub index) @@@ -2294,10 -2294,12 +2306,10 @@@ (sb!xc:defmacro list-search (main sub) `(do ((main (nthcdr start2 ,main) (cdr main)) (index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) + (terminus (- end2 (the (integer 0) (- end1 start1)))) (last-match ())) ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) + (declare (type (integer 0) index2)) (if (search-compare list main ,sub index2) (if from-end (setq last-match index2) @@@ -2305,10 -2307,12 +2317,10 @@@ (sb!xc:defmacro vector-search (main sub) `(do ((index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) + (terminus (- end2 (the (integer 0) (- end1 start1)))) (last-match ())) ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) + (declare (type (integer 0) index2)) (if (search-compare vector ,main ,sub index2) (if from-end (setq last-match index2) @@@ -2318,7 -2322,7 +2330,7 @@@ (define-sequence-traverser search (sequence1 sequence2 - &key from-end (test #'eql) test-not + &key from-end test test-not start1 end1 start2 end2 key) (declare (fixnum start1 start2)) (let ((end1 (or end1 length1)) diff --combined src/code/stream.lisp index aa91999,5e5b892..ed66194 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@@ -185,7 -185,7 +185,7 @@@ ;; private predicate function..) is ugly and confusing, but ;; I can't see any other way. -- WHN 2001-04-14 :expected-type '(satisfies stream-associated-with-file-p) - :format-string + :format-control "~@" :format-arguments (list stream)))) @@@ -1083,7 -1083,13 +1083,13 @@@ (:include ansi-stream) (:constructor nil) (:copier nil)) - (string nil :type string)) + ;; FIXME: This type declaration is true, and will probably continue + ;; to be true. However, note well the comments in DEFTRANSFORM + ;; REPLACE, implying that performance of REPLACE is somewhat + ;; critical to performance of string streams. If (VECTOR CHARACTER) + ;; ever becomes different from (VECTOR BASE-CHAR), the transform + ;; probably needs to be extended. + (string (missing-arg) :type (vector character))) ;;;; STRING-INPUT-STREAM stuff @@@ -1093,7 -1099,8 +1099,8 @@@ (bin #'string-binch) (n-bin #'string-stream-read-n-bytes) (misc #'string-in-misc) - (string nil :type simple-string)) + (string (missing-arg) + :type (simple-array character (*)))) (:constructor internal-make-string-input-stream (string current end)) (:copier nil)) @@@ -1103,7 -1110,8 +1110,8 @@@ (defun string-inch (stream eof-error-p eof-value) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (simple-string string) (fixnum index)) + (declare (type (simple-array character (*)) string) + (type fixnum index)) (cond ((= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) (t @@@ -1113,7 -1121,7 +1121,7 @@@ (defun string-binch (stream eof-error-p eof-value) (let ((string (string-input-stream-string stream)) (index (string-input-stream-current stream))) - (declare (simple-string string) + (declare (type (simple-array character (*)) string) (type index index)) (cond ((= index (the index (string-input-stream-end stream))) (eof-or-lose stream eof-error-p eof-value)) @@@ -1128,7 -1136,7 +1136,7 @@@ (index (string-input-stream-current stream)) (available (- (string-input-stream-end stream) index)) (copy (min available requested))) - (declare (simple-string string) + (declare (type (simple-array character (*)) string) (type index index available copy)) (when (plusp copy) (setf (string-input-stream-current stream) @@@ -1181,7 -1189,8 +1189,8 @@@ (sout #'string-sout) (misc #'string-out-misc) ;; The string we throw stuff in. - (string (make-string 40) :type simple-string)) + (string (make-string 40) + :type (simple-array character (*)))) (:constructor make-string-output-stream ()) (:copier nil)) ;; Index of the next location to use. @@@ -1195,7 -1204,8 +1204,8 @@@ (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) (fixnum current)) + (declare (type (simple-array character (*)) workspace) + (type fixnum current)) (if (= current (the fixnum (length workspace))) (let ((new-workspace (make-string (* current 2)))) (replace new-workspace workspace) @@@ -1205,13 -1215,17 +1215,17 @@@ (setf (string-output-stream-index stream) (1+ current)))) (defun string-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((current (string-output-stream-index stream)) + (declare (type simple-string string) + (type fixnum start end)) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) + (current (string-output-stream-index stream)) (length (- end start)) (dst-end (+ length current)) (workspace (string-output-stream-string stream))) - (declare (simple-string workspace) - (fixnum current length dst-end)) + (declare (type (simple-array character (*)) workspace string) + (type fixnum current length dst-end)) (if (> dst-end (the fixnum (length workspace))) (let ((new-workspace (make-string (+ (* current 2) length)))) (replace new-workspace workspace :end2 current) @@@ -1236,8 -1250,8 +1250,8 @@@ (count 0 (1+ count)) (string (string-output-stream-string stream))) ((< index 0) count) - (declare (simple-string string) - (fixnum index count)) + (declare (type (simple-array character (*)) string) + (type fixnum index count)) (if (char= (schar string index) #\newline) (return count)))) (:element-type 'base-char))) @@@ -1268,7 -1282,7 +1282,7 @@@ ;;; WITH-OUTPUT-TO-STRING. (deftype string-with-fill-pointer () - '(and string + '(and (vector character) (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream @@@ -1290,7 -1304,7 +1304,7 @@@ (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) - (declare (simple-string workspace)) + (declare (type (simple-array character (*)) workspace)) (let ((offset-current (+ start current))) (declare (fixnum offset-current)) (if (= offset-current end) @@@ -1309,20 -1323,23 +1323,23 @@@ (defun fill-pointer-sout (stream string start end) (declare (simple-string string) (fixnum start end)) - (let* ((buffer (fill-pointer-output-stream-string stream)) + (let* ((string (if (typep string '(simple-array character (*))) + string + (coerce string '(simple-array character (*))))) + (buffer (fill-pointer-output-stream-string stream)) (current (fill-pointer buffer)) (string-len (- end start)) (dst-end (+ string-len current))) (declare (fixnum current dst-end string-len)) (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (simple-string workspace)) + (declare (type (simple-array character (*)) workspace)) (let ((offset-dst-end (+ dst-start dst-end)) (offset-current (+ dst-start current))) (declare (fixnum offset-dst-end offset-current)) (if (> offset-dst-end dst-length) (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) + (declare (type (simple-array character (*)) new-workspace)) (%byte-blt workspace dst-start new-workspace 0 current) (setf workspace new-workspace) diff --combined src/code/string.lisp index d38fdb0,e638523..f5aa2fa --- a/src/code/string.lisp +++ b/src/code/string.lisp @@@ -37,7 -37,13 +37,7 @@@ ;;; strings in the unasterisked versions and using this in the ;;; transforms conditional on SAFETY>SPEED,SPACE). (defun %check-vector-sequence-bounds (vector start end) - (declare (type vector vector) - (type index start) - (type (or index null) end)) - (let ((length (length vector))) - (if (<= 0 start (or end length) length) - (or end length) - (signal-bounding-indices-bad-error string start end)))) + (%check-vector-sequence-bounds vector start end)) (eval-when (:compile-toplevel) ;;; WITH-ONE-STRING is used to set up some string hacking things. The @@@ -342,19 -348,16 +342,16 @@@ (using char-equal) of the two strings. Otherwise, returns ()." (string-not-greaterp* string1 string2 start1 end1 start2 end2)) - (defun make-string (count &key element-type ((:initial-element fill-char))) + (defun make-string (count &key + (element-type 'character) + ((:initial-element fill-char))) #!+sb-doc "Given a character count and an optional fill character, makes and returns - a new string Count long filled with the fill character." - (declare (fixnum count) - (ignore element-type)) + a new string COUNT long filled with the fill character." + (declare (fixnum count)) (if fill-char - (do ((i 0 (1+ i)) - (string (make-string count))) - ((= i count) string) - (declare (fixnum i)) - (setf (schar string i) fill-char)) - (make-string count))) + (make-string count :element-type element-type :initial-element fill-char) + (make-string count :element-type element-type))) (flet ((%upcase (string start end) (declare (string string) (index start) (type sequence-end end)) diff --combined src/compiler/array-tran.lisp index 76e6f48,d425b36..b6b7c51 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@@ -41,12 -41,6 +41,12 @@@ ;; 2002-08-21 *wild-type*))) +(defun extract-declared-element-type (array) + (let ((type (continuation-type array))) + (if (array-type-p type) + (array-type-element-type type) + *wild-type*))) + ;;; The ``new-value'' for array setters must fit in the array, and the ;;; return type is going to be the same as the new-value for SETF ;;; functions. @@@ -142,12 -136,7 +142,12 @@@ `(,(if simple 'simple-array 'array) ,(cond ((not element-type) t) ((constant-continuation-p element-type) - (continuation-value element-type)) + (let ((ctype (careful-specifier-type + (continuation-value element-type)))) + (cond + ((or (null ctype) (unknown-type-p ctype)) '*) + (t (sb!xc:upgraded-array-element-type + (continuation-value element-type)))))) (t '*)) ,(cond ((constant-continuation-p dims) @@@ -200,83 -189,13 +200,13 @@@ ;;; Just convert it into a MAKE-ARRAY. (deftransform make-string ((length &key - (element-type 'base-char) + (element-type 'character) (initial-element #.*default-init-char-form*))) - '(make-array (the index length) - :element-type element-type - :initial-element initial-element)) - - (defstruct (specialized-array-element-type-properties - (:conc-name saetp-) - (:constructor !make-saetp (ctype - initial-element-default - n-bits - typecode - &key - (n-pad-elements 0))) - (:copier nil)) - ;; the element type, e.g. # or - ;; # - (ctype (missing-arg) :type ctype :read-only t) - ;; what we get when the low-level vector-creation logic zeroes all - ;; the bits (which also serves as the default value of MAKE-ARRAY's - ;; :INITIAL-ELEMENT keyword) - (initial-element-default (missing-arg) :read-only t) - ;; how many bits per element - (n-bits (missing-arg) :type index :read-only t) - ;; the low-level type code - (typecode (missing-arg) :type index :read-only t) - ;; the number of extra elements we use at the end of the array for - ;; low level hackery (e.g., one element for arrays of BASE-CHAR, - ;; which is used for a fixed #\NULL so that when we call out to C - ;; we don't need to cons a new copy) - (n-pad-elements (missing-arg) :type index :read-only t)) - - (defparameter *specialized-array-element-type-properties* - (map 'simple-vector - (lambda (args) - (destructuring-bind (type-spec &rest rest) args - (let ((ctype (specifier-type type-spec))) - (apply #'!make-saetp ctype rest)))) - `(;; Erm. Yeah. There aren't a lot of things that make sense - ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07 - (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag) - (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag - ;; (SIMPLE-STRINGs are stored with an extra trailing - ;; #\NULL for convenience in calling out to C.) - :n-pad-elements 1) - (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag) - (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag) - #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128 - ,sb!vm:simple-array-long-float-widetag) - (bit 0 1 ,sb!vm:simple-bit-vector-widetag) - ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come - ;; before their SIGNED-BYTE partners is significant in the - ;; implementation of the compiler; some of the cross-compiler - ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in - ;; src/compiler/debug-dump.lisp) attempts to create an array - ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7; - ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're - ;; not careful we could get the wrong specialized array when - ;; we try to FIND-IF, below. -- CSR, 2002-07-08 - ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag) - ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag) - ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag) - ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag) - ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag) - ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag) - ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag) - ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag) - ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag) - ((complex single-float) #C(0.0f0 0.0f0) 64 - ,sb!vm:simple-array-complex-single-float-widetag) - ((complex double-float) #C(0.0d0 0.0d0) 128 - ,sb!vm:simple-array-complex-double-float-widetag) - #!+long-float ((complex long-float) #C(0.0L0 0.0L0) - #!+x86 192 #!+sparc 256 - ,sb!vm:simple-array-complex-long-float-widetag) - (t 0 32 ,sb!vm:simple-vector-widetag)))) + `(the simple-string (make-array (the index length) + :element-type element-type + ,@(when initial-element + '(:initial-element initial-element))))) (deftransform make-array ((dims &key initial-element element-type adjustable fill-pointer) @@@ -291,10 -210,10 +221,10 @@@ (continuation-value element-type)))) (eltype-type (ir1-transform-specifier-type eltype)) (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (saetp-ctype saetp))) - *specialized-array-element-type-properties*)) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*)) (creation-form `(make-array dims - :element-type ',(type-specifier (saetp-ctype saetp)) + :element-type ',(type-specifier (sb!vm:saetp-ctype saetp)) ,@(when fill-pointer '(:fill-pointer fill-pointer)) ,@(when adjustable @@@ -305,7 -224,7 +235,7 @@@ (cond ((and (constant-continuation-p initial-element) (eql (continuation-value initial-element) - (saetp-initial-element-default saetp))) + (sb!vm:saetp-initial-element-default saetp))) creation-form) (t ;; error checking for target, disabled on the host because @@@ -314,13 -233,13 +244,13 @@@ (when (constant-continuation-p initial-element) (let ((value (continuation-value initial-element))) (cond - ((not (ctypep value (saetp-ctype saetp))) + ((not (ctypep value (sb!vm:saetp-ctype saetp))) ;; this case will cause an error at runtime, so we'd ;; better WARN about it now. (compiler-warn "~@<~S is not a ~S (which is the ~ UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>" value - (type-specifier (saetp-ctype saetp)) + (type-specifier (sb!vm:saetp-ctype saetp)) eltype)) ((not (ctypep value eltype-type)) ;; this case will not cause an error at runtime, but @@@ -349,22 -268,16 +279,22 @@@ (len (if (constant-continuation-p length) (continuation-value length) '*)) - (result-type-spec `(simple-array ,eltype (,len))) (eltype-type (ir1-transform-specifier-type eltype)) + (result-type-spec + `(simple-array + ,(if (unknown-type-p eltype-type) + (give-up-ir1-transform + "ELEMENT-TYPE is an unknown type: ~S" eltype) + (sb!xc:upgraded-array-element-type eltype)) + (,len))) (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (saetp-ctype saetp))) - *specialized-array-element-type-properties*))) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*))) (unless saetp (give-up-ir1-transform "cannot open-code creation of ~S" result-type-spec)) #-sb-xc-host - (unless (csubtypep (ctype-of (saetp-initial-element-default saetp)) + (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp)) eltype-type) ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If @@@ -377,11 -290,11 +307,11 @@@ ;; he writes code:-), we'll signal a STYLE-WARNING in case he ;; didn't realize this. (compiler-style-warn "The default initial element ~S is not a ~S." - (saetp-initial-element-default saetp) + (sb!vm:saetp-initial-element-default saetp) eltype)) - (let* ((n-bits-per-element (saetp-n-bits saetp)) - (typecode (saetp-typecode saetp)) - (n-pad-elements (saetp-n-pad-elements saetp)) + (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp)) + (typecode (sb!vm:saetp-typecode saetp)) + (n-pad-elements (sb!vm:saetp-n-pad-elements saetp)) (padded-length-form (if (zerop n-pad-elements) 'length `(+ length ,n-pad-elements))) @@@ -432,11 -345,8 +362,11 @@@ (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) - ((constant-continuation-p element-type) - (continuation-value element-type)) + ((and (constant-continuation-p element-type) + (ir1-transform-specifier-type + (continuation-value element-type))) + (sb!xc:upgraded-array-element-type + (continuation-value element-type))) (t '*)) ,(make-list rank :initial-element '*)))) `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) @@@ -585,7 -495,7 +515,7 @@@ (give-up-ir1-transform)) (t (let ((dim (continuation-value dimension))) - `(the (integer 0 ,dim) index))))) + `(the (integer 0 (,dim)) index))))) ;;;; WITH-ARRAY-DATA @@@ -833,17 -743,16 +763,17 @@@ ;;; value? ;;; Pick off some constant cases. -(deftransform array-header-p ((array) (array)) +(defoptimizer (array-header-p derive-type) ((array)) (let ((type (continuation-type array))) - (unless (array-type-p type) - (give-up-ir1-transform)) - (let ((dims (array-type-dimensions type))) - (cond ((csubtypep type (specifier-type '(simple-array * (*)))) - ;; no array header - nil) - ((and (listp dims) (/= (length dims) 1)) - ;; multi-dimensional array, will have a header - t) - (t - (give-up-ir1-transform)))))) + (cond ((not (array-type-p type)) + nil) + (t + (let ((dims (array-type-dimensions type))) + (cond ((csubtypep type (specifier-type '(simple-array * (*)))) + ;; no array header + (specifier-type 'null)) + ((and (listp dims) (/= (length dims) 1)) + ;; multi-dimensional array, will have a header + (specifier-type '(eql t))) + (t + nil))))))) diff --combined src/compiler/fndb.lisp index 50f40e3,592dab1..6b80f4d --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@@ -44,7 -44,7 +44,7 @@@ (defknown type-of (t) t (foldable flushable)) ;;; These can be affected by type definitions, so they're not FOLDABLE. -(defknown (upgraded-complex-part-type upgraded-array-element-type) +(defknown (upgraded-complex-part-type sb!xc:upgraded-array-element-type) (type-specifier &optional lexenv-designator) type-specifier (unsafely-flushable)) @@@ -455,11 -455,11 +455,11 @@@ (:initial-element t)) consed-sequence (movable unsafe) - :derive-type (result-type-specifier-nth-arg 1)) + :derive-type (creation-result-type-specifier-nth-arg 1)) (defknown concatenate (type-specifier &rest sequence) consed-sequence () - :derive-type (result-type-specifier-nth-arg 1)) + :derive-type (creation-result-type-specifier-nth-arg 1)) (defknown (map %map) (type-specifier callable sequence &rest sequence) consed-sequence @@@ -642,7 -642,7 +642,7 @@@ &key (:key callable)) sequence (call) - :derive-type (result-type-specifier-nth-arg 1)) + :derive-type (creation-result-type-specifier-nth-arg 1)) ;;; not FLUSHABLE, despite what CMU CL's DEFKNOWN said.. (defknown read-sequence (sequence stream @@@ -684,9 -684,9 +684,9 @@@ (foldable flushable call)) (defknown endp (list) boolean (foldable flushable movable)) (defknown list-length (list) (or index null) (foldable unsafely-flushable)) -(defknown nth (index list) t (foldable flushable)) -(defknown nthcdr (index list) t (foldable unsafely-flushable)) -(defknown last (list &optional index) t (foldable flushable)) +(defknown nth (unsigned-byte list) t (foldable flushable)) +(defknown nthcdr (unsigned-byte list) t (foldable unsafely-flushable)) +(defknown last (list &optional unsigned-byte) t (foldable flushable)) (defknown list (&rest t) list (movable flushable unsafe)) (defknown list* (t &rest t) t (movable flushable unsafe)) (defknown make-list (index &key (:initial-element t)) list @@@ -707,8 -707,8 +707,8 @@@ (defknown nconc (&rest t) t ()) (defknown nreconc (list t) t ()) -(defknown butlast (list &optional index) list (flushable)) -(defknown nbutlast (list &optional index) list ()) +(defknown butlast (list &optional unsigned-byte) list (flushable)) +(defknown nbutlast (list &optional unsigned-byte) list ()) (defknown ldiff (list t) list (flushable)) (defknown (rplaca rplacd) (cons t) list (unsafe)) @@@ -1179,32 -1179,12 +1179,32 @@@ (defknown directory (pathname-designator &key) list ()) -;;;; from the "Errors" chapter: - -(defknown error (t &rest t) nil) ; never returns -(defknown cerror (string t &rest t) null) +;;;; from the "Conditions" chapter: + +(defknown cell-error-name (cell-error) t) +(defknown error (t &rest t) nil) +(defknown cerror (format-control t &rest t) null) +(defknown invalid-method-error (t format-control &rest t) *) ; FIXME: first arg is METHOD +(defknown method-combination-error (format-control &rest t) *) +(defknown signal (t &rest t) null) +(defknown simple-condition-format-control (condition) + format-control) +(defknown simple-condition-format-arguments (condition) + list) (defknown warn (t &rest t) null) -(defknown break (&optional t &rest t) null) +(defknown invoke-debugger (condition) nil) +(defknown break (&optional format-control &rest t) null) +(defknown make-condition (type-specifier &rest t) condition) +(defknown compute-restarts (&optional (or condition null)) list) +(defknown find-restart (restart-designator &optional (or condition null)) + (or restart null)) +(defknown invoke-restart (restart-designator &rest t) *) +(defknown invoke-restart-interactively (restart-designator) *) +(defknown restart-name (restart) symbol) +(defknown (abort muffle-warning) (&optional (or condition null)) nil) +(defknown continue (&optional (or condition null)) null) +(defknown (store-value use-value) (t &optional (or condition null)) + null) ;;; and analogous SBCL extension: (defknown bug (t &rest t) nil) ; never returns @@@ -1413,7 -1393,7 +1413,7 @@@ (defknown (setf fdocumentation) ((or string null) t symbol) (or string null) ()) -(defknown %setnth (index list t) t (unsafe)) +(defknown %setnth (unsigned-byte list t) t (unsafe)) (defknown %set-fill-pointer (vector index) index (unsafe)) ;;;; miscellaneous internal utilities diff --combined src/compiler/generic/vm-tran.lisp index 634e687,3298c81..37fdb87 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@@ -41,10 -41,18 +41,19 @@@ ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET + (deftransform hairy-data-vector-ref ((string index) (simple-string t)) + (let ((ctype (continuation-type string))) + (if (array-type-p ctype) + ;; the other transform will kick in, so that's OK + (give-up-ir1-transform) + `(typecase string + ((simple-array character (*)) (data-vector-ref string index)) + ((simple-array nil (*)) (data-vector-ref string index)))))) + (deftransform hairy-data-vector-ref ((array index) (array t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@@ -57,11 -65,7 +66,11 @@@ `(multiple-value-bind (array index) (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) - (data-vector-ref array index))))) + ,(let ((bare-form '(data-vector-ref array index))) + (if (type= element-ctype declared-element-ctype) + bare-form + `(the ,(type-specifier declared-element-ctype) + ,bare-form))))))) (deftransform data-vector-ref ((array index) (simple-array t)) @@@ -80,13 -84,12 +89,25 @@@ (%array-data-vector array)) index))))) ++(deftransform hairy-data-vector-set ((string index new-value) ++ (simple-string t t)) ++ (let ((ctype (continuation-type string))) ++ (if (array-type-p ctype) ++ ;; the other transform will kick in, so that's OK ++ (give-up-ir1-transform) ++ `(typecase string ++ ((simple-array character (*)) ++ (data-vector-set string index new-value)) ++ ((simple-array nil (*)) ++ (data-vector-set string index new-value)))))) ++ (deftransform hairy-data-vector-set ((array index new-value) (array t t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@@ -96,12 -99,21 +117,12 @@@ (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array) (type ,element-type-specifier new-value)) - (data-vector-set array - index - new-value))))) - -(deftransform hairy-data-vector-set ((string index new-value) - (simple-string t t)) - (let ((ctype (continuation-type string))) - (if (array-type-p ctype) - ;; the other transform will kick in, so that's OK - (give-up-ir1-transform) - `(typecase string - ((simple-array character (*)) - (data-vector-set string index new-value)) - ((simple-array nil (*)) - (data-vector-set string index new-value)))))) + ,(if (type= element-ctype declared-element-ctype) + '(data-vector-set array index new-value) + `(truly-the ,(type-specifier declared-element-ctype) + (data-vector-set array index + (the ,(type-specifier declared-element-ctype) + new-value)))))))) (deftransform data-vector-set ((array index new-value) (simple-array t t)) diff --combined src/compiler/generic/vm-type.lisp index 4b47009,cde035f..f432393 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@@ -14,10 -14,6 +14,6 @@@ (in-package "SB!KERNEL") - (/show0 "vm-type.lisp 17") - - (!begin-collecting-cold-init-forms) - ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817 (deftype sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits)) @@@ -78,29 -74,6 +74,6 @@@ ;;;; hooks into the type system - ;;; the kinds of specialized array that actually exist in this implementation - (defvar *specialized-array-element-types*) - (!cold-init-forms - (setf *specialized-array-element-types* - '(nil - bit - (unsigned-byte 2) - (unsigned-byte 4) - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - (signed-byte 8) - (signed-byte 16) - (signed-byte 30) - (signed-byte 32) - (complex single-float) - (complex double-float) - #!+long-float (complex long-float) - base-char - single-float - double-float - #!+long-float long-float))) - (sb!xc:deftype unboxed-array (&optional dims) (collect ((types (list 'or))) (dolist (type *specialized-array-element-types*) @@@ -146,20 -119,11 +119,21 @@@ ;; them on the fly this way? (Call the new array ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..) (let ((stype (specifier-type stype-name))) + (aver (not (unknown-type-p stype))) (when (csubtypep eltype stype) (return stype)))))) type)) +(defun sb!xc:upgraded-array-element-type (spec &optional environment) + #!+sb-doc + "Return the element type that will actually be used to implement an array + with the specifier :ELEMENT-TYPE Spec." + (declare (ignore environment)) + (if (unknown-type-p (specifier-type spec)) + (error "undefined type: ~S" spec) + (type-specifier (array-type-specialized-element-type + (specifier-type `(array ,spec)))))) + ;;; Return the most specific integer type that can be quickly checked that ;;; includes the given type. (defun containing-integer-type (subtype) @@@ -196,7 -160,3 +170,3 @@@ 'sb!c:check-fun) (t nil))) - - (!defun-from-collected-cold-init-forms !vm-type-cold-init) - - (/show0 "vm-type.lisp end of file") diff --combined src/compiler/knownfun.lisp index bd35c93,70dc67a..d28f79e --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@@ -116,8 -116,6 +116,8 @@@ (predicate-type nil :type (or ctype null))) (defprinter (fun-info) + (attributes :test (not (zerop attributes)) + :prin1 (decode-ir1-attributes attributes)) (transforms :test transforms) (derive-type :test derive-type) (optimizer :test optimizer) @@@ -262,7 -260,7 +262,7 @@@ (when (csubtypep type ltype) ltype)))))))) - ;;; Derive the type to be the type specifier which is the N'th arg. + ;;; Derive the type to be the type specifier which is the Nth arg. (defun result-type-specifier-nth-arg (n) (lambda (call) (declare (type combination call)) @@@ -270,4 -268,29 +270,29 @@@ (when (and cont (constant-continuation-p cont)) (careful-specifier-type (continuation-value cont)))))) + ;;; Derive the type to be the type specifier which is the Nth arg, + ;;; with the additional restriptions noted in the CLHS for STRING and + ;;; SIMPLE-STRING. + (defun creation-result-type-specifier-nth-arg (n) + (lambda (call) + (declare (type combination call)) + (let ((cont (nth (1- n) (combination-args call)))) + (when (and cont (constant-continuation-p cont)) + (let* ((specifier (continuation-value cont)) + (lspecifier (if (atom specifier) (list specifier) specifier))) + (cond + ((eq (car lspecifier) 'string) + (destructuring-bind (string &rest size) + lspecifier + (declare (ignore string)) + (careful-specifier-type + `(vector character ,@(when size size))))) + ((eq (car lspecifier) 'simple-string) + (destructuring-bind (simple-string &rest size) + lspecifier + (declare (ignore simple-string)) + (careful-specifier-type + `(simple-array character ,@(if size (list size) '((*))))))) + (t (careful-specifier-type specifier)))))))) + (/show0 "knownfun.lisp end of file") diff --combined version.lisp-expr index 4606f8f,5ca7467..4e2d67d --- a/version.lisp-expr +++ b/version.lisp-expr @@@ -17,4 -17,4 +17,4 @@@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) - "0.8.1.33" -"0.8.0.78.vector-nil-string.15" ++"0.8.1.34"