common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.8.0.78.vector-nil-string.1:

Browse source 
As noted with horror between myself and pfdietz on #lisp,
        vectors specialized on NIL are strings.

This patch implements (VECTOR NIL) as subtype of STRING with no
regressions in either our regression test suite or pfdietz' test suite.

However, this notwithstanding, there are a number of issues that need to
be resolved before this hits HEAD.  (Why would it hit HEAD, you ask?
Well, it /is/ an ANSI issue, but in this case that would probably just
merit it an entry in BUGS, were it not for the fact that a Unicode
implementation is likely to have several string representations, so most
of the issues that we're addressing here will have to be dealt with in
any case; the use of (ARRAY NIL) as a "poison pill" to investigate
string routines and the like is probably a good thing.  Note that this
is only a half-way house; while STRING is no longer the same type as
BASE-STRING, which is one portion of the Unicode battle, CHARACTER
remains equivalent to BASE-CHAR).

Brokennesses:
* STRING= and similar functions may work by accident for (VECTOR NIL 0),
  but they're unlikely to be robustly working;
* FFI and ALIEN: we need at the very least (a) to ensure that C-STRINGs
  get turned into a useful string type, not (VECTOR NIL) and (b) to
  install a conversion routine for the other direction, so that the Lisp
  string #.(make-array 0 :element-type nil) becomes the C string "";
* Filesystem access and SB-UNIX is completely unaudited.  This may be
  similar to the above issue;
* SXHASH-SIMPLE-STRING tries to access string elements, and promptly
  errors on a (VECTOR NIL) with non-zero length.  This also breaks
  TYPE-OF;
* INTERN currently takes only a BASE-STRING;
* [ probably others.  Should examine Brian Spilsbury's Unicode patch for
    some more gotchas. ]

Suboptimalities:
* 10% slowdown in self-compilation, probably mostly caused by
  CONCATENATE (not transformed away for general SIMPLE-STRINGs any more)
  and HAIRY-DATA-VECTOR-{REF,SET} (type dispatch unavoidable for the
  latter on STRING-typed objects).  We can mitigate the latter issue by,
  for STRINGlike types including (VECTOR NIL), having a vector nil type
  test branching to an array-nil-accessed error clause if true, then
  retrying the hairy-data-vector optimization;
* throughout the codebase, string and base-string have been
  interchangeably used for a number of years; we need to look at them
  all and fix them if necessary.
This commit is contained in:
Christophe Rhodes 2003-06-18 15:16:05 +00:00
parent 937a46e649
commit 902e93736a
36 changed files with 250 additions and 205 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
package-data-list.lisp-expr
View file

@ -1026,7 +1026,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
@ -1167,6 +1167,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
@ -1208,6 +1209,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
@ -1250,6 +1252,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
@ -1297,6 +1300,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"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"
@ -1913,7 +1917,8 @@ structure representations"
"COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT"
"COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-WIDETAG"
"COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER"
"COMPLEX-SIZE" "COMPLEX-STRING-WIDETAG" "COMPLEX-WIDETAG"
"COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" "COMPLEX-WIDETAG"
"COMPLEX-VECTOR-NIL-WIDETAG"
"COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT"
"CONS-SIZE" "CONSTANT-SC-NUMBER"
"CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
@ -2024,7 +2029,7 @@ structure representations"
"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"

24
src/code/array.lisp
View file

