"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-TYPES" "VALUES-TYPES"
"VALUES-TYPE-START"
"VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
+ "VECTOR-NIL-P"
"VECTOR-TO-VECTOR*"
"VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
"WITH-ARRAY-DATA"
"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"
"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.
;; *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))
+ (base-char (values #.sb!vm:simple-base-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))
;; 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
(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))
;; 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-array-nil-widetag sb!vm:complex-vector-nil-widetag) nil)
+ ((sb!vm:simple-base-string-widetag sb!vm:complex-base-string-widetag) 'base-char)
((sb!vm:simple-bit-vector-widetag
sb!vm:complex-bit-vector-widetag) 'bit)
(sb!vm:simple-vector-widetag t)
: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
+ :inherits (string simple-array))
+ (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))
:format-arguments (list (car x)(car y) z)))))
(defun stringify-name (name kind)
+ (/show0 "in STRINGIFY-NAME, NAME=..")
+ (/hexstr name)
(typecase name
- (simple-string name)
- (string (coerce name 'simple-string))
+ (simple-base-string name)
+ (base-string (coerce name 'simple-base-string))
(symbol (symbol-name name))
(base-char (string name))
(t
`(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)))
:datum object
:expected-type 'simple-string))
+(deferr object-not-simple-base-string-error (object)
+ (error 'type-error
+ :datum object
+ :expected-type 'simple-base-string))
+
(deferr object-not-simple-bit-vector-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
(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
t)))))
(!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)))))
: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
"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
"Return a new sequence of all the argument sequences concatenated together
which shares no structure with the original argument sequences of the
specified OUTPUT-TYPE-SPEC."
+ (/show0 "full call to CONCATENATE, OUTPUT-TYPE-SPEC=..")
+ (/hexstr output-type-spec)
(let ((type (specifier-type output-type-spec)))
(cond
((csubtypep type (specifier-type 'list))
(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))))))))))
`(;; 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
+ (base-char ,(code-char 0) 8 ,sb!vm:simple-base-string-widetag
;; (SIMPLE-STRINGs are stored with an extra trailing
;; #\NULL for convenience in calling out to C.)
:n-pad-elements 1)
(: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))))
"Object is not of type LONG-FLOAT.")
(object-not-simple-string
"Object is not of type SIMPLE-STRING.")
+ (object-not-simple-base-string
+ "Object is not of type SIMPLE-BASE-STRING.")
(object-not-simple-bit-vector
"Object is not of type SIMPLE-BIT-VECTOR.")
(object-not-simple-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-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))
+ (simple-base-string-widetag simple-array-nil-widetag))
+
+(!define-type-vops simple-base-string-p check-simple-base-string simple-base-string
+ object-not-simple-base-string-error
+ (simple-base-string-widetag))
(!define-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
object-not-simple-bit-vector-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-base-string-widetag
simple-array-nil-widetag
simple-bit-vector-widetag
simple-vector-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-base-string-widetag
+ complex-vector-nil-widetag
complex-bit-vector-widetag
complex-vector-widetag))
(!define-type-vops simple-array-p check-simple-array nil
object-not-simple-array-error
(simple-array-widetag
- simple-string-widetag
+ simple-base-string-widetag
simple-array-nil-widetag
simple-bit-vector-widetag
simple-vector-widetag
(!define-type-vops arrayp check-array nil object-not-array-error
(simple-array-widetag
- simple-string-widetag
+ simple-base-string-widetag
simple-array-nil-widetag
simple-bit-vector-widetag
simple-vector-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-base-string-widetag
+ complex-vector-nil-widetag
complex-bit-vector-widetag
complex-vector-widetag
complex-array-widetag))
(/show0 "primtype.lisp 96")
(!def-primitive-type simple-array-nil (descriptor-reg)
:type (simple-array nil (*)))
-(!def-primitive-type simple-string (descriptor-reg)
+(!def-primitive-type simple-base-string (descriptor-reg)
:type simple-base-string)
(!def-primitive-type simple-bit-vector (descriptor-reg))
(!def-primitive-type simple-vector (descriptor-reg))
(defvar *simple-array-primitive-types*
'((nil . simple-array-nil)
- (base-char . simple-string)
+ (base-char . simple-base-string)
(bit . simple-bit-vector)
((unsigned-byte 2) . simple-array-unsigned-byte-2)
((unsigned-byte 4) . simple-array-unsigned-byte-4)
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
;;; 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)
(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")
;;; 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 simple-base-string)
+ simple-base-string
:policy (< safety 3))
(loop for rest-seqs on sequences
for n-seq = (gensym "N-SEQ")
(- 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.
;;; 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;
}
;;; 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.0.78"
+"0.8.0.78.vector-nil-string.1"
projects / sbcl.git / commitdiff