;; 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
("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
("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")
"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"
"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"
"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"
"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"
"VALUES-TYPE-REST" "VALUES-TYPE-UNION"
"VALUES-TYPE-TYPES" "VALUES-TYPES"
"VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
+ "VECTOR-NIL-P"
"VECTOR-TO-VECTOR*"
"VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
"WITH-ARRAY-DATA"
"!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"
"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"
"*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"
"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"
;; 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)))))
(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)
(coerce (the list objects) 'simple-vector))
\f
;;;; 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
(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))
`(= 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
(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
,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)
--- /dev/null
+;;;; When this file's top level forms are run, it precomputes the
+;;;; translations for built in classes. This stuff is split off from
+;;;; the other type stuff to get around problems with everything
+;;;; needing to be loaded before everything else. This file is the
+;;;; first to exercise the type machinery.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+;;; built-in classes
+(/show0 "beginning class-init.lisp")
+(dolist (x *built-in-classes*)
+ (destructuring-bind (name &key (translation nil trans-p) &allow-other-keys)
+ x
+ (/show0 "doing class with NAME=..")
+ (/primitive-print (symbol-name name))
+ (when trans-p
+ (/show0 "in TRANS-P case")
+ (let ((classoid (classoid-cell-classoid (find-classoid-cell name)))
+ (type (specifier-type translation)))
+ (setf (built-in-classoid-translation classoid) type)
+ (setf (info :type :builtin name) type)))))
+
+(/show0 "done with class-init.lisp")
:inherits (function)
:state :read-only)
+ (number :translation number)
+ (complex
+ :translation complex
+ :inherits (number)
+ :codes (#.sb!vm:complex-widetag))
+ (complex-single-float
+ :translation (complex single-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-single-float-widetag))
+ (complex-double-float
+ :translation (complex double-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-double-float-widetag))
+ #!+long-float
+ (complex-long-float
+ :translation (complex long-float)
+ :inherits (complex number)
+ :codes (#.sb!vm:complex-long-float-widetag))
+ (real :translation real :inherits (number))
+ (float
+ :translation float
+ :inherits (real number))
+ (single-float
+ :translation single-float
+ :inherits (float real number)
+ :codes (#.sb!vm:single-float-widetag))
+ (double-float
+ :translation double-float
+ :inherits (float real number)
+ :codes (#.sb!vm:double-float-widetag))
+ #!+long-float
+ (long-float
+ :translation long-float
+ :inherits (float real number)
+ :codes (#.sb!vm:long-float-widetag))
+ (rational
+ :translation rational
+ :inherits (real number))
+ (ratio
+ :translation (and rational (not integer))
+ :inherits (rational real number)
+ :codes (#.sb!vm:ratio-widetag))
+ (integer
+ :translation integer
+ :inherits (rational real number))
+ (fixnum
+ :translation (integer #.sb!xc:most-negative-fixnum
+ #.sb!xc:most-positive-fixnum)
+ :inherits (integer rational real number)
+ :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
+ (bignum
+ :translation (and integer (not fixnum))
+ :inherits (integer rational real number)
+ :codes (#.sb!vm:bignum-widetag))
+
(array :translation array :codes (#.sb!vm:complex-array-widetag)
:hierarchical-p nil)
(simple-array
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-16
- :translation (simple-array (unsigned-byte 16) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (unsigned-byte 16) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-32
- :translation (simple-array (unsigned-byte 32) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (unsigned-byte 32) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-8
- :translation (simple-array (signed-byte 8) (*))
- :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (signed-byte 8) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-16
- :translation (simple-array (signed-byte 16) (*))
- :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (signed-byte 16) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-30
- :translation (simple-array (signed-byte 30) (*))
- :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (signed-byte 30) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-signed-byte-32
- :translation (simple-array (signed-byte 32) (*))
- :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array (signed-byte 32) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-single-float
- :translation (simple-array single-float (*))
- :codes (#.sb!vm:simple-array-single-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
+ :translation (simple-array single-float (*))
+ :codes (#.sb!vm:simple-array-single-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
(simple-array-double-float
- :translation (simple-array double-float (*))
- :codes (#.sb!vm:simple-array-double-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
- #!+long-float
- (simple-array-long-float
- :translation (simple-array long-float (*))
- :codes (#.sb!vm:simple-array-long-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
- (simple-array-complex-single-float
- :translation (simple-array (complex single-float) (*))
- :codes (#.sb!vm:simple-array-complex-single-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
- (simple-array-complex-double-float
- :translation (simple-array (complex double-float) (*))
- :codes (#.sb!vm:simple-array-complex-double-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
- #!+long-float
- (simple-array-complex-long-float
- :translation (simple-array (complex long-float) (*))
- :codes (#.sb!vm:simple-array-complex-long-float-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence))
- (string
- :translation string
- :codes (#.sb!vm:complex-string-widetag)
- :direct-superclasses (vector)
- :inherits (vector array sequence))
- (simple-string
- :translation simple-string
- :codes (#.sb!vm:simple-string-widetag)
- :direct-superclasses (string simple-array)
- :inherits (string vector simple-array
- array sequence))
- (list
- :translation (or cons (member nil))
- :inherits (sequence))
- (cons
- :codes (#.sb!vm:list-pointer-lowtag)
- :translation cons
- :inherits (list sequence))
- (null
- :translation (member nil)
- :inherits (symbol list sequence)
- :direct-superclasses (symbol list))
- (number :translation number)
- (complex
- :translation complex
- :inherits (number)
- :codes (#.sb!vm:complex-widetag))
- (complex-single-float
- :translation (complex single-float)
- :inherits (complex number)
- :codes (#.sb!vm:complex-single-float-widetag))
- (complex-double-float
- :translation (complex double-float)
- :inherits (complex number)
- :codes (#.sb!vm:complex-double-float-widetag))
- #!+long-float
- (complex-long-float
- :translation (complex long-float)
- :inherits (complex number)
- :codes (#.sb!vm:complex-long-float-widetag))
- (real :translation real :inherits (number))
- (float
- :translation float
- :inherits (real number))
- (single-float
- :translation single-float
- :inherits (float real number)
- :codes (#.sb!vm:single-float-widetag))
- (double-float
- :translation double-float
- :inherits (float real number)
- :codes (#.sb!vm:double-float-widetag))
- #!+long-float
- (long-float
- :translation long-float
- :inherits (float real number)
- :codes (#.sb!vm:long-float-widetag))
- (rational
- :translation rational
- :inherits (real number))
- (ratio
- :translation (and rational (not integer))
- :inherits (rational real number)
- :codes (#.sb!vm:ratio-widetag))
- (integer
- :translation integer
- :inherits (rational real number))
- (fixnum
- :translation (integer #.sb!xc:most-negative-fixnum
- #.sb!xc:most-positive-fixnum)
- :inherits (integer rational real number)
- :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
- (bignum
- :translation (and integer (not fixnum))
- :inherits (integer rational real number)
- :codes (#.sb!vm:bignum-widetag))
- (stream
- :state :read-only
- :depth 3
- :inherits (instance)))))
+ :translation (simple-array double-float (*))
+ :codes (#.sb!vm:simple-array-double-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ #!+long-float
+ (simple-array-long-float
+ :translation (simple-array long-float (*))
+ :codes (#.sb!vm:simple-array-long-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (simple-array-complex-single-float
+ :translation (simple-array (complex single-float) (*))
+ :codes (#.sb!vm:simple-array-complex-single-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (simple-array-complex-double-float
+ :translation (simple-array (complex double-float) (*))
+ :codes (#.sb!vm:simple-array-complex-double-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ #!+long-float
+ (simple-array-complex-long-float
+ :translation (simple-array (complex long-float) (*))
+ :codes (#.sb!vm:simple-array-complex-long-float-widetag)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence))
+ (string
+ :translation string
+ :direct-superclasses (vector)
+ :inherits (vector array sequence))
+ (simple-string
+ :translation simple-string
+ :direct-superclasses (string simple-array)
+ :inherits (string vector simple-array array sequence))
+ (vector-nil
+ ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))?
+ :translation (vector nil)
+ :codes (#.sb!vm:complex-vector-nil-widetag)
+ :direct-superclasses (string)
+ :inherits (string vector array sequence))
+ (simple-array-nil
+ :translation (simple-array nil (*))
+ :codes (#.sb!vm:simple-array-nil-widetag)
+ :direct-superclasses (vector-nil simple-string)
+ :inherits (vector-nil simple-string string vector simple-array array sequence))
+ (base-string
+ :translation base-string
+ :codes (#.sb!vm:complex-base-string-widetag)
+ :direct-superclasses (string)
+ :inherits (string vector array sequence))
+ (simple-base-string
+ :translation simple-base-string
+ :codes (#.sb!vm:simple-base-string-widetag)
+ :direct-superclasses (base-string simple-string)
+ :inherits (base-string simple-string string vector simple-array
+ array sequence))
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence))
+ (cons
+ :codes (#.sb!vm:list-pointer-lowtag)
+ :translation cons
+ :inherits (list sequence))
+ (null
+ :translation (member nil)
+ :inherits (symbol list sequence)
+ :direct-superclasses (symbol list))
+
+ (stream
+ :state :read-only
+ :depth 3
+ :inherits (instance)))))
-;;; comment from CMU CL:
-;;; See also type-init.lisp where we finish setting up the
-;;; translations for built-in types.
+;;; See also src/code/class-init.lisp where we finish setting up the
+;;; translations for built-in types.
(!cold-init-forms
(dolist (x *built-in-classes*)
#-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
;; DEFTYPEs are.
(setf *type-system-initialized* t)
+ ;; now that the type system is definitely initialized, fixup UNKNOWN
+ ;; types that have crept in.
+ (show-and-call !fixup-type-cold-init)
;; run the PROCLAIMs.
(show-and-call !late-proclaim-cold-init)
(defun stringify-name (name kind)
(typecase name
- (simple-string name)
- (string (coerce name 'simple-string))
+ (simple-base-string name)
+ (string (coerce name 'simple-base-string))
(symbol (symbol-name name))
(base-char (string name))
(t
(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 ()
`(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)))
(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 ()
(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
:datum object
:expected-type 'simple-string))
-(deferr object-not-simple-bit-vector-error (object)
- (error 'type-error
- :datum object
- :expected-type 'simple-bit-vector))
-
-(deferr object-not-simple-vector-error (object)
- (error 'type-error
- :datum object
- :expected-type 'simple-vector))
-
(deferr object-not-fixnum-error (object)
(error 'type-error
:datum object
:datum object
:expected-type 'string))
+(deferr object-not-base-string-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type 'base-string))
+
(deferr object-not-bit-vector-error (object)
(error 'type-error
:datum object
:datum object
:expected-type '(unsigned-byte 32)))
-(deferr object-not-simple-array-nil-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array nil (*))))
-
-(deferr object-not-simple-array-unsigned-byte-2-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (unsigned-byte 2) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-4-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (unsigned-byte 4) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-8-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (unsigned-byte 8) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-16-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (unsigned-byte 16) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-32-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (unsigned-byte 32) (*))))
-
-(deferr object-not-simple-array-signed-byte-8-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (signed-byte 8) (*))))
-
-(deferr object-not-simple-array-signed-byte-16-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (signed-byte 16) (*))))
-
-(deferr object-not-simple-array-signed-byte-30-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (signed-byte 30) (*))))
-
-(deferr object-not-simple-array-signed-byte-32-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (signed-byte 32) (*))))
-
-(deferr object-not-simple-array-single-float-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array single-float (*))))
-
-(deferr object-not-simple-array-double-float-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array double-float (*))))
-
-(deferr object-not-simple-array-complex-single-float-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (complex single-float) (*))))
-
-(deferr object-not-simple-array-complex-double-float-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (complex double-float) (*))))
-
-#!+long-float
-(deferr object-not-simple-array-complex-long-float-error (object)
- (error 'type-error
- :datum object
- :expected-type '(simple-array (complex long-float) (*))))
+(macrolet
+ ((define-simple-array-internal-errors ()
+ `(progn
+ ,@(map 'list
+ (lambda (saetp)
+ `(deferr ,(symbolicate
+ "OBJECT-NOT-"
+ (sb!vm:saetp-primitive-type-name saetp)
+ "-ERROR")
+ (object)
+ (error 'type-error
+ :datum object
+ :expected-type `(simple-array
+ ,(sb!vm:saetp-specifier saetp)
+ (*)))))
+ sb!vm:*specialized-array-element-type-properties*))))
+ (define-simple-array-internal-errors))
(deferr object-not-complex-error (object)
(error 'type-error
(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
(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)
((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
#!+sb-doc
"the standard structure for the description of a package"
;; the name of the package, or NIL for a deleted package
- (%name nil :type (or simple-string null))
+ (%name nil :type (or simple-base-string null))
;; nickname strings
(%nicknames () :type list)
;; packages used by this package
;; shadowing symbols
(%shadowing-symbols () :type list)
;; documentation string for this package
- (doc-string nil :type (or simple-string null)))
+ (doc-string nil :type (or simple-base-string null)))
\f
;;;; iteration macros
(def-type-predicate-wrapper arrayp)
(def-type-predicate-wrapper atom)
(def-type-predicate-wrapper base-char-p)
+ (def-type-predicate-wrapper base-string-p)
(def-type-predicate-wrapper bignump)
(def-type-predicate-wrapper bit-vector-p)
(def-type-predicate-wrapper characterp)
(def-type-predicate-wrapper short-float-p)
(def-type-predicate-wrapper sb!kernel:simple-array-p)
(def-type-predicate-wrapper simple-bit-vector-p)
+ (def-type-predicate-wrapper simple-base-string-p)
(def-type-predicate-wrapper simple-string-p)
(def-type-predicate-wrapper simple-vector-p)
(def-type-predicate-wrapper single-float-p)
(def-type-predicate-wrapper vectorp)
(def-type-predicate-wrapper unsigned-byte-32-p)
(def-type-predicate-wrapper signed-byte-32-p)
+ (def-type-predicate-wrapper simple-array-nil-p)
(def-type-predicate-wrapper simple-array-unsigned-byte-2-p)
(def-type-predicate-wrapper simple-array-unsigned-byte-4-p)
(def-type-predicate-wrapper simple-array-unsigned-byte-8-p)
;; check for bad lengths, the type system is needed
;; for calls to CONCATENATE. So we need to make sure
;; that the calls are transformed away:
- (1 (concatenate 'string (the simple-string (string (car things)))))
+ (1 (concatenate 'string
+ (the simple-base-string (string (car things)))))
(2 (concatenate 'string
- (the simple-string (string (car things)))
- (the simple-string (string (cadr things)))))
+ (the simple-base-string (string (car things)))
+ (the simple-base-string (string (cadr things)))))
(3 (concatenate 'string
- (the simple-string (string (car things)))
- (the simple-string (string (cadr things)))
- (the simple-string (string (caddr things)))))
+ (the simple-base-string (string (car things)))
+ (the simple-base-string (string (cadr things)))
+ (the simple-base-string (string (caddr things)))))
(t (apply #'concatenate 'string (mapcar #'string things))))))
(values (intern name)))))
;;; words, diddle its case according to *PRINT-CASE* and
;;; READTABLE-CASE.
(defun output-symbol-name (name stream &optional (maybe-quote t))
- (declare (type simple-base-string name))
+ (declare (type simple-string name))
(setup-printer-state)
(if (and maybe-quote (symbol-quotep name))
(output-quoted-symbol-name name stream)
(defvar *ouch-ptr*)
(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
-(declaim (simple-string *read-buffer*))
+(declaim (type (simple-array character (*)) *read-buffer*))
(defmacro reset-read-buffer ()
;; Turn *READ-BUFFER* into an empty read buffer.
:kind :fixed
:length size))))))
-(dolist (code (list complex-string-widetag simple-array-widetag
+(dolist (code (list complex-base-string-widetag simple-array-widetag
complex-bit-vector-widetag complex-vector-widetag
- complex-array-widetag))
+ complex-array-widetag complex-vector-nil-widetag))
(setf (svref *meta-room-info* code)
(make-room-info :name 'array-header
:kind :header)))
:kind :vector
:length size))))
-(setf (svref *meta-room-info* simple-string-widetag)
- (make-room-info :name 'simple-string
+(setf (svref *meta-room-info* simple-base-string-widetag)
+ (make-room-info :name 'simple-base-string
:kind :string
:length 0))
((#.bignum-widetag
#.single-float-widetag
#.double-float-widetag
- #.simple-string-widetag
+ #.simple-base-string-widetag
+ #.simple-array-nil-widetag
#.simple-bit-vector-widetag
#.simple-array-unsigned-byte-2-widetag
#.simple-array-unsigned-byte-4-widetag
#.complex-widetag
#.simple-array-widetag
#.simple-vector-widetag
- #.complex-string-widetag
+ #.complex-base-string-widetag
+ #.complex-vector-nil-widetag
#.complex-bit-vector-widetag
#.complex-vector-widetag
#.complex-array-widetag
(defun unix-environment-cmucl-from-sbcl (sbcl)
(mapcan
(lambda (string)
- (declare (type simple-string string))
+ (declare (type simple-base-string string))
(let ((=-pos (position #\= string :test #'equal)))
(if =-pos
(list
(mapcar
(lambda (cons)
(destructuring-bind (key . val) cons
- (declare (type keyword key) (type simple-string val))
- (concatenate 'simple-string (symbol-name key) "=" val)))
+ (declare (type keyword key) (type simple-base-string val))
+ (concatenate 'simple-base-string (symbol-name key) "=" val)))
cmucl))
\f
;;;; Import wait3(2) from Unix.
The &KEY arguments have the following meanings:
:ENVIRONMENT
- a list of SIMPLE-STRINGs describing the new Unix environment (as
- in \"man environ\"). The default is to copy the environment of
+ a list of SIMPLE-BASE-STRINGs describing the new Unix environment
+ (as in \"man environ\"). The default is to copy the environment of
the current process.
:ENV
an alternative lossy representation of the new Unix environment,
"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))
;; 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))))))
\f
;;;; SUBSEQ
(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))))))))))
(: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)))
\f
;;;; STRING-INPUT-STREAM stuff
(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))
(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
(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))
(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)
(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.
(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)
(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)
(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)))
;;; 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
(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)
(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)
(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))
(declare (type index count))
(let ((result 408967240))
(declare (type fixnum result))
- (dotimes (i count)
- (declare (type index i))
- (mixf result
- (the fixnum
- (ash (char-code (aref string i)) 5))))
+ (unless (typep string '(vector nil))
+ (dotimes (i count)
+ (declare (type index i))
+ (mixf result
+ (the fixnum
+ (ash (char-code (aref string i)) 5)))))
result))
;;; test:
;;; (let ((ht (make-hash-table :test 'equal)))
;;;; When this file's top level forms are run, it precomputes the
;;;; translations for commonly used type specifiers. This stuff is
;;;; split off from the other type stuff to get around problems with
-;;;; everything needing to be loaded before everything else. This is
-;;;; the first file which really exercises the type stuff. This stuff
-;;;; is also somewhat implementation-dependent in that implementations
-;;;; may want to precompute other types which are important to them.
+;;;; everything needing to be loaded before everything else. This
+;;;; stuff is also somewhat implementation-dependent in that
+;;;; implementations may want to precompute other types which are
+;;;; important to them.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!KERNEL")
-;;; built-in classes
-(/show0 "beginning type-init.lisp")
-(dolist (x *built-in-classes*)
- (destructuring-bind (name &key (translation nil trans-p) &allow-other-keys)
- x
- (/show0 "doing class with NAME=..")
- (/primitive-print (symbol-name name))
- (when trans-p
- (/show0 "in TRANS-P case")
- (let ((classoid (classoid-cell-classoid (find-classoid-cell name)))
- (type (specifier-type translation)))
- (setf (built-in-classoid-translation classoid) type)
- (setf (info :type :builtin name) type)))))
-
;;; numeric types
(/show0 "precomputing numeric types")
(precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000)
(def-full-data-vector-frobs simple-vector *
descriptor-reg any-reg null zero)
- (def-partial-data-vector-frobs simple-string base-char :byte nil
+ (def-partial-data-vector-frobs simple-base-string base-char :byte nil
base-char-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
;;; 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. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
- ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
- (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)
(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
(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
(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
(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
;; 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)))
--- /dev/null
+(in-package "SB!C")
+
+(!begin-collecting-cold-init-forms)
+
+(!cold-init-forms
+ (map 'nil
+ (lambda (saetp)
+ (setf (sb!vm:saetp-ctype saetp)
+ (specifier-type (sb!vm:saetp-specifier saetp))))
+ sb!vm:*specialized-array-element-type-properties*))
+
+(!defun-from-collected-cold-init-forms !fixup-type-cold-init)
\ No newline at end of file
(: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
&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
#!+long-float complex-long-float
simple-array
- simple-string
+ simple-array-nil
+ simple-base-string
simple-bit-vector
simple-vector
- simple-array-nil
simple-array-unsigned-byte-2
simple-array-unsigned-byte-4
simple-array-unsigned-byte-8
simple-array-complex-single-float
simple-array-complex-double-float
#!+long-float simple-array-complex-long-float
- complex-string
+ complex-base-string
+ complex-vector-nil
complex-bit-vector
complex-vector
complex-array
(des (allocate-vector-object gspace
sb!vm:n-byte-bits
(1+ length)
- sb!vm:simple-string-widetag))
+ sb!vm:simple-base-string-widetag))
(bytes (gspace-bytes gspace))
(offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
(descriptor-byte-offset des))))
(eval-when (:compile-toplevel :execute)
(def!macro define-internal-errors (&rest errors)
(let ((info (mapcar (lambda (x)
- ;; FIXME: We shouldn't need placeholder
- ;; NIL entries any more now that we
- ;; pass our magic numbers cleanly
- ;; through sbcl.h.
- (if x
- (cons (symbolicate (first x) "-ERROR")
- (second x))
- '(nil . "unused")))
+ (cons (symbolicate (first x) "-ERROR")
+ (second x)))
errors)))
`(progn
(setf sb!c:*backend-internal-errors*
"Object is not of type LONG-FLOAT.")
(object-not-simple-string
"Object is not of type SIMPLE-STRING.")
- (object-not-simple-bit-vector
- "Object is not of type SIMPLE-BIT-VECTOR.")
- (object-not-simple-vector
- "Object is not of type SIMPLE-VECTOR.")
(object-not-fixnum
"Object is not of type FIXNUM.")
(object-not-vector
"Object is not of type VECTOR.")
(object-not-string
"Object is not of type STRING.")
+ (object-not-base-string
+ "Object is not of type BASE-STRING.")
(object-not-bit-vector
"Object is not of type BIT-VECTOR.")
(object-not-array
"Object is not of type (SIGNED-BYTE 32).")
(object-not-unsigned-byte-32
"Object is not of type (UNSIGNED-BYTE 32).")
- (object-not-simple-array-nil
- "Object is not of type (SIMPLE-ARRAY NIL (*)).")
- (object-not-simple-array-unsigned-byte-2
- "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*)).")
- (object-not-simple-array-unsigned-byte-4
- "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*)).")
- (object-not-simple-array-unsigned-byte-8
- "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).")
- (object-not-simple-array-unsigned-byte-16
- "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*)).")
- (object-not-simple-array-unsigned-byte-32
- "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)).")
- (object-not-simple-array-signed-byte-8
- "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 8) (*)).")
- (object-not-simple-array-signed-byte-16
- "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 16) (*)).")
- (object-not-simple-array-signed-byte-30
- "Object is not of type (SIMPLE-ARRAY FIXNUM (*)).")
- (object-not-simple-array-signed-byte-32
- "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 32) (*)).")
- (object-not-simple-array-single-float
- "Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*)).")
- (object-not-simple-array-double-float
- "Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*)).")
- #!+long-float
- (object-not-simple-array-long-float
- "Object is not of type (SIMPLE-ARRAY LONG-FLOAT (*)).")
- (object-not-simple-array-complex-single-float
- "Object is not of type (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)).")
- (object-not-simple-array-complex-double-float
- "Object is not of type (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)).")
- #!+long-float
- (object-not-simple-array-complex-long-float
- "Object is not of type (SIMPLE-ARRAY (COMPLEX LONG-FLOAT) (*)).")
(object-not-complex
"Object is not of type COMPLEX.")
(object-not-complex-rational
(layout-invalid
"Object layout is invalid. (indicates obsolete instance)")
(object-not-complex-vector
- "Object is not a complex (non-SIMPLE-ARRAY) vector."))
+ "Object is not a complex (non-SIMPLE-ARRAY) vector.")
+ .
+ #.(map 'list
+ (lambda (saetp)
+ (list
+ (symbolicate "OBJECT-NOT-" (sb!vm:saetp-primitive-type-name saetp))
+ (format nil "Object is not of type ~A."
+ (specifier-type
+ `(simple-array ,(sb!vm:saetp-specifier saetp) (*))))))
+ sb!vm:*specialized-array-element-type-properties*))
+
object-not-long-float-error
(long-float-widetag))
-(!define-type-vops simple-string-p check-simple-string simple-string
+(!define-type-vops simple-string-p check-simple-string nil
object-not-simple-string-error
- (simple-string-widetag))
-
-(!define-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
- object-not-simple-bit-vector-error
- (simple-bit-vector-widetag))
-
-(!define-type-vops simple-vector-p check-simple-vector simple-vector
- object-not-simple-vector-error
- (simple-vector-widetag))
-
-(!define-type-vops simple-array-nil-p
- check-simple-array-nil
- simple-array-nil
- object-not-simple-array-nil-error
- (simple-array-nil-widetag))
-
-(!define-type-vops simple-array-unsigned-byte-2-p
- check-simple-array-unsigned-byte-2
- simple-array-unsigned-byte-2
- object-not-simple-array-unsigned-byte-2-error
- (simple-array-unsigned-byte-2-widetag))
-
-(!define-type-vops simple-array-unsigned-byte-4-p
- check-simple-array-unsigned-byte-4
- simple-array-unsigned-byte-4
- object-not-simple-array-unsigned-byte-4-error
- (simple-array-unsigned-byte-4-widetag))
-
-(!define-type-vops simple-array-unsigned-byte-8-p
- check-simple-array-unsigned-byte-8
- simple-array-unsigned-byte-8
- object-not-simple-array-unsigned-byte-8-error
- (simple-array-unsigned-byte-8-widetag))
-
-(!define-type-vops simple-array-unsigned-byte-16-p
- check-simple-array-unsigned-byte-16
- simple-array-unsigned-byte-16
- object-not-simple-array-unsigned-byte-16-error
- (simple-array-unsigned-byte-16-widetag))
-
-(!define-type-vops simple-array-unsigned-byte-32-p
- check-simple-array-unsigned-byte-32
- simple-array-unsigned-byte-32
- object-not-simple-array-unsigned-byte-32-error
- (simple-array-unsigned-byte-32-widetag))
-
-(!define-type-vops simple-array-signed-byte-8-p
- check-simple-array-signed-byte-8
- simple-array-signed-byte-8
- object-not-simple-array-signed-byte-8-error
- (simple-array-signed-byte-8-widetag))
-
-(!define-type-vops simple-array-signed-byte-16-p
- check-simple-array-signed-byte-16
- simple-array-signed-byte-16
- object-not-simple-array-signed-byte-16-error
- (simple-array-signed-byte-16-widetag))
-
-(!define-type-vops simple-array-signed-byte-30-p
- check-simple-array-signed-byte-30
- simple-array-signed-byte-30
- object-not-simple-array-signed-byte-30-error
- (simple-array-signed-byte-30-widetag))
-
-(!define-type-vops simple-array-signed-byte-32-p
- check-simple-array-signed-byte-32
- simple-array-signed-byte-32
- object-not-simple-array-signed-byte-32-error
- (simple-array-signed-byte-32-widetag))
-
-(!define-type-vops simple-array-single-float-p check-simple-array-single-float
- simple-array-single-float
- object-not-simple-array-single-float-error
- (simple-array-single-float-widetag))
-
-(!define-type-vops simple-array-double-float-p check-simple-array-double-float
- simple-array-double-float
- object-not-simple-array-double-float-error
- (simple-array-double-float-widetag))
-
-#!+long-float
-(!define-type-vops simple-array-long-float-p check-simple-array-long-float
- simple-array-long-float
- object-not-simple-array-long-float-error
- (simple-array-long-float-widetag))
-
-(!define-type-vops simple-array-complex-single-float-p
- check-simple-array-complex-single-float
- simple-array-complex-single-float
- object-not-simple-array-complex-single-float-error
- (simple-array-complex-single-float-widetag))
-
-(!define-type-vops simple-array-complex-double-float-p
- check-simple-array-complex-double-float
- simple-array-complex-double-float
- object-not-simple-array-complex-double-float-error
- (simple-array-complex-double-float-widetag))
-
-#!+long-float
-(!define-type-vops simple-array-complex-long-float-p
- check-simple-array-complex-long-float
- simple-array-complex-long-float
- object-not-simple-array-complex-long-float-error
- (simple-array-complex-long-float-widetag))
+ (simple-base-string-widetag simple-array-nil-widetag))
+
+(macrolet
+ ((define-simple-array-type-vops ()
+ `(progn
+ ,@(map 'list
+ (lambda (saetp)
+ (let ((primtype (saetp-primitive-type-name saetp)))
+ `(!define-type-vops
+ ,(symbolicate primtype "-P")
+ ,(symbolicate "CHECK-" primtype)
+ ,primtype
+ ,(symbolicate "OBJECT-NOT-" primtype "-ERROR")
+ (,(saetp-typecode saetp)))))
+ *specialized-array-element-type-properties*))))
+ (define-simple-array-type-vops))
(!define-type-vops base-char-p check-base-char base-char
object-not-base-char-error
(funcallable-instance-header-widetag))
(!define-type-vops array-header-p nil nil nil
- (simple-array-widetag complex-string-widetag complex-bit-vector-widetag
- complex-vector-widetag complex-array-widetag))
+ (simple-array-widetag complex-base-string-widetag complex-bit-vector-widetag
+ complex-vector-widetag complex-array-widetag complex-vector-nil-widetag))
(!define-type-vops stringp check-string nil object-not-string-error
- (simple-string-widetag complex-string-widetag))
+ (simple-base-string-widetag complex-base-string-widetag
+ simple-array-nil-widetag complex-vector-nil-widetag))
+
+(!define-type-vops base-string-p check-base-string nil object-not-base-string-error
+ (simple-base-string-widetag complex-base-string-widetag))
(!define-type-vops bit-vector-p check-bit-vector nil
object-not-bit-vector-error
(simple-bit-vector-widetag complex-bit-vector-widetag))
+(!define-type-vops vector-nil-p check-vector-nil nil
+ object-not-vector-nil-error
+ (simple-array-nil-widetag complex-vector-nil-widetag))
+
(!define-type-vops vectorp check-vector nil object-not-vector-error
- (simple-string-widetag
- simple-array-nil-widetag
- simple-bit-vector-widetag
- simple-vector-widetag
- simple-array-unsigned-byte-2-widetag
- simple-array-unsigned-byte-4-widetag
- simple-array-unsigned-byte-8-widetag
- simple-array-unsigned-byte-16-widetag
- simple-array-unsigned-byte-32-widetag
- simple-array-signed-byte-8-widetag
- simple-array-signed-byte-16-widetag
- simple-array-signed-byte-30-widetag
- simple-array-signed-byte-32-widetag
- simple-array-single-float-widetag
- simple-array-double-float-widetag
- #!+long-float simple-array-long-float-widetag
- simple-array-complex-single-float-widetag
- simple-array-complex-double-float-widetag
- #!+long-float simple-array-complex-long-float-widetag
- complex-string-widetag
- complex-bit-vector-widetag
- complex-vector-widetag))
+ (complex-vector-widetag .
+ #.(append
+ (map 'list
+ #'saetp-typecode
+ *specialized-array-element-type-properties*)
+ (mapcan (lambda (saetp)
+ (when (saetp-complex-typecode saetp)
+ (list (saetp-complex-typecode saetp))))
+ (coerce *specialized-array-element-type-properties* 'list)))))
;;; Note that this "type VOP" is sort of an oddball; it doesn't so
;;; much test for a Lisp-level type as just expose a low-level type
(!define-type-vops simple-array-p check-simple-array nil
object-not-simple-array-error
- (simple-array-widetag
- simple-string-widetag
- simple-array-nil-widetag
- simple-bit-vector-widetag
- simple-vector-widetag
- simple-array-unsigned-byte-2-widetag
- simple-array-unsigned-byte-4-widetag
- simple-array-unsigned-byte-8-widetag
- simple-array-unsigned-byte-16-widetag
- simple-array-unsigned-byte-32-widetag
- simple-array-signed-byte-8-widetag
- simple-array-signed-byte-16-widetag
- simple-array-signed-byte-30-widetag
- simple-array-signed-byte-32-widetag
- simple-array-single-float-widetag
- simple-array-double-float-widetag
- #!+long-float simple-array-long-float-widetag
- simple-array-complex-single-float-widetag
- simple-array-complex-double-float-widetag
- #!+long-float simple-array-complex-long-float-widetag))
+ (simple-array-widetag .
+ #.(map 'list
+ #'saetp-typecode
+ *specialized-array-element-type-properties*)))
(!define-type-vops arrayp check-array nil object-not-array-error
(simple-array-widetag
- simple-string-widetag
- simple-array-nil-widetag
- simple-bit-vector-widetag
- simple-vector-widetag
- simple-array-unsigned-byte-2-widetag
- simple-array-unsigned-byte-4-widetag
- simple-array-unsigned-byte-8-widetag
- simple-array-unsigned-byte-16-widetag
- simple-array-unsigned-byte-32-widetag
- simple-array-signed-byte-8-widetag
- simple-array-signed-byte-16-widetag
- simple-array-signed-byte-30-widetag
- simple-array-signed-byte-32-widetag
- simple-array-single-float-widetag
- simple-array-double-float-widetag
- #!+long-float simple-array-long-float-widetag
- simple-array-complex-single-float-widetag
- simple-array-complex-double-float-widetag
- #!+long-float simple-array-complex-long-float-widetag
- complex-string-widetag
- complex-bit-vector-widetag
- complex-vector-widetag
- complex-array-widetag))
+ complex-array-widetag
+ complex-vector-widetag .
+ #.(append
+ (map 'list
+ #'saetp-typecode
+ *specialized-array-element-type-properties*)
+ (mapcan (lambda (saetp)
+ (when (saetp-complex-typecode saetp)
+ (list (saetp-complex-typecode saetp))))
+ (coerce *specialized-array-element-type-properties* 'list)))))
(!define-type-vops numberp check-number nil object-not-number-error
(even-fixnum-lowtag
;;; primitive other-pointer array types
(/show0 "primtype.lisp 96")
-(!def-primitive-type simple-array-nil (descriptor-reg)
- :type (simple-array nil (*)))
-(!def-primitive-type simple-string (descriptor-reg)
- :type simple-base-string)
-(!def-primitive-type simple-bit-vector (descriptor-reg))
-(!def-primitive-type simple-vector (descriptor-reg))
-(!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
- :type (simple-array (unsigned-byte 2) (*)))
-(!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
- :type (simple-array (unsigned-byte 4) (*)))
-(!def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
- :type (simple-array (unsigned-byte 8) (*)))
-(!def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
- :type (simple-array (unsigned-byte 16) (*)))
-(!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
- :type (simple-array (unsigned-byte 32) (*)))
-(!def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
- :type (simple-array (signed-byte 8) (*)))
-(!def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
- :type (simple-array (signed-byte 16) (*)))
-(!def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
- :type (simple-array (signed-byte 30) (*)))
-(!def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
- :type (simple-array (signed-byte 32) (*)))
-(!def-primitive-type simple-array-single-float (descriptor-reg)
- :type (simple-array single-float (*)))
-(!def-primitive-type simple-array-double-float (descriptor-reg)
- :type (simple-array double-float (*)))
-#!+long-float
-(!def-primitive-type simple-array-long-float (descriptor-reg)
- :type (simple-array long-float (*)))
-(!def-primitive-type simple-array-complex-single-float (descriptor-reg)
- :type (simple-array (complex single-float) (*)))
-(!def-primitive-type simple-array-complex-double-float (descriptor-reg)
- :type (simple-array (complex double-float) (*)))
-#!+long-float
-(!def-primitive-type simple-array-complex-long-float (descriptor-reg)
- :type (simple-array (complex long-float) (*)))
-
+(macrolet ((define-simple-array-primitive-types ()
+ `(progn
+ ,@(map 'list
+ (lambda (saetp)
+ `(!def-primitive-type
+ ,(saetp-primitive-type-name saetp)
+ (descriptor-reg)
+ :type (simple-array ,(saetp-specifier saetp) (*))))
+ *specialized-array-element-type-properties*))))
+ (define-simple-array-primitive-types))
;;; Note: The complex array types are not included, 'cause it is
;;; pointless to restrict VOPs to them.
(t
*backend-t-primitive-type*))))
-(defvar *simple-array-primitive-types*
- '((nil . simple-array-nil)
- (base-char . simple-string)
- (bit . simple-bit-vector)
- ((unsigned-byte 2) . simple-array-unsigned-byte-2)
- ((unsigned-byte 4) . simple-array-unsigned-byte-4)
- ((unsigned-byte 8) . simple-array-unsigned-byte-8)
- ((unsigned-byte 16) . simple-array-unsigned-byte-16)
- ((unsigned-byte 32) . simple-array-unsigned-byte-32)
- ((signed-byte 8) . simple-array-signed-byte-8)
- ((signed-byte 16) . simple-array-signed-byte-16)
- (fixnum . simple-array-signed-byte-30)
- ((signed-byte 32) . simple-array-signed-byte-32)
- (single-float . simple-array-single-float)
- (double-float . simple-array-double-float)
- #!+long-float (long-float . simple-array-long-float)
- ((complex single-float) . simple-array-complex-single-float)
- ((complex double-float) . simple-array-complex-double-float)
- #!+long-float
- ((complex long-float) . simple-array-complex-long-float)
- (t . simple-vector))
- #!+sb-doc
- "An a-list for mapping simple array element types to their
- corresponding primitive types.")
-
;;; Return the primitive type corresponding to a type descriptor
;;; structure. The second value is true when the primitive type is
;;; exactly equivalent to the argument Lisp type.
(let* ((dims (array-type-dimensions type))
(etype (array-type-specialized-element-type type))
(type-spec (type-specifier etype))
+ ;; FIXME: We're _WHAT_? Testing for type equality
+ ;; with a specifier and #'EQUAL? *BOGGLE*. --
+ ;; CSR, 2003-06-24
(ptype (cdr (assoc type-spec *simple-array-primitive-types*
:test #'equal))))
(if (and (consp dims) (null (rest dims)) ptype)
--- /dev/null
+;;;; this file centralizes information about the array types
+;;;; implemented by the system, where previously such information was
+;;;; spread over several files.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(defstruct (specialized-array-element-type-properties
+ (:conc-name saetp-)
+ (:constructor
+ !make-saetp
+ (specifier
+ initial-element-default
+ n-bits
+ primitive-type-name
+ &key (n-pad-elements 0) complex-typecode (importance 0)
+ &aux (typecode
+ (eval (symbolicate primitive-type-name "-WIDETAG")))))
+ (:copier nil))
+ ;; the element specifier, e.g. BASE-CHAR or (UNSIGNED-BYTE 4)
+ (specifier (missing-arg) :type type-specifier :read-only t)
+ ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
+ ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
+ (ctype nil :type (or ctype null))
+ ;; 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 (aka "widetag")
+ (typecode (missing-arg) :type index :read-only t)
+ ;; if an integer, a typecode corresponding to a complex vector
+ ;; specialized on this element type.
+ (complex-typecode nil :type (or index null) :read-only t)
+ ;; the name of the primitive type of data vectors specialized on
+ ;; this type
+ (primitive-type-name (missing-arg) :type symbol :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)
+ ;; the relative importance of this array type. Used for determining
+ ;; the order of the TYPECASE in HAIRY-DATA-VECTOR-{REF,SET}. High
+ ;; positive numbers are near the top; low negative numbers near the
+ ;; bottom.
+ (importance (missing-arg) :type fixnum :read-only t))
+
+(defparameter *specialized-array-element-type-properties*
+ (map 'simple-vector
+ (lambda (args)
+ (apply #'!make-saetp args))
+ `(;; 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 simple-array-nil
+ :complex-typecode #.sb!vm:complex-vector-nil-widetag
+ :importance 0)
+ (base-char ,(code-char 0) 8 simple-base-string
+ ;; (SIMPLE-BASE-STRINGs are stored with an extra
+ ;; trailing #\NULL for convenience in calling out
+ ;; to C.)
+ :n-pad-elements 1
+ :complex-typecode #.sb!vm:complex-base-string-widetag
+ :importance 17)
+ (single-float 0.0f0 32 simple-array-single-float
+ :importance 6)
+ (double-float 0.0d0 64 simple-array-double-float
+ :importance 5)
+ #!+long-float
+ (long-float 0.0l0 #!+x86 96 #!+sparc 128 simple-array-long-float
+ :importance 4)
+ (bit 0 1 simple-bit-vector
+ :complex-typecode #.sb!vm:complex-bit-vector-widetag
+ :importance 16)
+ ;; 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 simple-array-unsigned-byte-2
+ :importance 15)
+ ((unsigned-byte 4) 0 4 simple-array-unsigned-byte-4
+ :importance 14)
+ ((unsigned-byte 8) 0 8 simple-array-unsigned-byte-8
+ :importance 13)
+ ((unsigned-byte 16) 0 16 simple-array-unsigned-byte-16
+ :importance 12)
+ ((unsigned-byte 32) 0 32 simple-array-unsigned-byte-32
+ :importance 11)
+ ((signed-byte 8) 0 8 simple-array-signed-byte-8
+ :importance 10)
+ ((signed-byte 16) 0 16 simple-array-signed-byte-16
+ :importance 9)
+ ;; KLUDGE: See the comment in PRIMITIVE-TYPE-AUX,
+ ;; compiler/generic/primtype.lisp, for why this is FIXNUM and
+ ;; not (SIGNED-BYTE 30)
+ (fixnum 0 32 simple-array-signed-byte-30
+ :importance 8)
+ ((signed-byte 32) 0 32 simple-array-signed-byte-32
+ :importance 7)
+ ((complex single-float) #C(0.0f0 0.0f0) 64
+ simple-array-complex-single-float
+ :importance 3)
+ ((complex double-float) #C(0.0d0 0.0d0) 128
+ simple-array-complex-double-float
+ :importance 2)
+ #!+long-float
+ ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
+ simple-array-complex-long-float
+ :importance 1)
+ (t 0 32 simple-vector :importance 18))))
+
+(defvar sb!kernel::*specialized-array-element-types*
+ (map 'list
+ #'saetp-specifier
+ *specialized-array-element-type-properties*))
+
+#-sb-xc-host
+(defun !vm-type-cold-init ()
+ (setf sb!kernel::*specialized-array-element-types*
+ '#.sb!kernel::*specialized-array-element-types*))
+
+(defvar *simple-array-primitive-types*
+ (map 'list
+ (lambda (saetp)
+ (cons (saetp-specifier saetp)
+ (saetp-primitive-type-name saetp)))
+ *specialized-array-element-type-properties*)
+ #!+sb-doc
+ "An alist for mapping simple array element types to their
+corresponding primitive types.")
complex-double-float-p #!+long-float complex-long-float-p
complex-vector-p
base-char-p %standard-char-p %instancep
+ base-string-p simple-base-string-p
array-header-p
- simple-array-p simple-array-nil-p
+ simple-array-p simple-array-nil-p vector-nil-p
simple-array-unsigned-byte-2-p
simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
\f
;;;; 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))
(%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)
*
(in-package "SB!KERNEL")
-(/show0 "vm-type.lisp 17")
-
-(!begin-collecting-cold-init-forms)
-\f
;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
(deftype sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
\f
;;;; 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*)
;; 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))
'sb!c:check-fun)
(t
nil)))
-\f
-(!defun-from-collected-cold-init-forms !vm-type-cold-init)
-
-(/show0 "vm-type.lisp end of file")
;;; These type predicates are used to implement simple cases of TYPEP.
;;; They shouldn't be used explicitly.
(define-type-predicate base-char-p base-char)
+(define-type-predicate base-string-p base-string)
(define-type-predicate bignump bignum)
(define-type-predicate complex-double-float-p (complex double-float))
(define-type-predicate complex-single-float-p (complex single-float))
#!+long-float
(define-type-predicate simple-array-complex-long-float-p
(simple-array (complex long-float) (*)))
+(define-type-predicate simple-base-string-p simple-base-string)
(define-type-predicate system-area-pointer-p system-area-pointer)
(define-type-predicate unsigned-byte-32-p (unsigned-byte 32))
(define-type-predicate signed-byte-32-p (signed-byte 32))
(define-type-predicate vector-t-p (vector t))
+(define-type-predicate vector-nil-p (vector nil))
(define-type-predicate weak-pointer-p weak-pointer)
(define-type-predicate code-component-p code-component)
(define-type-predicate lra-p lra)
(def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
- (def-partial-data-vector-frobs simple-string base-char :byte nil base-char-reg)
+ (def-partial-data-vector-frobs simple-base-string base-char :byte nil base-char-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
:byte nil unsigned-reg signed-reg)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(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))
(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")
;;; type descriptor for the Lisp type that is equivalent to this type.
(defmacro !def-primitive-type (name scs &key (type name))
(declare (type symbol name) (type list scs))
- (let ((scns (mapcar #'meta-sc-number-or-lose scs))
- (ctype-form `(specifier-type ',type)))
+ (let ((scns (mapcar #'meta-sc-number-or-lose scs)))
`(progn
(/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
(/primitive-print ,(symbol-name name))
(setf (gethash ',name *backend-meta-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,ctype-form)))
- ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
- (n-type ctype-form))
+ :specifier ',type)))
+ ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*)))
`(progn
;; If the PRIMITIVE-TYPE structure already exists, we
;; destructively modify it so that existing references in
(cond (,n-old
(/show0 "in ,N-OLD clause of COND")
(setf (primitive-type-scs ,n-old) ',scns)
- (setf (primitive-type-type ,n-old) ,n-type))
+ (setf (primitive-type-specifier ,n-old) ',type))
(t
(/show0 "in T clause of COND")
(setf (gethash ',name *backend-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,n-type))))
+ :specifier ',type))))
(/show0 "done with !DEF-PRIMITIVE-TYPE")
',name)))))
(def-full-data-vector-frobs simple-vector *
descriptor-reg any-reg null zero)
- (def-partial-data-vector-frobs simple-string base-char
+ (def-partial-data-vector-frobs simple-base-string base-char
:byte nil base-char-reg)
(def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
`(progn
- (define-vop (,(intern (concatenate 'simple-string
- "DATA-VECTOR-REF/"
- (string type)))
- ,(intern (concatenate 'simple-string
- (string variant)
- "-REF")))
+ (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
+ ,(symbolicate (string variant) "-REF"))
(:note "inline array access")
(:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
(:translate data-vector-ref)
(:arg-types ,type positive-fixnum)
(:results (value :scs ,scs))
(:result-types ,element-type))
- (define-vop (,(intern (concatenate 'simple-string
- "DATA-VECTOR-SET/"
- (string type)))
- ,(intern (concatenate 'simple-string
- (string variant)
- "-SET")))
+ (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
+ ,(symbolicate (string variant) "-SET"))
(:note "inline array store")
(:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
(:translate data-vector-set)
(value :scs ,scs))
(:results (result :scs ,scs))
(:result-types ,element-type)))))
- (def-data-vector-frobs simple-string byte-index
+ (def-data-vector-frobs simple-base-string byte-index
base-char base-char-reg)
(def-data-vector-frobs simple-vector word-index
* descriptor-reg any-reg)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
;;; Return a form that tests the free variables STRING1 and STRING2
;;; for the ordering relationship specified by LESSP and EQUALP. The
;;; start and end are also gotten from the environment. Both strings
-;;; must be SIMPLE-STRINGs.
+;;; must be SIMPLE-BASE-STRINGs.
(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-string simple-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
(macrolet ((def (name result-fun)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-string simple-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(,',result-fun
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
end1 end2)
- (simple-string simple-string &rest t)
+ (simple-base-string simple-base-string &rest t)
*
;; FIXME: consider replacing this policy test
;; with some tests for the STARTx and ENDx
;;;
;;; FIXME: currently KLUDGEed because of bug 188
(deftransform concatenate ((rtype &rest sequences)
- (t &rest simple-string)
- simple-string
+ (t &rest (or simple-base-string
+ (simple-array nil (*))))
+ simple-base-string
:policy (< safety 3))
(loop for rest-seqs on sequences
for n-seq = (gensym "N-SEQ")
collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
collect n-length into all-lengths
collect next-start into starts
- collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
- res ,start ,n-length)
+ collect `(if (and (typep ,n-seq '(simple-array nil (*)))
+ (> ,n-length 0))
+ (error 'nil-array-accessed-error)
+ (bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res ,start ,n-length))
into forms
collect `(setq ,next-start (+ ,start ,n-length)) into forms
finally
(macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
`(progn
- (define-vop (,(intern (concatenate 'simple-string
- "DATA-VECTOR-REF/"
- (string type)))
- ,(intern (concatenate 'simple-string
- (string variant)
- "-REF")))
+ (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
+ ,(symbolicate (string variant) "-REF"))
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-ref)
(:arg-types ,type positive-fixnum)
(:results (value :scs ,scs))
(:result-types ,element-type))
- (define-vop (,(intern (concatenate 'simple-string
- "DATA-VECTOR-SET/"
- (string type)))
- ,(intern (concatenate 'simple-string
- (string variant)
- "-SET")))
+ (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
+ ,(symbolicate (string variant) "-SET"))
(:note "inline array store")
(:variant vector-data-offset other-pointer-lowtag)
(:translate data-vector-set)
(:results (result :scs ,scs))
(:result-types ,element-type)))))
- (def-data-vector-frobs simple-string byte-index
+ (def-data-vector-frobs simple-base-string byte-index
base-char base-char-reg)
(def-data-vector-frobs simple-vector word-index
* descriptor-reg any-reg)
(def-data-vector-frobs simple-array-signed-byte-30 word-index
tagged-num any-reg)
(def-data-vector-frobs simple-array-signed-byte-32 word-index
- signed-num signed-reg)
-) ; MACROLET
-;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
-;;; and 4-bit vectors.
-;;;
+ signed-num signed-reg))
+;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit,
+;;; and 4-bit vectors.
(macrolet ((def-small-data-vector-frobs (type bits)
(let* ((elements-per-word (floor n-word-bits bits))
(bit-shift (1- (integer-length elements-per-word))))
`(progn
- (define-vop (,(symbolicate 'data-vector-ref/ type))
+ (define-vop (,(symbolicate "DATA-VECTOR-REF/" type))
(:note "inline array access")
(:translate data-vector-ref)
(:policy :fast-safe)
(inst srl result temp)
(inst and result ,(1- (ash 1 bits)))
(inst sll value result 2)))
- (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+ (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type))
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(inst srl result (* extra ,bits)))
(unless (= extra ,(1- elements-per-word))
(inst and result ,(1- (ash 1 bits)))))))
- (define-vop (,(symbolicate 'data-vector-set/ type))
+ (define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
(:note "inline array store")
(:translate data-vector-set)
(:policy :fast-safe)
(inst li result (tn-value value)))
(t
(move result value)))))
- (define-vop (,(symbolicate 'data-vector-set-c/ type))
+ (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" type))
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(def-small-data-vector-frobs simple-bit-vector 1)
(def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
- (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)
-
-) ; MACROLET
-
+ (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
;;; And the float variants.
-;;;
-
(define-vop (data-vector-ref/simple-array-single-float)
(:note "inline array access")
(:translate data-vector-ref)
(define-vop (set-vector-subtype set-header-data))
\f
-;;;
+;;; XXX FIXME: Don't we have these above, in DEF-DATA-VECTOR-FROBS?
(define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
(:note "inline array access")
(:variant vector-data-offset other-pointer-lowtag)
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(- val (ash 1 13))
val))
-;;; Oh, come on, this is ridiculous. I'm not going to solve
-;;; bootstrapping issues for a disassembly note. Does this make me
-;;; lazy? Christophe, 2001-09-02. FIXME
-#+nil
-(macrolet
- ((frob (&rest names)
- (let ((results (mapcar (lambda (n)
- (let ((nn (intern (concatenate 'string (string n)
- "-TYPE"))))
- `(,(eval nn) ,nn)))
- names)))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (def!constant header-word-type-alist
- ',results)))))
- ;; This is the same list as in objdefs.
- (frob bignum
- ratio
- single-float
- double-float
- #!+long-float long-float
- complex
- complex-single-float
- complex-double-float
- #!+long-float complex-long-float
-
- simple-array
- simple-string
- simple-bit-vector
- simple-vector
- simple-array-unsigned-byte-2
- simple-array-unsigned-byte-4
- simple-array-unsigned-byte-8
- simple-array-unsigned-byte-16
- simple-array-unsigned-byte-32
- simple-array-signed-byte-8
- simple-array-signed-byte-16
- simple-array-signed-byte-30
- simple-array-signed-byte-32
- simple-array-single-float
- simple-array-double-float
- #!+long-float simple-array-long-float
- simple-array-complex-single-float
- simple-array-complex-double-float
- #!+long-float simple-array-complex-long-float
- complex-string
- complex-bit-vector
- complex-vector
- complex-array
-
- code-header
- function-header
- closure-header
- funcallable-instance-header
- byte-code-function
- byte-code-closure
- closure-function-header
- #!-gengc return-pc-header
- #!+gengc forwarding-pointer
- value-cell-header
- symbol-header
- base-char
- sap
- unbound-marker
- weak-pointer
- instance-header
- fdefn
- #!+(or gengc gencgc) scavenger-hook))
-
;; Look at the current instruction and see if we can't add some notes
;; about what's happening.
#'<=
:key #'template-cost))
\f
-;;; Return a function type specifier describing Template's type computed
+;;; Return a function type specifier describing TEMPLATE's type computed
;;; from the operand type restrictions.
(defun template-type-specifier (template)
(declare (type template template))
(if (eq x '*)
t
(ecase (first x)
- (:or `(or ,@(mapcar (lambda (type)
- (type-specifier
- (primitive-type-type
- type)))
+ (:or `(or ,@(mapcar #'primitive-type-specifier
(rest x))))
(:constant `(constant-arg ,(third x)))))))
`(,@(mapcar #'frob types)
(scs nil :type list)
;; the Lisp type equivalent to this type. If this type could never be
;; returned by PRIMITIVE-TYPE, then this is the NIL (or empty) type
- (type (missing-arg) :type ctype)
+ (specifier (missing-arg) :type type-specifier)
;; the template used to check that an object is of this type. This is a
;; template of one argument and one result, both of primitive-type T. If
;; the argument is of the correct type, then it is delivered into the
;;; simple-string
-(define-vop (data-vector-ref/simple-string)
+(define-vop (data-vector-ref/simple-base-string)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg)))
- (:arg-types simple-string positive-fixnum)
+ (:arg-types simple-base-string positive-fixnum)
(:temporary (:sc unsigned-reg ; byte-reg
:offset eax-offset ; al-offset
:target value
other-pointer-lowtag)))
(move value al-tn)))
-(define-vop (data-vector-ref-c/simple-string)
+(define-vop (data-vector-ref-c/simple-base-string)
(:translate data-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:info index)
- (:arg-types simple-string (:constant (signed-byte 30)))
+ (:arg-types simple-base-string (:constant (signed-byte 30)))
(:temporary (:sc unsigned-reg :offset eax-offset :target value
:from (:eval 0) :to (:result 0))
eax)
other-pointer-lowtag)))
(move value al-tn)))
-(define-vop (data-vector-set/simple-string)
+(define-vop (data-vector-set/simple-base-string)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
(index :scs (unsigned-reg) :to (:eval 0))
(value :scs (base-char-reg)))
- (:arg-types simple-string positive-fixnum base-char)
+ (:arg-types simple-base-string positive-fixnum base-char)
(:results (result :scs (base-char-reg)))
(:result-types base-char)
(:generator 5
value)
(move result value)))
-(define-vop (data-vector-set/simple-string-c)
+(define-vop (data-vector-set/simple-base-string-c)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:eval 0))
(value :scs (base-char-reg)))
(:info index)
- (:arg-types simple-string (:constant (signed-byte 30)) base-char)
+ (:arg-types simple-base-string (:constant (signed-byte 30)) base-char)
(:results (result :scs (base-char-reg)))
(:result-types base-char)
(:generator 4
(:translate foreign-symbol-address)
(:policy :fast-safe)
(:args)
- (:arg-types (:constant simple-string))
+ (:arg-types (:constant simple-base-string))
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
;;; The loader uses this to convert alien names to the form they need in
;;; the symbol table (for example, prepending an underscore).
(defun extern-alien-name (name)
- (declare (type simple-string name))
+ (declare (type simple-base-string name))
;; OpenBSD is non-ELF, and needs a _ prefix
#!+openbsd (concatenate 'string "_" name)
;; The other (ELF) ports currently don't need any prefix
}
lispobj
-alloc_string(char *str)
+alloc_base_string(char *str)
{
int len = strlen(str);
- lispobj result = alloc_vector(SIMPLE_STRING_WIDETAG, len+1, 8);
+ lispobj result = alloc_vector(SIMPLE_BASE_STRING_WIDETAG, len+1, 8);
struct vector *vec = (struct vector *)native_pointer(result);
vec->length = make_fixnum(len);
symbol = (struct symbol *) object;
object = (lispobj *) native_pointer(symbol->name);
}
- if (widetag_of(*object) == SIMPLE_STRING_WIDETAG) {
+ if (widetag_of(*object) == SIMPLE_BASE_STRING_WIDETAG) {
struct vector *string;
string = (struct vector *) object;
#define NWORDS(x,y) (CEILING((x),(y)) / (y))
-scav_string(lispobj *where, lispobj object)
+scav_base_string(lispobj *where, lispobj object)
{
struct vector *vector;
int length, nwords;
return nwords;
}
static lispobj
-trans_string(lispobj object)
+trans_base_string(lispobj object)
{
struct vector *vector;
int length, nwords;
}
static int
-size_string(lispobj *where)
+size_base_string(lispobj *where)
{
struct vector *vector;
int length, nwords;
scavtab[COMPLEX_LONG_FLOAT_WIDETAG] = scav_unboxed;
#endif
scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed;
- scavtab[SIMPLE_STRING_WIDETAG] = scav_string;
+ scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string;
scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit;
scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil;
scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] =
scavtab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
scav_vector_complex_long_float;
#endif
- scavtab[COMPLEX_STRING_WIDETAG] = scav_boxed;
+ scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed;
+ scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed;
scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed;
scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed;
scavtab[COMPLEX_ARRAY_WIDETAG] = scav_boxed;
transother[COMPLEX_LONG_FLOAT_WIDETAG] = trans_unboxed;
#endif
transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */
- transother[SIMPLE_STRING_WIDETAG] = trans_string;
+ transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string;
transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit;
transother[SIMPLE_VECTOR_WIDETAG] = trans_vector;
transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil;
transother[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
trans_vector_complex_long_float;
#endif
- transother[COMPLEX_STRING_WIDETAG] = trans_boxed;
+ transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed;
transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed;
+ transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed;
transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed;
transother[COMPLEX_ARRAY_WIDETAG] = trans_boxed;
transother[CODE_HEADER_WIDETAG] = trans_code_header;
sizetab[COMPLEX_LONG_FLOAT_WIDETAG] = size_unboxed;
#endif
sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed;
- sizetab[SIMPLE_STRING_WIDETAG] = size_string;
+ sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string;
sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit;
sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector;
sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil;
sizetab[SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG] =
size_vector_complex_long_float;
#endif
- sizetab[COMPLEX_STRING_WIDETAG] = size_boxed;
+ sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed;
+ sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed;
sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed;
sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed;
sizetab[COMPLEX_ARRAY_WIDETAG] = size_boxed;
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
case SIMPLE_ARRAY_WIDETAG:
- case COMPLEX_STRING_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+ case COMPLEX_VECTOR_NIL_WIDETAG:
case COMPLEX_BIT_VECTOR_WIDETAG:
case COMPLEX_VECTOR_WIDETAG:
case COMPLEX_ARRAY_WIDETAG:
#ifdef LONG_FLOAT_WIDETAG
case LONG_FLOAT_WIDETAG:
#endif
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
case SIMPLE_BIT_VECTOR_WIDETAG:
case SIMPLE_ARRAY_NIL_WIDETAG:
case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
boxed = BOXED_PAGE;
break;
case BIGNUM_WIDETAG:
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
case SIMPLE_BIT_VECTOR_WIDETAG:
case SIMPLE_ARRAY_NIL_WIDETAG:
case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
case RATIO_WIDETAG:
case COMPLEX_WIDETAG:
case SIMPLE_ARRAY_WIDETAG:
- case COMPLEX_STRING_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+ case COMPLEX_VECTOR_NIL_WIDETAG:
case COMPLEX_BIT_VECTOR_WIDETAG:
case COMPLEX_VECTOR_WIDETAG:
case COMPLEX_ARRAY_WIDETAG:
#ifdef COMPLEX_LONG_FLOAT_WIDETAG
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
case SIMPLE_BIT_VECTOR_WIDETAG:
case SIMPLE_ARRAY_NIL_WIDETAG:
case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
}
break;
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
vector = (struct vector *)ptr;
putchar('"');
for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
break;
#endif
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
NEWLINE_OR_RETURN;
cptr = (char *)(ptr+1);
putchar('"');
#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
#endif
- case COMPLEX_STRING_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+ case COMPLEX_VECTOR_NIL_WIDETAG:
case COMPLEX_BIT_VECTOR_WIDETAG:
case COMPLEX_VECTOR_WIDETAG:
case COMPLEX_ARRAY_WIDETAG:
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
case SIMPLE_ARRAY_WIDETAG:
- case COMPLEX_STRING_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+ case COMPLEX_VECTOR_NIL_WIDETAG:
case COMPLEX_BIT_VECTOR_WIDETAG:
case COMPLEX_VECTOR_WIDETAG:
case COMPLEX_ARRAY_WIDETAG:
#ifdef LONG_FLOAT_WIDETAG
case LONG_FLOAT_WIDETAG:
#endif
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
case SIMPLE_BIT_VECTOR_WIDETAG:
case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
{
switch (widetag_of(header)) {
+ /* FIXME: this needs a reindent */
case BIGNUM_WIDETAG:
case SINGLE_FLOAT_WIDETAG:
case DOUBLE_FLOAT_WIDETAG:
case COMPLEX_LONG_FLOAT_WIDETAG:
#endif
case SAP_WIDETAG:
- return ptrans_unboxed(thing, header);
+ return ptrans_unboxed(thing, header);
case RATIO_WIDETAG:
case COMPLEX_WIDETAG:
case SIMPLE_ARRAY_WIDETAG:
- case COMPLEX_STRING_WIDETAG:
+ case COMPLEX_BASE_STRING_WIDETAG:
+ case COMPLEX_VECTOR_NIL_WIDETAG:
case COMPLEX_VECTOR_WIDETAG:
case COMPLEX_ARRAY_WIDETAG:
return ptrans_boxed(thing, header, constant);
case SYMBOL_HEADER_WIDETAG:
return ptrans_boxed(thing, header, 0);
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
return ptrans_vector(thing, 8, 1, 0, constant);
case SIMPLE_BIT_VECTOR_WIDETAG:
count = 1;
break;
- case SIMPLE_STRING_WIDETAG:
+ case SIMPLE_BASE_STRING_WIDETAG:
vector = (struct vector *)addr;
count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
break;
}
/* Convert a null-terminated array of null-terminated strings (e.g.
- * argv or envp) into a Lisp list of Lisp strings. */
+ * argv or envp) into a Lisp list of Lisp base-strings. */
static lispobj
-alloc_string_list(char *array_ptr[])
+alloc_base_string_list(char *array_ptr[])
{
if (*array_ptr) {
- return alloc_cons(alloc_string(*array_ptr),
- alloc_string_list(1 + array_ptr));
+ return alloc_cons(alloc_base_string(*array_ptr),
+ alloc_base_string_list(1 + array_ptr));
} else {
return NIL;
}
/* Convert remaining argv values to something that Lisp can grok. */
SHOW("setting POSIX-ARGV symbol value");
- SetSymbolValue(POSIX_ARGV, alloc_string_list(argv),0);
+ SetSymbolValue(POSIX_ARGV, alloc_base_string_list(argv),0);
/* Install a handler to pick off SIGINT until the Lisp system gets
* far enough along to install its own handler. */
if (lowtag_of(symbol->name) == OTHER_POINTER_LOWTAG) {
symbol_name = (struct vector *)native_pointer(symbol->name);
if (is_valid_lisp_addr((os_vm_address_t)symbol_name) &&
- widetag_of(symbol_name->header) == SIMPLE_STRING_WIDETAG &&
+ widetag_of(symbol_name->header) == SIMPLE_BASE_STRING_WIDETAG &&
strcmp((char *)symbol_name->data, name) == 0)
return 1;
}
(assert (string= nstring "CaT"))
(nstring-capitalize nstring)
(assert (string= nstring "Cat")))
+
+;;; (VECTOR NIL)s are strings. Tests for that and issues uncovered in
+;;; the process.
+(assert (typep (make-array 1 :element-type nil) 'string))
+(assert (not (typep (make-array 2 :element-type nil) 'base-string)))
+(assert (typep (make-string 3 :element-type nil) 'simple-string))
+(assert (not (typep (make-string 4 :element-type nil) 'simple-base-string)))
+
+(assert (subtypep (class-of (make-array 1 :element-type nil))
+ (find-class 'string)))
+(assert (subtypep (class-of (make-array 2 :element-type nil :fill-pointer 1))
+ (find-class 'string)))
+
+(assert (string= "" (make-array 0 :element-type nil)))
+(assert (string/= "a" (make-array 0 :element-type nil)))
+(assert (string= "" (make-array 5 :element-type nil :fill-pointer 0)))
+
+(assert (= (sxhash "")
+ (sxhash (make-array 0 :element-type nil))
+ (sxhash (make-array 5 :element-type nil :fill-pointer 0))
+ (sxhash (make-string 0 :element-type nil))))
+(assert (subtypep (type-of (make-array 2 :element-type nil)) 'simple-string))
+(assert (subtypep (type-of (make-array 4 :element-type nil :fill-pointer t))
+ 'string))
+
+(assert (eq (intern "") (intern (make-array 0 :element-type nil))))
+(assert (eq (intern "")
+ (intern (make-array 5 :element-type nil :fill-pointer 0))))
+
+(assert (raises-error? (make-string 5 :element-type t)))
+(assert (raises-error? (let () (make-string 5 :element-type t))))
;;; 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.1.34"
projects / sbcl.git / commitdiff