@ -100,8 +100,8 @@
;; 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.
@ -110,7 +110,7 @@
;; *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))
@ -151,14 +151,17 @@
;; 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)))))
@ -185,7 +188,7 @@
(array (allocate-vector
type
length
(ceiling (* (if (= type sb!vm:simple-string-widetag)
(ceiling (* (if (= type sb!vm:simple-base-string-widetag)
(1+ length)
length)
n-bits)
@ -311,7 +314,6 @@
(coerce (the list objects) 'simple-vector))
;;;; accessor/setter functions
(eval-when (:compile-toplevel :execute)
(defparameter *specialized-array-element-types*
'(t
@ -333,7 +335,7 @@
(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))
@ -556,8 +558,8 @@
;; 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)

27
src/code/class.lisp
View file

@ -1058,14 +1058,31 @@
: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))

6
src/code/defpackage.lisp
View file

@ -135,9 +135,11 @@
: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

6
src/code/deftypes-for-target.lisp
View file

@ -87,10 +87,12 @@
`(simple-array base-char (,size)))
(sb!xc:deftype string (&optional size)
`(or (array character (,size))
(base-string ,size)))
(array nil (,size))
(base-string ,size)))
(sb!xc:deftype simple-string (&optional size)
`(or (simple-array character (,size))
(simple-base-string ,size)))
(simple-array nil (,size))
(simple-base-string ,size)))
(sb!xc:deftype bit-vector (&optional size)
`(array bit (,size)))

10
src/code/interr.lisp
View file

@ -103,6 +103,11 @@
: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
@ -128,6 +133,11 @@
: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

8
src/code/late-type.lisp
View file

@ -2128,25 +2128,21 @@
(case eltype
(bit 'bit-vector)
(base-char 'base-string)
(character 'string)
(* 'vector)
(t `(vector ,eltype)))
(case eltype
(bit `(bit-vector ,(car dims)))
(base-char `(base-string ,(car dims)))
(character `(string ,(car dims)))
(t `(vector ,eltype ,(car dims)))))
(if (eq (car dims) '*)
(case eltype
(bit 'simple-bit-vector)
(base-char 'simple-base-string)
(character 'simple-string)
((t) 'simple-vector)
(t `(simple-array ,eltype (*))))
(case eltype
(bit `(simple-bit-vector ,(car dims)))
(base-char `(simple-base-string ,(car dims)))
(character `(simple-string ,(car dims)))
((t) `(simple-vector ,(car dims)))
(t `(simple-array ,eltype ,dims))))))
(t
@ -2195,7 +2191,7 @@
t)))))
(!define-superclasses array
((string string)
((base-string base-string)
(vector vector)
(array))
!cold-init-forms)
@ -2546,6 +2542,8 @@
((type= type (specifier-type 'real)) 'real)
((type= type (specifier-type 'sequence)) 'sequence)
((type= type (specifier-type 'bignum)) 'bignum)
((type= type (specifier-type 'simple-string)) 'simple-string)
((type= type (specifier-type 'string)) 'string)
(t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each

4
src/code/package.lisp
View file

@ -73,7 +73,7 @@
#!+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
@ -99,7 +99,7 @@
;; 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)))
;;;; iteration macros

3
src/code/pred.lisp
View file

@ -47,6 +47,7 @@
(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)
@ -79,6 +80,7 @@
(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)
@ -90,6 +92,7 @@
(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)

13
src/code/primordial-extensions.lisp
View file

@ -173,14 +173,15 @@
;; 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)))))

14
src/code/room.lisp
View file

@ -50,9 +50,9 @@
: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)))
@ -91,8 +91,8 @@
: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))
@ -440,7 +440,8 @@
((#.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
@ -463,7 +464,8 @@
#.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

62
src/code/seq.lisp
View file

@ -254,7 +254,20 @@
"Return a sequence of the given TYPE and LENGTH, with elements initialized
to :INITIAL-ELEMENT."
(declare (fixnum length))
(let ((type (specifier-type type)))
(let* ((adjusted-type
(typecase type
(atom (cond
((eq type 'string) '(vector character))
((eq type 'simple-string) '(simple-array character (*)))
(t type)))
(cons (cond
((eq (car type) 'string) `(vector character ,@(cdr type)))
((eq (car type) 'simple-string)
`(simple-array character ,@(when (cdr type)
(list (cdr type)))))
(t type)))
(t type)))
(type (specifier-type adjusted-type)))
(cond ((csubtypep type (specifier-type 'list))
(cond
((type= type (specifier-type 'list))
@ -279,29 +292,28 @@
;; it was stranger to feed that type in to MAKE-SEQUENCE.
(t (sequence-type-too-hairy (type-specifier type)))))
((csubtypep type (specifier-type 'vector))
(if (typep type 'array-type)
;; KLUDGE: the above test essentially asks "Do we know
;; what the upgraded-array-element-type is?" [consider
;; (OR STRING BIT-VECTOR)]
(progn
(aver (= (length (array-type-dimensions type)) 1))
(let* ((etype (type-specifier
(array-type-specialized-element-type type)))
(etype (if (eq etype '*) t etype))
(cond
(;; is it immediately obvious what the result type is?
(typep type 'array-type)
(progn
(aver (= (length (array-type-dimensions type)) 1))
(let* ((etype (type-specifier
(array-type-specialized-element-type type)))
(etype (if (eq etype '*) t etype))
(type-length (car (array-type-dimensions type))))
(unless (or (eq type-length '*)
(= type-length length))
(sequence-type-length-mismatch-error type length))
;; FIXME: These calls to MAKE-ARRAY can't be
;; open-coded, as the :ELEMENT-TYPE argument isn't
;; constant. Probably we ought to write a
;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR,
;; 2002-07-22
(if iep
(make-array length :element-type etype
:initial-element initial-element)
(make-array length :element-type etype))))
(sequence-type-too-hairy (type-specifier type))))
(unless (or (eq type-length '*)
(= type-length length))
(sequence-type-length-mismatch-error type length))
;; FIXME: These calls to MAKE-ARRAY can't be
;; open-coded, as the :ELEMENT-TYPE argument isn't
;; constant. Probably we ought to write a
;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR,
;; 2002-07-22
(if iep
(make-array length :element-type etype
:initial-element initial-element)
(make-array length :element-type etype)))))
(t (sequence-type-too-hairy (type-specifier type)))))
(t (bad-sequence-type-error (type-specifier type))))))
;;;; SUBSEQ
@ -699,6 +711,8 @@
"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))
@ -1972,7 +1986,7 @@
(frob sequence nil))))
(typecase sequence
(simple-vector (frob2))
(simple-string (frob2))
(simple-base-string (frob2))
(t (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (+ p offset))))))))))

2
src/compiler/array-tran.lisp
View file

@ -231,7 +231,7 @@
`(;; 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)

6
src/compiler/fndb.lisp
View file

@ -455,11 +455,11 @@
(:initial-element t))
consed-sequence
(movable unsafe)
:derive-type (result-type-specifier-nth-arg 1))
:derive-type (creation-result-type-specifier-nth-arg 1))
(defknown concatenate (type-specifier &rest sequence) consed-sequence
()
:derive-type (result-type-specifier-nth-arg 1))
:derive-type (creation-result-type-specifier-nth-arg 1))
(defknown (map %map) (type-specifier callable sequence &rest sequence)
consed-sequence
@ -642,7 +642,7 @@
&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

7
src/compiler/generic/early-objdef.lisp
View file

@ -72,10 +72,10 @@
#!+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
@ -91,7 +91,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

2
src/compiler/generic/genesis.lisp
View file

@ -598,7 +598,7 @@
(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))))

4
src/compiler/generic/interr.lisp
View file

@ -59,6 +59,8 @@
"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
@ -69,6 +71,8 @@
"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

34
src/compiler/generic/late-type-vops.lisp
View file

@ -75,9 +75,13 @@
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
@ -208,18 +212,26 @@
(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
@ -238,7 +250,8 @@
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))
@ -259,7 +272,7 @@
(!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
@ -281,7 +294,7 @@
(!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
@ -300,7 +313,8 @@
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))

4
src/compiler/generic/primtype.lisp
View file

@ -102,7 +102,7 @@
(/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))
@ -163,7 +163,7 @@
(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)

3
src/compiler/generic/vm-fndb.lisp
View file

@ -21,8 +21,9 @@
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

3
src/compiler/generic/vm-typetran.lisp
View file

@ -18,6 +18,7 @@
;;; 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))
@ -66,10 +67,12 @@
#!+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)

27
src/compiler/knownfun.lisp
View file

@ -260,7 +260,7 @@
(when (csubtypep type ltype)
ltype))))))))
;;; Derive the type to be the type specifier which is the N'th arg.
;;; Derive the type to be the type specifier which is the Nth arg.
(defun result-type-specifier-nth-arg (n)
(lambda (call)
(declare (type combination call))
@ -268,4 +268,29 @@
(when (and cont (constant-continuation-p cont))
(careful-specifier-type (continuation-value cont))))))
;;; Derive the type to be the type specifier which is the Nth arg,
;;; with the additional restriptions noted in the CLHS for STRING and
;;; SIMPLE-STRING.
(defun creation-result-type-specifier-nth-arg (n)
(lambda (call)
(declare (type combination call))
(let ((cont (nth (1- n) (combination-args call))))
(when (and cont (constant-continuation-p cont))
(let* ((specifier (continuation-value cont))
(lspecifier (if (atom specifier) (list specifier) specifier)))
(cond
((eq (car lspecifier) 'string)
(destructuring-bind (string &rest size)
lspecifier
(declare (ignore string))
(careful-specifier-type
`(vector character ,@(when size size)))))
((eq (car lspecifier) 'simple-string)
(destructuring-bind (simple-string &rest size)
lspecifier
(declare (ignore simple-string))
(careful-specifier-type
`(simple-array character ,@(if size (list size) '((*)))))))
(t (careful-specifier-type specifier))))))))
(/show0 "knownfun.lisp end of file")

12
src/compiler/seqtran.lisp
View file

@ -621,10 +621,10 @@
;;; 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
@ -650,7 +650,7 @@
(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))
@ -683,7 +683,7 @@
(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
@ -719,8 +719,8 @@
;;;
;;; 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")

68
src/compiler/sparc/insts.lisp
View file

@ -120,74 +120,6 @@ about function addresses and register values.")
(- 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.

16
src/compiler/x86/array.lisp
View file

@ -1243,12 +1243,12 @@
;;; 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
@ -1264,12 +1264,12 @@
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)
@ -1283,13 +1283,13 @@
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
@ -1299,13 +1299,13 @@
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

2
src/compiler/x86/c-call.lisp
View file

@ -196,7 +196,7 @@
(: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)

2
src/compiler/x86/vm.lisp
View file

@ -450,7 +450,7 @@
;;; 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

4
src/runtime/alloc.c
View file

@ -131,10 +131,10 @@ alloc_number(long n)
}
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);

2
src/runtime/backtrace.c
View file

@ -239,7 +239,7 @@ backtrace(int nframes)
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;

21
src/runtime/gc-common.c
View file

@ -769,7 +769,7 @@ static int
#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;
@ -784,7 +784,7 @@ scav_string(lispobj *where, lispobj object)
return nwords;
}
static lispobj
trans_string(lispobj object)
trans_base_string(lispobj object)
{
struct vector *vector;
int length, nwords;
@ -803,7 +803,7 @@ trans_string(lispobj object)
}
static int
size_string(lispobj *where)
size_base_string(lispobj *where)
{
struct vector *vector;
int length, nwords;
@ -1529,7 +1529,7 @@ gc_init_tables(void)
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] =
@ -1574,7 +1574,8 @@ gc_init_tables(void)
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;
@ -1624,7 +1625,7 @@ gc_init_tables(void)
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;
@ -1674,8 +1675,9 @@ gc_init_tables(void)
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;
@ -1724,7 +1726,7 @@ gc_init_tables(void)
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;
@ -1770,7 +1772,8 @@ gc_init_tables(void)
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;

12
src/runtime/gencgc.c
View file

@ -2302,7 +2302,8 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
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:
@ -2316,7 +2317,7 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
#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:
@ -2400,7 +2401,7 @@ maybe_adjust_large_object(lispobj *where)
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:
@ -3307,7 +3308,8 @@ verify_space(lispobj *start, size_t words)
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:
@ -3392,7 +3394,7 @@ verify_space(lispobj *start, size_t words)
#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:

7
src/runtime/print.c
View file

@ -385,7 +385,7 @@ static void brief_otherptr(lispobj obj)
}
break;
case SIMPLE_STRING_WIDETAG:
case SIMPLE_BASE_STRING_WIDETAG:
vector = (struct vector *)ptr;
putchar('"');
for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
@ -535,7 +535,7 @@ static void print_otherptr(lispobj obj)
break;
#endif
case SIMPLE_STRING_WIDETAG:
case SIMPLE_BASE_STRING_WIDETAG:
NEWLINE_OR_RETURN;
cptr = (char *)(ptr+1);
putchar('"');
@ -598,7 +598,8 @@ static void print_otherptr(lispobj obj)
#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:

15
src/runtime/purify.c
View file

@ -269,7 +269,8 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
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:
@ -283,7 +284,7 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
#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:
@ -900,6 +901,7 @@ static lispobj
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:
@ -916,12 +918,13 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
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);
@ -933,7 +936,7 @@ ptrans_otherptr(lispobj thing, lispobj header, boolean 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:
@ -1144,7 +1147,7 @@ pscav(lispobj *addr, int nwords, boolean constant)
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;

10
src/runtime/runtime.c
View file

@ -112,13 +112,13 @@ copied_existing_filename_or_null(char *filename)
}
/* 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;
}
@ -349,7 +349,7 @@ main(int argc, char *argv[], char *envp[])
/* 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. */

2
src/runtime/search.c
View file

@ -47,7 +47,7 @@ boolean search_for_symbol(char *name, lispobj **start, int *count)
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;
}

2
version.lisp-expr
View file

@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.8.0.78"
"0.8.0.78.vector-nil-string.1"