* finding or making sbcl@boinkor.net--2004-2/sbcl--main--0.8--patch-1102 * computing changeset A/ {arch}/sbcl/sbcl--character-branch A/ {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8 A/ {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2 A/ {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log A .arch-ids/TODO.character.id A TODO.character A tools-for-build/.arch-ids/UnicodeData.txt.id A tools-for-build/.arch-ids/ucd.lisp.id A tools-for-build/UnicodeData.txt A tools-for-build/ucd.lisp A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/base-0 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-1 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-10 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-11 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-12 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-13 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-14 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-15 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-16 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-17 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-18 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-19 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-2 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-20 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-21 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-22 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-23 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-24 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-25 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-26 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-27 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-28 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-29 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-3 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-30 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-31 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-32 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-33 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-34 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-35 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-36 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-37 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-38 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-39 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-4 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-40 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-41 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-42 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-43 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-44 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-5 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-6 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-7 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-8 A {arch}/sbcl/sbcl--character-branch/sbcl--character-branch--0.8/sbcl@boinkor.net--2004-2/patch-log/patch-9 M src/code/cross-condition.lisp M tools-for-build/ldso-stubs.lisp M make-host-1.sh M package-data-list.lisp-expr M version.lisp-expr M src/code/array.lisp M src/code/char.lisp M src/code/class.lisp M src/code/cold-init.lisp M src/code/cross-type.lisp M src/code/debug-int.lisp M src/code/debug.lisp M src/code/defboot.lisp M src/code/defpackage.lisp M src/code/defstruct.lisp M src/code/deftypes-for-target.lisp M src/code/primordial-extensions.lisp M src/code/early-format.lisp M src/code/early-pprint.lisp M src/code/early-setf.lisp M src/code/early-type.lisp M src/code/error.lisp M src/code/fd-stream.lisp M src/code/filesys.lisp M src/code/fop.lisp M src/code/host-c-call.lisp M src/code/interr.lisp M src/code/late-format.lisp M src/code/late-type.lisp M src/code/ansi-stream.lisp M src/code/loop.lisp M src/code/macros.lisp M src/code/package.lisp M src/code/pprint.lisp M src/code/pred.lisp M src/code/print.lisp M src/code/query.lisp M src/code/reader.lisp M src/code/readtable.lisp M src/code/room.lisp M src/code/run-program.lisp M src/code/seq.lisp M src/code/stream.lisp M src/code/sysmacs.lisp M src/code/target-alieneval.lisp M src/code/target-c-call.lisp M src/code/target-format.lisp M src/code/target-load.lisp M src/code/numbers.lisp M src/code/target-package.lisp M src/code/target-pathname.lisp M src/code/target-type.lisp M src/code/time.lisp M src/code/toplevel.lisp M src/code/typep.lisp M src/code/unix.lisp M src/cold/shebang.lisp M src/cold/warm.lisp M src/compiler/array-tran.lisp M src/compiler/assem.lisp M src/compiler/backend.lisp M src/compiler/ctype.lisp M src/compiler/dump.lisp M src/compiler/fndb.lisp M src/compiler/gtn.lisp M src/compiler/ir1final.lisp M src/compiler/ir1opt.lisp M src/compiler/ir1tran.lisp M src/compiler/ir1util.lisp M src/compiler/locall.lisp M src/compiler/main.lisp M src/compiler/meta-vmdef.lisp M src/compiler/pack.lisp M src/compiler/represent.lisp M src/compiler/seqtran.lisp M src/compiler/srctran.lisp M src/compiler/target-disassem.lisp M src/compiler/target-dump.lisp M src/compiler/typetran.lisp M src/pcl/walk.lisp M src/runtime/backtrace.c M src/runtime/gencgc.c M src/runtime/interr.c M src/runtime/print.c M src/runtime/purify.c M src/runtime/runtime.c M src/runtime/search.c M src/compiler/generic/early-objdef.lisp M src/compiler/generic/genesis.lisp M src/compiler/generic/interr.lisp M src/compiler/generic/primtype.lisp M src/compiler/generic/vm-fndb.lisp M src/compiler/generic/vm-tran.lisp M src/compiler/generic/vm-typetran.lisp M src/compiler/x86/array.lisp M src/compiler/x86/c-call.lisp M src/compiler/x86/cell.lisp M src/compiler/x86/char.lisp M src/compiler/x86/memory.lisp M src/compiler/x86/move.lisp M src/compiler/x86/pred.lisp M src/compiler/x86/vm.lisp M tests/pathnames.impure.lisp M tests/seq.impure.lisp M tests/type.impure.lisp M tests/type.before-xc.lisp M src/code/target-char.lisp M src/runtime/gc-common.c M tools-for-build/grovel-headers.c M src/compiler/ir1-translators.lisp M src/code/typecheckfuns.lisp M tests/character.pure.lisp M tests/dump.impure-cload.lisp M src/compiler/ppc/array.lisp M src/compiler/ppc/c-call.lisp M src/compiler/ppc/char.lisp M src/compiler/ppc/move.lisp M src/compiler/ppc/vm.lisp M src/runtime/gc-internal.h M src/compiler/generic/early-type-vops.lisp M src/compiler/generic/late-type-vops.lisp M src/code/target-thread.lisp M src/code/target-unithread.lisp M contrib/sb-aclrepl/inspect.lisp M tests/compiler.test.sh M src/code/cross-char.lisp M src/compiler/generic/vm-array.lisp M contrib/sb-simple-streams/impl.lisp --- orig/tests/dump.impure-cload.lisp +++ mod/tests/dump.impure-cload.lisp @@ -98,4 +98,30 @@ (defvar *2-bit* #.(make-array 5 :element-type '(unsigned-byte 2) :initial-element 0)) (defvar *4-bit* #.(make-array 5 :element-type '(unsigned-byte 4) :initial-element 1)) +;;; tests for constant coalescing (and absence of such) in the +;;; presence of strings. +(progn + (defvar *character-string-1* #.(make-string 5 :initial-element #\a)) + (defvar *character-string-2* #.(make-string 5 :initial-element #\a)) + (assert (eq *character-string-1* *character-string-2*)) + (assert (typep *character-string-1* '(simple-array character (5))))) + +(progn + (defvar *base-string-1* + #.(make-string 5 :initial-element #\b :element-type 'base-char)) + (defvar *base-string-2* + #.(make-string 5 :initial-element #\b :element-type 'base-char)) + (assert (eq *base-string-1* *base-string-2*)) + (assert (typep *base-string-1* '(simple-base-string 5)))) + +#-#.(cl:if (cl:subtypep 'cl:character 'cl:base-char) '(and) '(or)) +(progn + (defvar *base-string* + #.(make-string 5 :element-type 'base-char :initial-element #\x)) + (defvar *character-string* + #.(make-string 5 :initial-element #\x)) + (assert (not (eq *base-string* *character-string*))) + (assert (typep *base-string* 'base-string)) + (assert (typep *character-string* '(vector character)))) + (sb-ext:quit :unix-status 104) ; success --- orig/src/compiler/assem.lisp +++ mod/src/compiler/assem.lisp @@ -27,7 +27,7 @@ ;;; This structure holds the state of the assembler. (defstruct (segment (:copier nil)) ;; the name of this segment (for debugging output and stuff) - (name "unnamed" :type simple-base-string) + (name "unnamed" :type simple-string) ;; Ordinarily this is a vector where instructions are written. If ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the ;; vector can be replaced by NIL. @@ -953,7 +953,7 @@ (when (< (find-alignment additional-delta) (chooser-alignment note)) (error "~S shrunk by ~W bytes, but claimed that it ~ - preserves ~W bits of alignment." + preserves ~W bits of alignment." note additional-delta (chooser-alignment note))) (incf delta additional-delta) (emit-filler segment additional-delta)) @@ -995,7 +995,7 @@ (additional-delta (- old-size size))) (when (minusp additional-delta) (error "Alignment ~S needs more space now? It was ~W, ~ - and is ~W now." + and is ~W now." note old-size size)) (when (plusp additional-delta) (emit-filler segment additional-delta) @@ -1387,7 +1387,7 @@ (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr)))) (when (ldb-test (byte byte-size byte-posn) overall-mask) (error "The byte spec ~S either overlaps another byte spec, or ~ - extends past the end." + extends past the end." byte-spec-expr)) (setf (ldb byte-spec overall-mask) -1) (arg-names arg) @@ -1650,7 +1650,7 @@ (setf (segment-postits ,segment-name) nil) (macrolet ((%%current-segment%% () (error "You can't use INST without an ~ - ASSEMBLE inside emitters."))) + ASSEMBLE inside emitters."))) ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) ;; can't deal with this declaration, so disable it on host ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%% --- orig/src/code/macros.lisp +++ mod/src/code/macros.lisp @@ -37,7 +37,7 @@ (defun assert-prompt (name value) (cond ((y-or-n-p "The old value of ~S is ~S.~ - ~%Do you want to supply a new value? " + ~%Do you want to supply a new value? " name value) (format *query-io* "~&Type a form to be evaluated:~%") (flet ((read-it () (eval (read *query-io*)))) --- orig/src/code/target-type.lisp +++ mod/src/code/target-type.lisp @@ -33,6 +33,7 @@ named-type member-type array-type + character-set-type built-in-classoid cons-type) (values (%typep obj type) t)) @@ -191,6 +192,8 @@ :specialized-element-type etype))) (cons (make-cons-type *universal-type* *universal-type*)) + (character + (specifier-type 'character)) (t (classoid-of x)))) --- orig/src/compiler/backend.lisp +++ mod/src/compiler/backend.lisp @@ -157,7 +157,7 @@ name) *backend-support-routines*) (error "machine-specific support ~S ~ - routine undefined" + routine undefined" ',name)) args))) routines)))) --- orig/src/compiler/ppc/c-call.lisp +++ mod/src/compiler/ppc/c-call.lisp @@ -303,7 +303,7 @@ (:translate foreign-symbol-address) (:policy :fast-safe) (:args) - (:arg-types (:constant simple-base-string)) + (:arg-types (:constant simple-string)) (:info foreign-symbol) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) --- orig/src/code/stream.lisp +++ mod/src/code/stream.lisp @@ -276,11 +276,11 @@ #!-sb-fluid (declaim (inline ansi-stream-unread-char)) (defun ansi-stream-unread-char (character stream) (let ((index (1- (ansi-stream-in-index stream))) - (buffer (ansi-stream-in-buffer stream))) + (buffer (ansi-stream-cin-buffer stream))) (declare (fixnum index)) (when (minusp index) (error "nothing to unread")) (cond (buffer - (setf (aref buffer index) (char-code character)) + (setf (aref buffer index) character) (setf (ansi-stream-in-index stream) index)) (t (funcall (ansi-stream-misc stream) stream @@ -418,7 +418,7 @@ ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER, ;;; and hence must be an N-BIN method. (defun fast-read-char-refill (stream eof-error-p eof-value) - (let* ((ibuf (ansi-stream-in-buffer stream)) + (let* ((ibuf (ansi-stream-cin-buffer stream)) (count (funcall (ansi-stream-n-bin stream) stream ibuf @@ -433,16 +433,17 @@ (funcall (ansi-stream-in stream) stream eof-error-p eof-value)) (t (when (/= start +ansi-stream-in-buffer-extra+) + ;; FIXME AARGH KLUDGE There's no sb!vm:n-character-bits. (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+ - sb!vm:n-byte-bits) + sb!vm:n-byte-bits 4) (* sb!vm:vector-data-offset sb!vm:n-word-bits)) - ibuf (+ (the index (* start sb!vm:n-byte-bits)) + ibuf (+ (the index (* start sb!vm:n-byte-bits 4)) (* sb!vm:vector-data-offset sb!vm:n-word-bits)) - (* count sb!vm:n-byte-bits))) + (* count sb!vm:n-byte-bits 4))) (setf (ansi-stream-in-index stream) (1+ start)) - (code-char (aref ibuf start)))))) + (aref ibuf start))))) ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to ;;; leave room for unreading. @@ -1028,7 +1029,7 @@ (:include string-stream (in #'string-inch) (bin #'ill-bin) - (n-bin #'string-stream-read-n-bytes) + (n-bin #'ill-bin) (misc #'string-in-misc) (string (missing-arg) :type simple-string)) (:constructor internal-make-string-input-stream @@ -1233,14 +1234,19 @@ (element-type (string-output-stream-element-type stream)) (result (case element-type - ;; Overwhelmingly common case; can be inlined. + ;; overwhelmingly common case: can be inlined ((character) (make-string length)) + ;; slightly less common cases: inline it anyway + ((base-char standard-char) + (make-string length :element-type 'base-char)) (t (make-string length :element-type element-type))))) ;; For the benefit of the REPLACE transform, let's do this, so ;; that the common case isn't ludicrously expensive. (etypecase result ((simple-array character (*)) (replace result (string-output-stream-string stream))) + (simple-base-string + (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0 @@ -1263,6 +1269,8 @@ ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. +;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL), +;;; ideally without destroying all hope of efficiency. (deftype string-with-fill-pointer () '(and (vector character) (satisfies array-has-fill-pointer-p))) @@ -1292,9 +1300,9 @@ (if (= offset-current end) (let* ((new-length (1+ (* current 2))) (new-workspace (make-string new-length))) - (declare (simple-string new-workspace)) - (%byte-blt workspace start - new-workspace 0 current) + (declare (type (simple-array character (*)) new-workspace)) + (replace new-workspace workspace + :start2 start :end2 offset-current) (setf workspace new-workspace offset-current current) (set-array-header buffer workspace new-length @@ -1322,21 +1330,16 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (type (simple-array character (*)) new-workspace)) - (%byte-blt workspace dst-start - new-workspace 0 current) - (setf workspace new-workspace) - (setf offset-current current) - (setf offset-dst-end dst-end) - (set-array-header buffer - workspace - new-length - dst-end - 0 - new-length - nil)) + (replace new-workspace workspace + :start2 dst-start :end2 offset-current) + (setf workspace new-workspace + offset-current current + offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil)) (setf (fill-pointer buffer) dst-end)) - (%byte-blt string start - workspace offset-current offset-dst-end))) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) @@ -1399,7 +1402,7 @@ (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) (%write-string - " " + #.(make-string 60 :initial-element #\Space) ,sub-stream 0 (min 60 (- indentation i))))) @@ -1472,12 +1475,12 @@ #!+sb-doc "Return a stream that sends all output to the stream TARGET, but modifies the case of letters, depending on KIND, which should be one of: - :upcase - convert to upper case. - :downcase - convert to lower case. - :capitalize - convert the first letter of words to upper case and the - rest of the word to lower case. - :capitalize-first - convert the first letter of the first word to upper - case and everything else to lower case." + :UPCASE - convert to upper case. + :DOWNCASE - convert to lower case. + :CAPITALIZE - convert the first letter of words to upper case and the + rest of the word to lower case. + :CAPITALIZE-FIRST - convert the first letter of the first word to upper + case and everything else to lower case." (declare (type stream target) (type (member :upcase :downcase :capitalize :capitalize-first) kind) @@ -1525,7 +1528,7 @@ (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1550,7 +1553,7 @@ (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1583,7 +1586,7 @@ (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1628,7 +1631,7 @@ (defun case-frob-capitalize-aux-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1673,7 +1676,7 @@ (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-base-string str) + (type simple-string str) (type index start) (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) @@ -1742,8 +1745,7 @@ (with-array-data ((data seq) (offset-start start) (offset-end end)) (typecase data ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*)) - simple-string) + (simple-array (signed-byte 8) (*))) (let* ((numbytes (- end start)) (bytes-read (read-n-bytes stream data offset-start numbytes nil))) --- orig/src/code/primordial-extensions.lisp +++ mod/src/code/primordial-extensions.lisp @@ -167,30 +167,15 @@ ;;; producing a symbol in the current package. (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun symbolicate (&rest things) - (let ((name (case (length things) - ;; Why isn't this just the value in the T branch? - ;; Well, this is called early in cold-init, before - ;; the type system is set up; however, now that we - ;; 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-base-string - (string (car things))))) - (2 (concatenate 'string - (the simple-base-string - (string (car things))) - (the simple-base-string - (string (cadr things))))) - (3 (concatenate 'string - (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))))) + (let* ((length (reduce #'+ things + :key (lambda (x) (length (string x))))) + (name (make-array length :element-type 'character))) + (let ((index 0)) + (dolist (thing things (values (intern name))) + (let* ((x (string thing)) + (len (length x))) + (replace name x :start1 index) + (incf index len))))))) ;;; like SYMBOLICATE, but producing keywords (defun keywordicate (&rest things) --- orig/src/code/loop.lisp +++ mod/src/code/loop.lisp @@ -1190,12 +1190,12 @@ (t (unless (eq (loop-collector-class cruft) class) (loop-error "incompatible kinds of LOOP value accumulation specified for collecting~@ - ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" name (car (loop-collector-history cruft)) collector)) (unless (equal dtype (loop-collector-dtype cruft)) (loop-warn "unequal datatypes specified in different LOOP value accumulations~@ - into ~S: ~S and ~S" + into ~S: ~S and ~S" name dtype (loop-collector-dtype cruft)) (when (eq (loop-collector-dtype cruft) t) (setf (loop-collector-dtype cruft) dtype))) @@ -1664,7 +1664,7 @@ (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) (loop-error "The variable substitution for ~S occurs twice in a USING phrase,~@ - with ~S and ~S." + with ~S and ~S." (car z) (cadr z) (cadr tem)) (push (cons (car z) (cadr z)) *loop-named-vars*))) (when (or (null *loop-source-code*) @@ -1742,7 +1742,7 @@ nil t))) (t (loop-error "~S invalid preposition in sequencing or sequence path;~@ - maybe invalid prepositions were specified in iteration path descriptor?" + maybe invalid prepositions were specified in iteration path descriptor?" prep))) (when (and odir dir (not (eq dir odir))) (loop-error "conflicting stepping directions in LOOP sequencing path")) --- orig/src/runtime/search.c +++ mod/src/runtime/search.c @@ -47,6 +47,8 @@ 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) && + /* FIXME: Broken with more than one type of string + (i.e. even broken given (VECTOR NIL) */ widetag_of(symbol_name->header) == SIMPLE_BASE_STRING_WIDETAG && strcmp((char *)symbol_name->data, name) == 0) return 1; --- orig/src/code/early-setf.lisp +++ mod/src/code/early-setf.lisp @@ -85,7 +85,7 @@ (sb!xc:get-setf-expansion form environment) (when (cdr store-vars) (error "GET-SETF-METHOD used for a form with multiple store ~ - variables:~% ~S" + variables:~% ~S" form)) (values temps value-forms store-vars store-form access-form))) @@ -342,7 +342,7 @@ (cond ((gethash name sb!c:*setf-assumed-fboundp*) (warn "defining setf macro for ~S when ~S was previously ~ - treated as a function" + treated as a function" name `(setf ,name))) ((not (fboundp `(setf ,name))) --- orig/src/code/typep.lisp +++ mod/src/code/typep.lisp @@ -117,6 +117,14 @@ (and (consp object) (%%typep (car object) (cons-type-car-type type)) (%%typep (cdr object) (cons-type-cdr-type type)))) + (character-set-type + (and (characterp object) + (let ((code (char-code object)) + (pairs (character-set-type-pairs type))) + (dolist (pair pairs nil) + (destructuring-bind (low . high) pair + (when (<= low code high) + (return t))))))) (unknown-type ;; dunno how to do this ANSIly -- WHN 19990413 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host") --- orig/src/cold/warm.lisp +++ mod/src/cold/warm.lisp @@ -73,10 +73,13 @@ (make-pathname :directory '(:relative "contrib" :wild-inferiors) :name :wild :type :wild) sys))) + (sb-int:/show "about to set SYS logical pathname translations") (setf (logical-pathname-translations "SYS") `(("SYS:SRC;**;*.*.*" ,src) ("SYS:CONTRIB;**;*.*.*" ,contrib)))) +(sb-int:/show "set SYS logical pathname translations") + ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around ;;; COMPILE-PCL, at least some of which we should probably have too: ;;; @@ -175,7 +178,7 @@ ;; facility, and should be compiled and loaded after ;; our DESCRIBE facility is compiled and loaded. "SRC;PCL;DESCRIBE")) - + (sb-int:/show "at head of DOLIST") (let ((fullname (concatenate 'string "SYS:" stem ".LISP"))) (sb-int:/show "about to compile" fullname) (flet ((report-recompile-restart (stream) --- orig/src/compiler/gtn.lisp +++ mod/src/compiler/gtn.lisp @@ -137,8 +137,8 @@ (let ((*compiler-error-context* (lambda-bind (first funs)))) (compiler-notify "Return value count mismatch prevents known return ~ - from these functions:~ - ~{~% ~A~}" + from these functions:~ + ~{~% ~A~}" (mapcar #'leaf-source-name (remove-if-not #'leaf-has-source-name-p funs))))) (let ((ret (lambda-return fun))) @@ -150,7 +150,7 @@ (let ((*compiler-error-context* (lambda-bind fun))) (compiler-notify "Return type not fixed values, so can't use known return ~ - convention:~% ~S" + convention:~% ~S" (type-specifier rtype))) (return))))))))) (values)) --- orig/src/code/target-char.lisp +++ mod/src/code/target-char.lisp @@ -32,6 +32,27 @@ (deftype char-code () `(integer 0 (,char-code-limit))) +(defvar *character-database*) + +(macrolet ((frob () + (with-open-file (stream (merge-pathnames + (make-pathname + :directory + '(:relative :up :up "output") + :name "ucd" + :type "dat") + sb!xc:*compile-file-pathname*) + :direction :input + :element-type '(unsigned-byte 8)) + (let* ((length (file-length stream)) + (array (make-array length + :element-type '(unsigned-byte 8)))) + (read-sequence array stream) + `(defun !character-database-cold-init () + (setq *character-database* ',array)))))) + (frob)) +#+sb-xc-host (!character-database-cold-init) + ;;; This is the alist of (character-name . character) for characters ;;; with long names. The first name in this list for a given character ;;; is used on typeout and is the preferred form for input. @@ -40,8 +61,10 @@ (dolist (code char-names-list) (destructuring-bind (ccode names) code (dolist (name names) - (results (cons name (code-char ccode)))))) - `(defparameter *char-name-alist* ',(results))))) + (results (cons name ccode))))) + `(defparameter *char-name-alist* + (mapcar (lambda (x) (cons (car x) (code-char (cdr x)))) + ',(results)))))) ;; Note: The *** markers here indicate character names which are ;; required by the ANSI specification of #'CHAR-NAME. For the others, ;; we prefer the ASCII standard name. @@ -78,15 +101,76 @@ (#x1E ("Rs" "^^")) (#x1F ("Us" "^_")) (#x20 ("Space" "Sp")) ; *** See Note above. - (#x7f ("Rubout" "Delete" "Del"))))) ; *** See Note above. + (#x7f ("Rubout" "Delete" "Del")) + (#x80 ("C80")) + (#x81 ("C81")) + (#x82 ("Break-Permitted")) + (#x83 ("No-Break-Permitted")) + (#x84 ("C84")) + (#x85 ("Next-Line")) + (#x86 ("Start-Selected-Area")) + (#x87 ("End-Selected-Area")) + (#x88 ("Character-Tabulation-Set")) + (#x89 ("Character-Tabulation-With-Justification")) + (#x8A ("Line-Tabulation-Set")) + (#x8B ("Partial-Line-Forward")) + (#x8C ("Partial-Line-Backward")) + (#x8D ("Reverse-Linefeed")) + (#x8E ("Single-Shift-Two")) + (#x8F ("Single-Shift-Three")) + (#x90 ("Device-Control-String")) + (#x91 ("Private-Use-One")) + (#x92 ("Private-Use-Two")) + (#x93 ("Set-Transmit-State")) + (#x94 ("Cancel-Character")) + (#x95 ("Message-Waiting")) + (#x96 ("Start-Guarded-Area")) + (#x97 ("End-Guarded-Area")) + (#x98 ("Start-String")) + (#x99 ("C99")) + (#x9A ("Single-Character-Introducer")) + (#x9B ("Control-Sequence-Introducer")) + (#x9C ("String-Terminator")) + (#x9D ("Operating-System-Command")) + (#x9E ("Privacy-Message")) + (#x9F ("Application-Program-Command"))))) ; *** See Note above. ;;;; accessor functions +;; (* 8 186) => 1488 +;; (+ 1488 (ash #x110000 -8)) => 5840 +(defun ucd-index (char) + (let* ((cp (char-code char)) + (cp-high (ash cp -8)) + (page (aref *character-database* (+ 1488 cp-high)))) + (+ 5840 (ash page 10) (ash (ldb (byte 8 0) cp) 2)))) + +(defun ucd-value-0 (char) + (aref *character-database* (ucd-index char))) + +(defun ucd-value-1 (char) + (let ((index (ucd-index char))) + (dpb (aref *character-database* (+ index 3)) + (byte 8 16) + (dpb (aref *character-database* (+ index 2)) + (byte 8 8) + (aref *character-database* (1+ index)))))) + +(defun ucd-general-category (char) + (aref *character-database* (* 8 (ucd-value-0 char)))) + +(defun ucd-decimal-digit (char) + (let ((decimal-digit (aref *character-database* + (+ 3 (* 8 (ucd-value-0 char)))))) + (when (< decimal-digit 10) + decimal-digit))) + (defun char-code (char) #!+sb-doc "Return the integer code of CHAR." + ;; FIXME: do we actually need this? (etypecase char - (base-char (char-code (truly-the base-char char))))) + (character (char-code (truly-the character char))))) (defun char-int (char) #!+sb-doc @@ -156,41 +240,34 @@ "The argument must be a character object. GRAPHIC-CHAR-P returns T if the argument is a printing character (space through ~ in ASCII), otherwise returns NIL." - (and (typep char 'base-char) - (< 31 - (char-code (the base-char char)) - 127))) + (let ((n (char-code char))) + (or (< 31 n 127) + (< 159 n)))) (defun alpha-char-p (char) #!+sb-doc "The argument must be a character object. ALPHA-CHAR-P returns T if the argument is an alphabetic character, A-Z or a-z; otherwise NIL." - (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123)))) + (< (ucd-general-category char) 5)) (defun upper-case-p (char) #!+sb-doc "The argument must be a character object; UPPER-CASE-P returns T if the argument is an upper-case character, NIL otherwise." - (< 64 - (char-code char) - 91)) + (= (ucd-value-0 char) 0)) (defun lower-case-p (char) #!+sb-doc "The argument must be a character object; LOWER-CASE-P returns T if the argument is a lower-case character, NIL otherwise." - (< 96 - (char-code char) - 123)) + (= (ucd-value-0 char) 1)) (defun both-case-p (char) #!+sb-doc "The argument must be a character object. BOTH-CASE-P returns T if the argument is an alphabetic character and if the character exists in both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P." - (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123)))) + (< (ucd-value-0 char) 2)) (defun digit-char-p (char &optional (radix 10.)) #!+sb-doc @@ -208,14 +285,17 @@ ;; Also check lower case a - z. ((and (>= (setq m (- m 32)) 10) (< m radix)) m) ;; Else, fail. - (t nil)))) + (t (let ((number (ucd-decimal-digit char))) + (when (and number (< number radix)) + number)))))) (defun alphanumericp (char) #!+sb-doc "Given a character-object argument, ALPHANUMERICP returns T if the argument is either numeric or alphabetic." - (let ((m (char-code char))) - (or (< 47 m 58) (< 64 m 91) (< 96 m 123)))) + (let ((gc (ucd-general-category char))) + (or (< gc 5) + (= gc 12)))) (defun char= (character &rest more-characters) #!+sb-doc @@ -279,8 +359,11 @@ ;;; which loses font, bits, and case info. (defmacro equal-char-code (character) - `(let ((ch (char-code ,character))) - (if (< 96 ch 123) (- ch 32) ch))) + (let ((ch (gensym))) + `(let ((,ch ,character)) + (if (= (ucd-value-0 ,ch) 0) + (ucd-value-1 ,ch) + (char-code ,ch))))) (defun char-equal (character &rest more-characters) #!+sb-doc @@ -354,16 +437,17 @@ (defun char-upcase (char) #!+sb-doc - "Return CHAR converted to upper-case if that is possible." - (if (lower-case-p char) - (code-char (- (char-code char) 32)) + "Return CHAR converted to upper-case if that is possible. Don't convert + lowercase eszet (U+DF)." + (if (= (ucd-value-0 char) 1) + (code-char (ucd-value-1 char)) char)) (defun char-downcase (char) #!+sb-doc "Return CHAR converted to lower-case if that is possible." - (if (upper-case-p char) - (code-char (+ (char-code char) 32)) + (if (= (ucd-value-0 char) 0) + (code-char (ucd-value-1 char)) char)) (defun digit-char (weight &optional (radix 10)) --- orig/src/compiler/locall.lisp +++ mod/src/compiler/locall.lisp @@ -392,8 +392,8 @@ (cond (losing-local-functional (let ((*compiler-error-context* call)) (compiler-notify "couldn't inline expand because expansion ~ - calls this LET-converted local function:~ - ~% ~S" + calls this LET-converted local function:~ + ~% ~S" (leaf-debug-name losing-local-functional))) (loop for block = (block-next pred) then (block-next block) until (eq block end) @@ -627,8 +627,7 @@ (when (optional-dispatch-keyp fun) (when (oddp (length more)) (compiler-warn "function called with odd number of ~ - arguments in keyword portion") - + arguments in keyword portion") (setf (basic-combination-kind call) :error) (return-from convert-more-call)) --- orig/src/compiler/generic/early-objdef.lisp +++ mod/src/compiler/generic/early-objdef.lisp @@ -136,7 +136,7 @@ return-pc-header ; 00110110 value-cell-header ; 00111010 symbol-header ; 00111110 - base-char ; 01000010 + character ; 01000010 sap ; 01000110 unbound-marker ; 01001010 weak-pointer ; 01001110 @@ -167,6 +167,7 @@ simple-array-unsigned-byte-16 ; 10011110 simple-array-nil ; 10100010 simple-base-string ; 10100110 + simple-character-string simple-bit-vector ; 10101010 simple-vector ; 10101110 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) @@ -195,16 +196,19 @@ simple-array ; 11011110 complex-vector-nil ; 11100010 complex-base-string ; 11100110 + complex-character-string complex-bit-vector ; 11101010 complex-vector ; 11101110 complex-array ; 11110010 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) unused12 ; 11110110 + #| #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) unused13 ; 11111010 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) unused14 ; 11111110 + |# ) ;;; the different vector subtypes --- orig/src/code/reader.lisp +++ mod/src/code/reader.lisp @@ -61,21 +61,28 @@ (defmacro get-cat-entry (char rt) ;; KLUDGE: Only give this side-effect-free args. ;; FIXME: should probably become inline function - `(elt (character-attribute-table ,rt) - (char-code ,char))) + `(if (typep ,char 'base-char) + (elt (character-attribute-array ,rt) (char-code ,char)) + (gethash ,char (character-attribute-hash-table ,rt) +char-attr-constituent+))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (character-attribute-table rt) - (char-code char)) - newvalue)) + (if (typep char 'base-char) + (setf (elt (character-attribute-array rt) (char-code char)) newvalue) + ;; FIXME: could REMHASH if we're setting to + ;; +CHAR-ATTR-CONSTITUENT+ + (setf (gethash char (character-attribute-hash-table rt)) newvalue))) ;;; the value actually stored in the character macro table. As per ;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can ;;; be either a function or NIL. (eval-when (:compile-toplevel :execute) (sb!xc:defmacro get-raw-cmt-entry (char readtable) - `(svref (character-macro-table ,readtable) - (char-code ,char)))) + `(if (typep ,char 'base-char) + (svref (character-macro-array ,readtable) (char-code ,char)) + ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so + ;; that everything above the base-char range is a non-macro + ;; constituent by default. + (gethash ,char (character-macro-hash-table ,readtable) nil)))) ;;; the value represented by whatever is stored in the character macro ;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, @@ -87,10 +94,13 @@ #'read-token))) (defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) - (setf (svref (character-macro-table rt) - (char-code char)) - (and new-value-designator - (%coerce-callable-to-fun new-value-designator)))) + (if (typep char 'base-char) + (setf (svref (character-macro-array rt) (char-code char)) + (and new-value-designator + (%coerce-callable-to-fun new-value-designator))) + (setf (gethash char (character-macro-hash-table rt)) + (and new-value-designator + (%coerce-callable-to-fun new-value-designator))))) (defun undefined-macro-char (stream char) (unless *read-suppress* @@ -137,7 +147,7 @@ (defun !cold-init-secondary-attribute-table () (setq *secondary-attribute-table* - (make-array char-code-limit :element-type '(unsigned-byte 8) + (make-array base-char-code-limit :element-type '(unsigned-byte 8) :initial-element +char-attr-constituent+)) (!set-secondary-attribute #\: +char-attr-package-delimiter+) (!set-secondary-attribute #\| +char-attr-multiple-escape+) ; |) [for EMACS] @@ -165,17 +175,29 @@ ;;;; readtable operations +(defun shallow-replace/eql-hash-table (to from) + (maphash (lambda (k v) (setf (gethash k to) v)) from)) + (defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) (let ((really-from-readtable (or from-readtable *standard-readtable*)) (really-to-readtable (or to-readtable (make-readtable)))) - (replace (character-attribute-table really-to-readtable) - (character-attribute-table really-from-readtable)) - (replace (character-macro-table really-to-readtable) - (character-macro-table really-from-readtable)) + (replace (character-attribute-array really-to-readtable) + (character-attribute-array really-from-readtable)) + (shallow-replace/eql-hash-table + (character-attribute-hash-table really-to-readtable) + (character-attribute-hash-table really-from-readtable)) + (replace (character-macro-array really-to-readtable) + (character-macro-array really-from-readtable)) + (shallow-replace/eql-hash-table + (character-macro-hash-table really-to-readtable) + (character-macro-hash-table really-from-readtable)) (setf (dispatch-tables really-to-readtable) - (mapcar (lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) + (mapcar (lambda (pair) + (cons (car pair) + (let ((table (make-hash-table))) + (shallow-replace/eql-hash-table table (cdr pair)) + table))) (dispatch-tables really-from-readtable))) (setf (readtable-case really-to-readtable) (readtable-case really-from-readtable)) @@ -250,17 +272,27 @@ (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) (prepare-for-fast-read-char stream - (do ((attribute-table (character-attribute-table *readtable*)) + (do ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table + (character-attribute-hash-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum (aref attribute-table (char-code char))) + ((/= (the fixnum + (if (typep char 'base-char) + (aref attribute-array (char-code char)) + (gethash char attribute-hash-table +char-attr-constituent+))) +char-attr-whitespace+) (done-with-fast-read-char) char))) ;; CLOS stream - (do ((attribute-table (character-attribute-table *readtable*)) + (do ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table + (character-attribute-hash-table *readtable*)) (char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) - (/= (the fixnum (aref attribute-table (char-code char))) + (/= (the fixnum + (if (typep char 'base-char) + (aref attribute-array (char-code char)) + (gethash char attribute-hash-table +char-attr-constituent+))) +char-attr-whitespace+)) (if (eq char :eof) (error 'end-of-file :stream stream) @@ -299,7 +331,7 @@ ;; all constituents (do ((ichar 0 (1+ ichar)) (char)) - ((= ichar #O200)) + ((= ichar base-char-code-limit)) (setq char (code-char ichar)) (when (constituentp char *standard-readtable*) (set-cat-entry char (get-secondary-attribute char)) @@ -621,8 +653,13 @@ ;;;; character classes ;;; Return the character class for CHAR. -(defmacro char-class (char attable) - `(let ((att (aref ,attable (char-code ,char)))) +;;; +;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY? +;;; Because we've cached the readtable tables? +(defmacro char-class (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) (if (<= att +char-attr-terminating-macro+) +char-attr-delimiter+ @@ -630,8 +667,10 @@ ;;; Return the character class for CHAR, which might be part of a ;;; rational number. -(defmacro char-class2 (char attable) - `(let ((att (aref ,attable (char-code ,char)))) +(defmacro char-class2 (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) (if (<= att +char-attr-terminating-macro+) +char-attr-delimiter+ @@ -644,8 +683,10 @@ ;;; Return the character class for a char which might be part of a ;;; rational or floating number. (Assume that it is a digit if it ;;; could be.) -(defmacro char-class3 (char attable) - `(let ((att (aref ,attable (char-code ,char)))) +(defmacro char-class3 (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) (if possibly-rational (setq possibly-rational @@ -734,7 +775,8 @@ (when *read-suppress* (internal-read-extended-token stream firstchar nil) (return-from read-token nil)) - (let ((attribute-table (character-attribute-table *readtable*)) + (let ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table (character-attribute-hash-table *readtable*)) (package-designator nil) (colons 0) (possibly-rational t) @@ -745,7 +787,7 @@ (seen-multiple-escapes nil)) (reset-read-buffer) (prog ((char firstchar)) - (case (char-class3 char attribute-table) + (case (char-class3 char attribute-array attribute-hash-table) (#.+char-attr-constituent-sign+ (go SIGN)) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) (#.+char-attr-constituent-digit-or-expt+ @@ -764,7 +806,7 @@ (unless char (go RETURN-SYMBOL)) (setq possibly-rational t possibly-float t) - (case (char-class3 char attribute-table) + (case (char-class3 char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) (#.+char-attr-constituent-digit-or-expt+ (setq seen-digit-or-expt t) @@ -781,7 +823,7 @@ (setq char (read-char stream nil nil)) (unless char (return (make-integer))) (setq was-possibly-float possibly-float) - (case (char-class3 char attribute-table) + (case (char-class3 char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) (#.+char-attr-constituent-decimal-digit+ (if possibly-float (go LEFTDECIMALDIGIT) @@ -810,7 +852,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) - (case (char-class3 char attribute-table) + (case (char-class3 char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) (#.+char-attr-constituent-decimal-digit+ (bug "impossible!")) (#.+char-attr-constituent-dot+ (go SYMBOL)) @@ -831,7 +873,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT)) (#.+char-attr-constituent-dot+ (go MIDDLEDOT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) @@ -848,7 +890,7 @@ (setq char (read-char stream nil nil)) (unless char (return (let ((*read-base* 10)) (make-integer)))) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) (#.+char-attr-delimiter+ @@ -863,7 +905,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) (#.+char-attr-delimiter+ @@ -877,7 +919,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-escape+ (go ESCAPE)) @@ -887,7 +929,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "dot context error")) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-dot+ (go DOTS)) (#.+char-attr-delimiter+ (%reader-error stream "dot context error")) @@ -900,7 +942,7 @@ (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (setq possibly-float t) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-sign+ (go EXPTSIGN)) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) @@ -912,7 +954,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-escape+ (go ESCAPE)) @@ -923,7 +965,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) @@ -936,7 +978,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class2 char attribute-table) + (case (char-class2 char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RATIODIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-escape+ (go ESCAPE)) @@ -947,7 +989,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio stream))) - (case (char-class2 char attribute-table) + (case (char-class2 char attribute-array attribute-hash-table) (#.+char-attr-constituent-digit+ (go RATIODIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) @@ -960,7 +1002,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "too many dots")) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-constituent-dot+ (go DOTS)) (#.+char-attr-delimiter+ (unread-char char stream) @@ -978,7 +1020,7 @@ (ouch-read-buffer char) (setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-escape+ (done-with-fast-read-char) (go ESCAPE)) (#.+char-attr-delimiter+ (done-with-fast-read-char) @@ -995,7 +1037,7 @@ (ouch-read-buffer char) (setq char (read-char stream nil :eof)) (when (eq char :eof) (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) @@ -1012,7 +1054,7 @@ (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) @@ -1027,7 +1069,7 @@ (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) @@ -1054,7 +1096,7 @@ (setq escapes ()) (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream @@ -1069,7 +1111,7 @@ (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) - (case (char-class char attribute-table) + (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream @@ -1322,7 +1364,7 @@ ;;;; cruft for dispatch macros (defun make-char-dispatch-table () - (make-array char-code-limit :initial-element #'dispatch-char-error)) + (make-hash-table)) (defun dispatch-char-error (stream sub-char ignore) (declare (ignore ignore)) @@ -1361,9 +1403,7 @@ (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair - (setf (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (coerce function 'function)) + (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) (error "~S is not a dispatch char." disp-char)))) (defun get-dispatch-macro-character (disp-char sub-char @@ -1376,14 +1416,7 @@ (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair - (let ((dispatch-fun (elt (the simple-vector (cdr dpair)) - (char-code sub-char)))) - ;; Digits are also initialized in a dispatch table to - ;; #'dispatch-char-error; READ-DISPATCH-CHAR handles them - ;; separately. - CSR, 2002-04-12 - (if (eq dispatch-fun #'dispatch-char-error) - nil - dispatch-fun)) + (values (gethash sub-char (cdr dpair))) (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) @@ -1407,8 +1440,7 @@ :test #'char= :key #'car))) (if dpair (funcall (the function - (elt (the simple-vector (cdr dpair)) - (char-code sub-char))) + (gethash sub-char (cdr dpair) #'dispatch-char-error)) stream sub-char (if numargp numarg nil)) (%reader-error stream "no dispatch table for dispatch char"))))) @@ -1432,10 +1464,10 @@ (start start) (end (%check-vector-sequence-bounds string start end))) (unless *read-from-string-spares* - (push (internal-make-string-input-stream "" 0 0) - *read-from-string-spares*)) + (push (make-string-input-stream "" 0 0) *read-from-string-spares*)) (let ((stream (pop *read-from-string-spares*))) - (setf (string-input-stream-string stream) string) + (setf (string-input-stream-string stream) + (coerce string '(simple-array character (*)))) (setf (string-input-stream-current stream) start) (setf (string-input-stream-end stream) end) (unwind-protect --- orig/src/compiler/generic/vm-array.lisp +++ mod/src/compiler/generic/vm-array.lisp @@ -68,9 +68,13 @@ ;; (SIMPLE-BASE-STRINGs are stored with an extra ;; trailing #\NULL for convenience in calling out ;; to C.) - :n-pad-elements 1 + :n-pad-elements 1 :complex-typecode #.sb!vm:complex-base-string-widetag :importance 17) + (character ,(code-char 0) 32 simple-character-string + :n-pad-elements 1 + :complex-typecode #.sb!vm:complex-character-string-widetag + :importance 17) (single-float 0.0f0 32 simple-array-single-float :importance 6) (double-float 0.0d0 64 simple-array-double-float --- orig/src/compiler/x86/vm.lisp +++ mod/src/compiler/x86/vm.lisp @@ -182,7 +182,7 @@ ;; the non-descriptor stacks (signed-stack stack) ; (signed-byte 32) (unsigned-stack stack) ; (unsigned-byte 32) - (base-char-stack stack) ; non-descriptor characters. + (character-stack stack) ; non-descriptor characters. (sap-stack stack) ; System area pointers. (single-stack stack) ; single-floats (double-stack stack :element-size 2) ; double-floats. @@ -228,12 +228,12 @@ :alternate-scs (control-stack)) ;; non-descriptor characters - (base-char-reg registers - :locations #.*byte-regs* - :reserve-locations (#.ah-offset #.al-offset) + (character-reg registers + :locations #.*dword-regs* +; :reserve-locations (#.ah-offset #.al-offset) :constant-scs (immediate) :save-p t - :alternate-scs (base-char-stack)) + :alternate-scs (character-stack)) ;; non-descriptor SAPs (arbitrary pointers into address space) (sap-reg registers @@ -322,11 +322,12 @@ (catch-block stack :element-size kludge-nondeterministic-catch-block-size)) (eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter *byte-sc-names* '(base-char-reg byte-reg base-char-stack)) +(defparameter *byte-sc-names* '(byte-reg)) (defparameter *word-sc-names* '(word-reg)) (defparameter *dword-sc-names* '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack - signed-stack unsigned-stack sap-stack single-stack constant)) + signed-stack unsigned-stack sap-stack single-stack + character-reg character-stack constant)) ;;; added by jrd. I guess the right thing to do is to treat floats ;;; as a separate size... ;;; @@ -450,6 +451,10 @@ ;;; 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-base-string name)) + (declare (type string name)) ;; ELF ports currently don't need any prefix - name) + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name)))))) --- orig/src/code/readtable.lisp +++ mod/src/code/readtable.lisp @@ -12,7 +12,7 @@ (in-package "SB!IMPL") (sb!xc:deftype attribute-table () - '(simple-array (unsigned-byte 8) (#.sb!xc:char-code-limit))) + '(simple-array (unsigned-byte 8) (#.base-char-code-limit))) ;;; constants for readtable character attributes. These are all as in ;;; the manual. @@ -58,20 +58,22 @@ ;; In order to make READ-TOKEN fast, all this information is stored ;; in the character attribute table by having different varieties of ;; constituents. - (character-attribute-table - (make-array sb!xc:char-code-limit + (character-attribute-array + (make-array base-char-code-limit :element-type '(unsigned-byte 8) :initial-element +char-attr-constituent+) :type attribute-table) + (character-attribute-hash-table (make-hash-table) :type hash-table) ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT ;; functions. One of these functions called with appropriate ;; arguments whenever any non-WHITESPACE character is encountered ;; inside READ-PRESERVING-WHITESPACE. These functions are used to ;; implement user-defined read-macros, system read-macros, and the ;; number-symbol reader. - (character-macro-table - (make-array sb!xc:char-code-limit :initial-element #'undefined-macro-char) - :type (simple-vector #.sb!xc:char-code-limit)) + (character-macro-array + (make-array base-char-code-limit :initial-element #'undefined-macro-char) + :type (simple-vector #.base-char-code-limit)) + (character-macro-hash-table (make-hash-table) :type hash-table) ;; an alist from dispatch characters to vectors of CHAR-CODE-LIMIT ;; functions, for use in defining dispatching macros (like #-macro) (dispatch-tables () :type list) --- orig/src/code/run-program.lisp +++ mod/src/code/run-program.lisp @@ -289,12 +289,12 @@ (defun find-a-pty () (dolist (char '(#\p #\q)) (dotimes (digit 16) - (let* ((master-name (format nil "/dev/pty~C~X" char digit)) + (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) (master-fd (sb-unix:unix-open master-name sb-unix:o_rdwr #o666))) (when master-fd - (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) (slave-fd (sb-unix:unix-open slave-name sb-unix:o_rdwr #o666))) @@ -347,7 +347,9 @@ (declare (simple-string s)) (let ((n (length s))) ;; Blast the string into place. - (sb-kernel:copy-to-system-area (the simple-string s) + (sb-kernel:copy-to-system-area (the simple-base-string + ;; FIXME + (coerce s 'simple-base-string)) (* sb-vm:vector-data-offset sb-vm:n-word-bits) string-sap 0 @@ -382,6 +384,7 @@ ;;; Is UNIX-FILENAME the name of a file that we can execute? (defun unix-filename-is-executable-p (unix-filename) (declare (type simple-string unix-filename)) + (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) (sb-unix:unix-access unix-filename sb-unix:x_ok)))) @@ -614,7 +617,7 @@ ;;; stream. (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) - (let ((string (make-string 256)) + (let ((string (make-string 256 :element-type 'base-char)) handler) (setf handler (sb-sys:add-fd-handler @@ -683,7 +686,7 @@ ;; Use /dev/null. (multiple-value-bind (fd errno) - (sb-unix:unix-open "/dev/null" + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) (case direction (:input sb-unix:o_rdonly) (:output sb-unix:o_wronly) @@ -735,7 +738,7 @@ (dotimes (count 256 (error "could not open a temporary file in /tmp")) - (let* ((name (format nil "/tmp/.run-program-~D" count)) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) (fd (sb-unix:unix-open name (logior sb-unix:o_rdwr sb-unix:o_creat --- orig/src/compiler/generic/vm-typetran.lisp +++ mod/src/compiler/generic/vm-typetran.lisp @@ -17,9 +17,9 @@ ;;; 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 character-string-p (vector character)) (define-type-predicate complex-double-float-p (complex double-float)) (define-type-predicate complex-single-float-p (complex single-float)) #!+long-float @@ -93,6 +93,7 @@ (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 simple-character-string-p (simple-array character (*))) (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)) --- orig/version.lisp-expr +++ mod/version.lisp-expr @@ -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.16" +"0.8.16.character_branch.1" --- orig/src/code/error.lisp +++ mod/src/code/error.lisp @@ -32,7 +32,7 @@ :datum arguments :expected-type 'null :format-control "You may not supply additional arguments ~ - when giving ~S to ~S." + when giving ~S to ~S." :format-arguments (list datum fun-name))) datum) ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) @@ -75,8 +75,8 @@ (source :initarg :source :reader program-error-source)) (:report (lambda (condition stream) (format stream "Execution of a form compiled with errors.~%~ - Form:~% ~A~%~ - Compile-time-error:~% ~A" + Form:~% ~A~%~ + Compile-time-error:~% ~A" (program-error-source condition) (program-error-message condition))))) --- orig/src/code/query.lisp +++ mod/src/code/query.lisp @@ -18,8 +18,7 @@ (defun query-read-line () (force-output *query-io*) - (string-trim #.(concatenate 'string '(#\Space #\Tab)) - (read-line *query-io*))) + (string-trim " " (read-line *query-io*))) (defun maybe-print-query (hint format-string &rest format-args) (fresh-line *query-io*) --- orig/src/code/char.lisp +++ mod/src/code/char.lisp @@ -12,6 +12,8 @@ (in-package "SB!IMPL") -(def!constant sb!xc:char-code-limit 256 +(def!constant sb!xc:char-code-limit #x110000 #!+sb-doc "the upper exclusive bound on values produced by CHAR-CODE") + +(def!constant base-char-code-limit 128) --- orig/src/code/typecheckfuns.lisp +++ mod/src/code/typecheckfuns.lisp @@ -199,7 +199,11 @@ (member-type-p ctype) (numeric-type-p ctype) (array-type-p ctype) - (cons-type-p ctype)))) + (cons-type-p ctype) + (intersection-type-p ctype) + (union-type-p ctype) + (negation-type-p ctype) + (character-range-type-p ctype)))) ;;; Evaluate (at load/execute time) to a function which checks that ;;; its argument is of the specified type. --- orig/src/runtime/gencgc.c +++ mod/src/runtime/gencgc.c @@ -2057,11 +2057,11 @@ /* Is it plausible cons? */ if ((is_lisp_pointer(start_addr[0]) || (fixnump(start_addr[0])) - || (widetag_of(start_addr[0]) == BASE_CHAR_WIDETAG) + || (widetag_of(start_addr[0]) == CHARACTER_WIDETAG) || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG)) && (is_lisp_pointer(start_addr[1]) || (fixnump(start_addr[1])) - || (widetag_of(start_addr[1]) == BASE_CHAR_WIDETAG) + || (widetag_of(start_addr[1]) == CHARACTER_WIDETAG) || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG))) break; else { @@ -2107,7 +2107,7 @@ } switch (widetag_of(start_addr[0])) { case UNBOUND_MARKER_WIDETAG: - case BASE_CHAR_WIDETAG: + case CHARACTER_WIDETAG: if (gencgc_verbose) FSHOW((stderr, "*Wo3: %x %x %x\n", @@ -2145,6 +2145,7 @@ #endif case SIMPLE_ARRAY_WIDETAG: case COMPLEX_BASE_STRING_WIDETAG: + case COMPLEX_CHARACTER_STRING_WIDETAG: case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_BIT_VECTOR_WIDETAG: case COMPLEX_VECTOR_WIDETAG: @@ -2160,6 +2161,7 @@ case LONG_FLOAT_WIDETAG: #endif case SIMPLE_BASE_STRING_WIDETAG: + case SIMPLE_CHARACTER_STRING_WIDETAG: case SIMPLE_BIT_VECTOR_WIDETAG: case SIMPLE_ARRAY_NIL_WIDETAG: case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: @@ -2248,6 +2250,7 @@ break; case BIGNUM_WIDETAG: case SIMPLE_BASE_STRING_WIDETAG: + case SIMPLE_CHARACTER_STRING_WIDETAG: case SIMPLE_BIT_VECTOR_WIDETAG: case SIMPLE_ARRAY_NIL_WIDETAG: case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: @@ -3111,6 +3114,7 @@ case COMPLEX_WIDETAG: case SIMPLE_ARRAY_WIDETAG: case COMPLEX_BASE_STRING_WIDETAG: + case COMPLEX_CHARACTER_STRING_WIDETAG: case COMPLEX_VECTOR_NIL_WIDETAG: case COMPLEX_BIT_VECTOR_WIDETAG: case COMPLEX_VECTOR_WIDETAG: @@ -3119,7 +3123,7 @@ case FUNCALLABLE_INSTANCE_HEADER_WIDETAG: case VALUE_CELL_HEADER_WIDETAG: case SYMBOL_HEADER_WIDETAG: - case BASE_CHAR_WIDETAG: + case CHARACTER_WIDETAG: case UNBOUND_MARKER_WIDETAG: case INSTANCE_HEADER_WIDETAG: case FDEFN_WIDETAG: @@ -3197,6 +3201,7 @@ case COMPLEX_LONG_FLOAT_WIDETAG: #endif case SIMPLE_BASE_STRING_WIDETAG: + case SIMPLE_CHARACTER_STRING_WIDETAG: case SIMPLE_BIT_VECTOR_WIDETAG: case SIMPLE_ARRAY_NIL_WIDETAG: case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: --- orig/src/code/array.lisp +++ mod/src/code/array.lisp @@ -93,6 +93,8 @@ (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)) ((base-char standard-char) (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) + ((character) + (values #.sb!vm:simple-character-string-widetag #.sb!vm:n-word-bits)) ((bit) (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. @@ -112,6 +114,8 @@ #.sb!vm:complex-vector-widetag) ((base-char) #.sb!vm:complex-base-string-widetag) + ((character) + #.sb!vm:complex-character-string-widetag) ((nil) #.sb!vm:complex-vector-nil-widetag) ((bit) @@ -121,6 +125,7 @@ (pick-vector-type type (nil #.sb!vm:complex-vector-nil-widetag) (base-char #.sb!vm:complex-base-string-widetag) + (character #.sb!vm:complex-character-string-widetag) (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) @@ -148,7 +153,8 @@ (array (allocate-vector type length - (ceiling (* (if (= type sb!vm:simple-base-string-widetag) + (ceiling (* (if (or (= type sb!vm:simple-base-string-widetag) + (= type sb!vm:simple-character-string-widetag)) (1+ length) length) n-bits) @@ -158,13 +164,13 @@ (fill array initial-element)) (when initial-contents-p (when initial-element-p - (error "can't specify both :INITIAL-ELEMENT and ~ - :INITIAL-CONTENTS")) - (unless (= length (length initial-contents)) - (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ - the vector length is ~W." - (length initial-contents) - length)) + (error "can't specify both :INITIAL-ELEMENT and ~ + :INITIAL-CONTENTS")) + (unless (= length (length initial-contents)) + (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ + the vector length is ~W." + (length initial-contents) + length)) (replace array initial-contents)) array)) ;; it's either a complex array or a multidimensional array. @@ -205,7 +211,7 @@ (cond (displaced-to (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ - can be specified along with :DISPLACED-TO")) + can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -229,7 +235,7 @@ initial-element initial-element-p) (when (and initial-contents-p initial-element-p) (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to - either MAKE-ARRAY or ADJUST-ARRAY.")) + either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p (make-array total-size :element-type element-type @@ -254,13 +260,13 @@ (incf index)) (t (unless (typep contents 'sequence) - (error "malformed :INITIAL-CONTENTS: ~S is not a ~ - sequence, but ~W more layer~:P needed." + (error "malformed :INITIAL-CONTENTS: ~S is not a ~ + sequence, but ~W more layer~:P needed." contents (- (length dimensions) axis))) (unless (= (length contents) (car dims)) - (error "malformed :INITIAL-CONTENTS: Dimension of ~ - axis ~W is ~W, but ~S is ~W long." + (error "malformed :INITIAL-CONTENTS: Dimension of ~ + axis ~W is ~W, but ~S is ~W long." axis (car dims) contents (length contents))) (if (listp contents) (dolist (content contents) @@ -708,8 +714,8 @@ (cond (initial-contents-p ;; array former contents replaced by INITIAL-CONTENTS (if (or initial-element-p displaced-to) - (error "INITIAL-CONTENTS may not be specified with ~ - the :INITIAL-ELEMENT or :DISPLACED-TO option.")) + (error "INITIAL-CONTENTS may not be specified with ~ + the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type @@ -729,11 +735,11 @@ (displaced-to ;; We already established that no INITIAL-CONTENTS was supplied. (when initial-element - (error "The :INITIAL-ELEMENT option may not be specified ~ - with :DISPLACED-TO.")) - (unless (subtypep element-type (array-element-type displaced-to)) - (error "can't displace an array of type ~S into another of ~ - type ~S" + (error "The :INITIAL-ELEMENT option may not be specified ~ + with :DISPLACED-TO.")) + (unless (subtypep element-type (array-element-type displaced-to)) + (error "can't displace an array of type ~S into another of ~ + type ~S" element-type (array-element-type displaced-to))) (let ((displacement (or displaced-index-offset 0)) (array-size (apply #'* dimensions))) @@ -813,19 +819,19 @@ (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ - smaller than its fill pointer (~S)" + smaller than its fill pointer (~S)" old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) ((not (array-has-fill-pointer-p old-array)) (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ - in ADJUST-ARRAY unless the array (~S) was originally ~ - created with a fill pointer" + in ADJUST-ARRAY unless the array (~S) was originally ~ + created with a fill pointer" fill-pointer old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ - than the new length of the vector (~S)" + than the new length of the vector (~S)" fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) @@ -854,7 +860,8 @@ ,@(map 'list (lambda (saetp) `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) - ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char) + ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character) + (eq (sb!vm:saetp-specifier saetp) 'base-char)) *default-init-char-form* (sb!vm:saetp-initial-element-default saetp)))) (remove-if-not @@ -995,10 +1002,10 @@ #!+sb-doc ,(format nil "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ - BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ - If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ - RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ - All the arrays must have the same rank and dimensions." + BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ + If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ + RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ + All the arrays must have the same rank and dimensions." (symbol-name function)) (declare (type (array bit) bit-array-1 bit-array-2) (type (or (array bit) (member t nil)) result-bit-array)) --- orig/src/code/toplevel.lisp +++ mod/src/code/toplevel.lisp @@ -421,6 +421,7 @@ (probe-init-files (explicitly-specified-init-file-name &rest default-init-file-names) (declare (type list default-init-file-names)) + (/show0 "in PROBE-INIT-FILES") (if explicitly-specified-init-file-name (or (probe-file explicitly-specified-init-file-name) (startup-error "The file ~S was not found." @@ -431,6 +432,7 @@ ;; shared idiom for creating default names for ;; SYSINITish and USERINITish files (init-file-name (maybe-dir-name basename) + (/show0 "in INIT-FILE-NAME") (and maybe-dir-name (concatenate 'string maybe-dir-name "/" basename)))) (let ((sysinit-truename --- orig/src/code/room.lisp +++ mod/src/code/room.lisp @@ -72,7 +72,8 @@ :kind :fixed :length size)))))) -(dolist (code (list complex-base-string-widetag simple-array-widetag +(dolist (code (list complex-character-string-widetag + complex-base-string-widetag simple-array-widetag complex-bit-vector-widetag complex-vector-widetag complex-array-widetag complex-vector-nil-widetag)) (setf (svref *meta-room-info* code) @@ -122,6 +123,11 @@ :kind :string :length 0)) +(setf (svref *meta-room-info* simple-character-string-widetag) + (make-room-info :name 'simple-character-string + :kind :string + :length 2)) + (setf (svref *meta-room-info* simple-array-nil-widetag) (make-room-info :name 'simple-array-nil :kind :fixed @@ -176,11 +182,11 @@ ;;; Return the total size of a vector in bytes, including any pad. #!-sb-fluid (declaim (inline vector-total-size)) (defun vector-total-size (obj info) - (let ((shift (room-info-length info)) - (len (+ (length (the (simple-array * (*)) obj)) - (ecase (room-info-kind info) - (:vector 0) - (:string 1))))) + (let* ((shift (room-info-length info)) + (len (+ (length (the (simple-array * (*)) obj)) + (ecase (room-info-kind info) + (:vector 0) + (:string 1))))) (declare (type (integer -3 3) shift)) (round-to-dualword (+ (* vector-data-offset n-word-bytes) @@ -246,7 +252,7 @@ (size (ecase (room-info-kind info) (:fixed (aver (or (eql (room-info-length info) - (1+ (get-header-data obj))) + (1+ (get-header-data obj))) (floatp obj) (simple-array-nil-p obj))) (round-to-dualword @@ -467,6 +473,7 @@ #.single-float-widetag #.double-float-widetag #.simple-base-string-widetag + #.simple-character-string-widetag #.simple-array-nil-widetag #.simple-bit-vector-widetag #.simple-array-unsigned-byte-2-widetag --- orig/src/compiler/target-disassem.lisp +++ mod/src/compiler/target-disassem.lisp @@ -949,7 +949,7 @@ (file-position f char-offset)) (t (warn "Source file ~S has been modified; ~@ - using form offset instead of ~ + using form offset instead of ~ file index." name) (let ((*read-suppress* t)) @@ -995,7 +995,7 @@ nil) ((> form-number (length mapping-table)) (warn "bogus form-number in form! The source file has probably ~@ - been changed too much to cope with.") + been changed too much to cope with.") (when cache ;; Disable future warnings. (setf (sfcache-toplevel-form cache) nil)) --- orig/src/runtime/gc-common.c +++ mod/src/runtime/gc-common.c @@ -779,6 +779,56 @@ } static int +size_character_string(lispobj *where) +{ + struct vector *vector; + int length, nwords; + + /* NOTE: A string contains one more byte of data (a terminating + * '\0' to help when interfacing with C functions) than indicated + * by the length slot. */ + + vector = (struct vector *) where; + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return nwords; +} + +scav_character_string(lispobj *where, lispobj object) +{ + struct vector *vector; + int length, nwords; + + /* NOTE: Strings contain one more byte of data than the length */ + /* slot indicates. */ + + vector = (struct vector *) where; + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return nwords; +} +static lispobj +trans_character_string(lispobj object) +{ + struct vector *vector; + int length, nwords; + + gc_assert(is_lisp_pointer(object)); + + /* NOTE: A string contains one more byte of data (a terminating + * '\0' to help when interfacing with C functions) than indicated + * by the length slot. */ + + vector = (struct vector *) native_pointer(object); + length = fixnum_value(vector->length) + 1; + nwords = CEILING(NWORDS(length, 32) + 2, 2); + + return copy_large_unboxed_object(object, nwords); +} + +static int size_base_string(lispobj *where) { struct vector *vector; @@ -1550,6 +1600,7 @@ #endif scavtab[SIMPLE_ARRAY_WIDETAG] = scav_boxed; scavtab[SIMPLE_BASE_STRING_WIDETAG] = scav_base_string; + scavtab[SIMPLE_CHARACTER_STRING_WIDETAG] = scav_character_string; scavtab[SIMPLE_BIT_VECTOR_WIDETAG] = scav_vector_bit; scavtab[SIMPLE_ARRAY_NIL_WIDETAG] = scav_vector_nil; scavtab[SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG] = @@ -1625,6 +1676,7 @@ scav_vector_complex_long_float; #endif scavtab[COMPLEX_BASE_STRING_WIDETAG] = scav_boxed; + scavtab[COMPLEX_CHARACTER_STRING_WIDETAG] = scav_boxed; scavtab[COMPLEX_VECTOR_NIL_WIDETAG] = scav_boxed; scavtab[COMPLEX_BIT_VECTOR_WIDETAG] = scav_boxed; scavtab[COMPLEX_VECTOR_WIDETAG] = scav_boxed; @@ -1643,7 +1695,7 @@ #endif scavtab[VALUE_CELL_HEADER_WIDETAG] = scav_boxed; scavtab[SYMBOL_HEADER_WIDETAG] = scav_boxed; - scavtab[BASE_CHAR_WIDETAG] = scav_immediate; + scavtab[CHARACTER_WIDETAG] = scav_immediate; scavtab[SAP_WIDETAG] = scav_unboxed; scavtab[UNBOUND_MARKER_WIDETAG] = scav_immediate; scavtab[INSTANCE_HEADER_WIDETAG] = scav_boxed; @@ -1675,6 +1727,7 @@ #endif transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed; /* but not GENCGC */ transother[SIMPLE_BASE_STRING_WIDETAG] = trans_base_string; + transother[SIMPLE_CHARACTER_STRING_WIDETAG] = trans_character_string; transother[SIMPLE_BIT_VECTOR_WIDETAG] = trans_vector_bit; transother[SIMPLE_VECTOR_WIDETAG] = trans_vector; transother[SIMPLE_ARRAY_NIL_WIDETAG] = trans_vector_nil; @@ -1755,6 +1808,7 @@ trans_vector_complex_long_float; #endif transother[COMPLEX_BASE_STRING_WIDETAG] = trans_boxed; + transother[COMPLEX_CHARACTER_STRING_WIDETAG] = trans_boxed; transother[COMPLEX_BIT_VECTOR_WIDETAG] = trans_boxed; transother[COMPLEX_VECTOR_NIL_WIDETAG] = trans_boxed; transother[COMPLEX_VECTOR_WIDETAG] = trans_boxed; @@ -1766,7 +1820,7 @@ transother[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = trans_boxed; transother[VALUE_CELL_HEADER_WIDETAG] = trans_boxed; transother[SYMBOL_HEADER_WIDETAG] = trans_boxed; - transother[BASE_CHAR_WIDETAG] = trans_immediate; + transother[CHARACTER_WIDETAG] = trans_immediate; transother[SAP_WIDETAG] = trans_unboxed; transother[UNBOUND_MARKER_WIDETAG] = trans_immediate; transother[WEAK_POINTER_WIDETAG] = trans_weak_pointer; @@ -1805,6 +1859,7 @@ #endif sizetab[SIMPLE_ARRAY_WIDETAG] = size_boxed; sizetab[SIMPLE_BASE_STRING_WIDETAG] = size_base_string; + sizetab[SIMPLE_CHARACTER_STRING_WIDETAG] = size_character_string; sizetab[SIMPLE_BIT_VECTOR_WIDETAG] = size_vector_bit; sizetab[SIMPLE_VECTOR_WIDETAG] = size_vector; sizetab[SIMPLE_ARRAY_NIL_WIDETAG] = size_vector_nil; @@ -1881,6 +1936,7 @@ size_vector_complex_long_float; #endif sizetab[COMPLEX_BASE_STRING_WIDETAG] = size_boxed; + sizetab[COMPLEX_CHARACTER_STRING_WIDETAG] = size_boxed; sizetab[COMPLEX_VECTOR_NIL_WIDETAG] = size_boxed; sizetab[COMPLEX_BIT_VECTOR_WIDETAG] = size_boxed; sizetab[COMPLEX_VECTOR_WIDETAG] = size_boxed; @@ -1895,7 +1951,7 @@ sizetab[FUNCALLABLE_INSTANCE_HEADER_WIDETAG] = size_boxed; sizetab[VALUE_CELL_HEADER_WIDETAG] = size_boxed; sizetab[SYMBOL_HEADER_WIDETAG] = size_boxed; - sizetab[BASE_CHAR_WIDETAG] = size_immediate; + sizetab[CHARACTER_WIDETAG] = size_immediate; sizetab[SAP_WIDETAG] = size_unboxed; sizetab[UNBOUND_MARKER_WIDETAG] = size_immediate; sizetab[WEAK_POINTER_WIDETAG] = size_weak_pointer; --- orig/src/code/target-format.lisp +++ mod/src/code/target-format.lisp @@ -76,8 +76,11 @@ (multiple-value-bind (new-directives new-args) (let* ((character (format-directive-character directive)) (function - (svref *format-directive-interpreters* - (char-code character))) + (typecase character + (base-char + (svref *format-directive-interpreters* + (char-code character))) + (character nil))) (*default-format-error-offset* (1- (format-directive-end directive)))) (unless function @@ -835,7 +838,7 @@ (setf args (nthcdr posn orig-args)) (error 'format-error :complaint "Index ~W is out of bounds. (It should ~ - have been between 0 and ~W.)" + have been between 0 and ~W.)" :args (list posn (length orig-args)))))) (if colonp (interpret-bind-defaults ((n 1)) params @@ -848,7 +851,7 @@ (error 'format-error :complaint "Index ~W is out of bounds. (It should - have been between 0 and ~W.)" + have been between 0 and ~W.)" :args (list new-posn (length orig-args)))))))) (interpret-bind-defaults ((n 1)) params --- orig/make-host-1.sh +++ mod/make-host-1.sh @@ -43,6 +43,9 @@ (when (find :sb-test *shebang-features*) (load "tests/type.before-xc.lisp") (load "tests/info.before-xc.lisp")) + (load "tools-for-build/ucd.lisp") + (sb-cold::slurp-ucd) + (sb-cold::output) (host-cload-stem "src/compiler/generic/genesis") (sb!vm:genesis :c-header-dir-name "src/runtime/genesis") #+cmu (ext:quit) --- orig/src/compiler/generic/primtype.lisp +++ mod/src/compiler/generic/primtype.lisp @@ -66,7 +66,7 @@ ;;; other primitive immediate types (/show0 "primtype.lisp 68") -(!def-primitive-type base-char (base-char-reg any-reg)) +(!def-primitive-type character (character-reg any-reg)) ;;; primitive pointer types (/show0 "primtype.lisp 73") @@ -304,6 +304,13 @@ (ecase (named-type-name type) ((t *) (values *backend-t-primitive-type* t)) ((nil) (any)))) + (character-set-type + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (exactly character) + (part-of character)))) (built-in-classoid (case (classoid-name type) ((complex function instance @@ -311,8 +318,6 @@ (values (primitive-type-or-lose (classoid-name type)) t)) (funcallable-instance (part-of function)) - (base-char - (exactly base-char)) (cons-type (part-of list)) (t --- orig/src/code/cold-init.lisp +++ mod/src/code/cold-init.lisp @@ -111,6 +111,8 @@ ;; this to be initialized, so we initialize it right away. (show-and-call !random-cold-init) + (show-and-call !character-database-cold-init) + (show-and-call !early-package-cold-init) (show-and-call !package-cold-init) @@ -313,7 +315,7 @@ (defun hexstr (thing) (/noshow0 "entering HEXSTR") (let ((addr (get-lisp-obj-address thing)) - (str (make-string 10))) + (str (make-string 10 :element-type 'base-char))) (/noshow0 "ADDR and STR calculated") (setf (char str 0) #\0 (char str 1) #\x) --- orig/src/compiler/target-dump.lisp +++ mod/src/compiler/target-dump.lisp @@ -13,6 +13,21 @@ (in-package "SB!FASL") +;;; a helper function shared by DUMP-SIMPLE-CHARACTER-STRING and +;;; DUMP-SYMBOL (in the target compiler: the cross-compiler uses the +;;; portability knowledge and always dumps BASE-STRINGS). +(defun dump-characters-of-string (s fasl-output) + (declare (type string s) (type fasl-output fasl-output)) + (dovector (c s) + (dump-word (char-code c) fasl-output)) + (values)) + +(defun dump-simple-character-string (s file) + (declare (type (simple-array character (*)) s)) + (dump-fop* (length s) fop-small-character-string fop-character-string file) + (dump-characters-of-string s file) + (values)) + ;;; Dump the first N bytes of VEC out to FILE. VEC is some sort of unboxed ;;; vector-like thing that we can BLT from. (defun dump-raw-bytes (vec n fasl-output) --- orig/src/code/pprint.lisp +++ mod/src/code/pprint.lisp @@ -119,7 +119,7 @@ (defun pretty-out (stream char) (declare (type pretty-stream stream) - (type base-char char)) + (type character char)) (cond ((char= char #\newline) (enqueue-newline stream :literal)) (t @@ -662,15 +662,15 @@ *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do nothing if not. KIND can be one of: :LINEAR - A line break is inserted if and only if the immediatly - containing section cannot be printed on one line. + containing section cannot be printed on one line. :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. - (See *PRINT-MISER-WIDTH*.) + (See *PRINT-MISER-WIDTH*.) :FILL - A line break is inserted if and only if either: (a) the following section cannot be printed on the end of the - current line, + current line, (b) the preceding section was not printed on a single line, or (c) the immediately containing section cannot be printed on one - line and miser-style is in effect. + line and miser-style is in effect. :MANDATORY - A line break is always inserted. When a line break is inserted by any type of conditional newline, any blanks that immediately precede the conditional newline are ommitted @@ -694,7 +694,7 @@ and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: :BLOCK - Indent relative to the column the current logical block - started on. + started on. :CURRENT - Indent relative to the current column. The new indentation value does not take effect until the following line break." --- orig/package-data-list.lisp-expr +++ mod/package-data-list.lisp-expr @@ -63,6 +63,7 @@ "SAP-ALIEN" "SHORT" "SIGNED" "SLOT" "STRUCT" "UNSIGNED" "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT" + "UTF8-STRING" "VOID" "WITH-ALIEN")) @@ -902,7 +903,7 @@ ;; various internal defaults "DEFAULT-INIT-CHAR" "*DEFAULT-INIT-CHAR-FORM*" - "*LOAD-SOURCE-DEFAULT-TYPE*" + "*LOAD-SOURCE-DEFAULT-TYPE*" "BASE-CHAR-CODE-LIMIT" ;; hash caches "DEFINE-HASH-CACHE" @@ -1118,7 +1119,11 @@ "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX" "BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE" "BOUNDING-INDICES-BAD-ERROR" "BYTE-SPECIFIER" "%BYTE-BLT" - "CALLABLE" "CASE-BODY-ERROR" "CHARPOS" + "CALLABLE" "CASE-BODY-ERROR" + "CHARACTER-SET" "CHARACTER-SET-TYPE" + "CHARACTER-SET-TYPE-PAIRS" + "CHARACTER-STRING-P" + "CHARPOS" "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME" "CODE-COMPONENT" "CODE-COMPONENT-P" "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-INSTRUCTIONS" @@ -1150,6 +1155,7 @@ "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE" "EFFECTIVE-FIND-POSITION-TEST" "EFFECTIVE-FIND-POSITION-KEY" "ERROR-NUMBER-OR-LOSE" + "EXTENDED-CHAR-P" "FAILED-%WITH-ARRAY-DATA" "FDEFINITION-OBJECT" "FDOCUMENTATION" "FILENAME" "FIND-AND-INIT-OR-CHECK-LAYOUT" "FLOAT-EXPONENT" @@ -1218,9 +1224,10 @@ "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" "NUMERIC-TYPE-EQUAL" "NUMERIC-TYPE-FORMAT" "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" - "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR" + "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-CHARACTER-ERROR" "OBJECT-NOT-BASE-STRING-ERROR" "OBJECT-NOT-BIGNUM-ERROR" - "OBJECT-NOT-BIT-VECTOR-ERROR" "OBJECT-NOT-COMPLEX-ERROR" + "OBJECT-NOT-BIT-VECTOR-ERROR" + "OBJECT-NOT-CHARACTER-STRING-ERROR" "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-COMPLEX-FLOAT-ERROR" "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR" #!+long-float "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR" @@ -1286,6 +1293,7 @@ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR" "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR" "OBJECT-NOT-SIMPLE-BASE-STRING-ERROR" + "OBJECT-NOT-SIMPLE-CHARACTER-STRING-ERROR" "OBJECT-NOT-SIMPLE-STRING-ERROR" "OBJECT-NOT-SIMPLE-VECTOR-ERROR" "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR" @@ -1294,7 +1302,9 @@ "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR" ;; FIXME: 32/64-bit issues "OBJECT-NOT-UNSIGNED-BYTE-64-ERROR" - "OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR" + "OBJECT-NOT-VECTOR-ERROR" + "OBJECT-NOT-VECTOR-NIL-ERROR" + "OBJECT-NOT-WEAK-POINTER-ERROR" "ODD-KEY-ARGS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" "PACKAGE-DESIGNATOR" "PACKAGE-DOC-STRING" "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" @@ -1341,6 +1351,7 @@ "SIMPLE-ARRAY-SIGNED-BYTE-61-P" "SIMPLE-ARRAY-SIGNED-BYTE-64-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P" + "SIMPLE-CHARACTER-STRING-P" "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND" @@ -1888,7 +1899,7 @@ "EUSERS" "EVICEERR" "EVICEOP" "EWOULDBLOCK" "EXDEV" "FD-ISSET" "FD-SET" "LTCHARS" "UNIX-FAST-SELECT" - "UNIX-FILE-KIND" "UNIX-KILL" + "UNIX-FILE-KIND" "UNIX-KILL" "CODESET" "TCSETPGRP" "FD-ZERO" "FD-CLR" "CHECK" "UNIX-RESOLVE-LINKS" "FD-SETSIZE" "TCGETPGRP" "UNIX-FAST-GETRUSAGE" "UNIX-SIMPLIFY-PATHNAME" "UNIX-KILLPG" @@ -1954,8 +1965,9 @@ "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT" - "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" "BASE-CHAR-REG-SC-NUMBER" - "BASE-CHAR-STACK-SC-NUMBER" "BASE-CHAR-WIDETAG" + "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" + "CHARACTER-REG-SC-NUMBER" + "CHARACTER-STACK-SC-NUMBER" "CHARACTER-WIDETAG" "BIGNUM-DIGITS-OFFSET" "BIGNUM-WIDETAG" "BINDING-SIZE" "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP" "N-BYTE-BITS" "BYTE-REG-SC-NUMBER" @@ -1984,7 +1996,8 @@ "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-BASE-STRING-WIDETAG" "COMPLEX-WIDETAG" + "COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" + "COMPLEX-CHARACTER-STRING-WIDETAG" "COMPLEX-WIDETAG" "COMPLEX-VECTOR-NIL-WIDETAG" "COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT" "CONS-SIZE" "CONSTANT-SC-NUMBER" @@ -2034,7 +2047,7 @@ "FUNCALLABLE-INSTANCE-LAYOUT-SLOT" "FUNCALLABLE-INSTANCE-LEXENV-SLOT" "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER" - "IMMEDIATE-BASE-CHAR-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER" + "IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER" "IMMEDIATE-SC-NUMBER" "*INITIAL-DYNAMIC-SPACE-FREE-POINTER*" "INSTANCE-HEADER-WIDETAG" "INSTANCE-POINTER-LOWTAG" "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" @@ -2124,6 +2137,7 @@ "SIMPLE-ARRAY-SIGNED-BYTE-8-WIDETAG" "SIMPLE-BIT-VECTOR-WIDETAG" "SIMPLE-BASE-STRING-WIDETAG" + "SIMPLE-CHARACTER-STRING-WIDETAG" "SIMPLE-VECTOR-WIDETAG" "SINGLE-FLOAT-BIAS" "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE" "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX" --- orig/src/code/target-pathname.lisp +++ mod/src/code/target-pathname.lisp @@ -44,11 +44,11 @@ (let ((namestring (handler-case (namestring pathname) (error nil)))) (if namestring - (format stream "#P~S" namestring) + (format stream "#P~S" (coerce namestring '(simple-array character (*)))) (print-unreadable-object (pathname stream :type t) (format stream "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ - ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" + ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" (%pathname-host pathname) (%pathname-device pathname) (%pathname-directory pathname) @@ -202,12 +202,12 @@ (or (eq thing wild) (eq wild :wild) (typecase thing - (simple-base-string + (simple-string ;; String is matched by itself, a matching pattern or :WILD. (typecase wild (pattern (values (pattern-matches wild thing))) - (simple-base-string + (simple-string (string= thing wild)))) (pattern ;; A pattern is only matched by an identical pattern. @@ -308,7 +308,7 @@ (dolist (x in) (when (check-for pred x) (return t)))) - (simple-base-string + (simple-string (dotimes (i (length in)) (when (funcall pred (schar in i)) (return t)))) @@ -319,7 +319,7 @@ (make-pattern (mapcar (lambda (piece) (typecase piece - (simple-base-string + (simple-string (funcall fun piece)) (cons (case (car piece) @@ -333,7 +333,7 @@ (pattern-pieces thing)))) (list (mapcar fun thing)) - (simple-base-string + (simple-string (funcall fun thing)) (t thing)))) @@ -385,6 +385,7 @@ (declare (type pathname-designator pathname) (type pathname-designator defaults) (values pathname)) + (/show0 "in MERGE-PATHNAMES") (with-pathname (defaults defaults) (let ((pathname (let ((*default-pathname-defaults* defaults)) (pathname pathname)))) @@ -692,7 +693,7 @@ :expected-type 'null :format-control "The host in the namestring, ~S,~@ - does not match the explicit HOST argument, ~S." + does not match the explicit HOST argument, ~S." :format-arguments (list new-host host))) (let ((pn-host (or new-host host (pathname-host defaults)))) (values (%make-maybe-logical-pathname @@ -702,7 +703,7 @@ ;;; If NAMESTR begins with a colon-terminated, defined, logical host, ;;; then return that host, otherwise return NIL. (defun extract-logical-host-prefix (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end) (values (or logical-host null))) (let ((colon-pos (position #\: namestr :start start :end end))) @@ -816,7 +817,7 @@ (let ((host (%pathname-host pathname))) (unless host (error "can't determine the namestring for pathnames with no ~ - host:~% ~S" pathname)) + host:~% ~S" pathname)) (funcall (host-unparse host) pathname))))) (defun host-namestring (pathname) @@ -924,7 +925,7 @@ (defun substitute-into (pattern subs diddle-case) (declare (type pattern pattern) (type list subs) - (values (or simple-base-string pattern) list)) + (values (or simple-string pattern) list)) (let ((in-wildcard nil) (pieces nil) (strings nil)) @@ -937,7 +938,7 @@ (setf in-wildcard t) (unless subs (error "not enough wildcards in FROM pattern to match ~ - TO pattern:~% ~S" + TO pattern:~% ~S" pattern)) (let ((sub (pop subs))) (typecase sub @@ -952,7 +953,7 @@ (push sub strings)) (t (error "can't substitute this into the middle of a word:~ - ~% ~S" + ~% ~S" sub))))))) (when strings @@ -969,7 +970,7 @@ ;;; Called when we can't see how source and from matched. (defun didnt-match-error (source from) (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@ - did not match:~% ~S ~S" + did not match:~% ~S ~S" source from)) ;;; Do TRANSLATE-COMPONENT for all components except host, directory @@ -1082,14 +1083,14 @@ (let ((match (pop subs-left))) (when (listp match) (error ":WILD-INFERIORS is not paired in from and to ~ - patterns:~% ~S ~S" from to)) + patterns:~% ~S ~S" from to)) (res (maybe-diddle-case match diddle-case)))) ((member :wild-inferiors) (aver subs-left) (let ((match (pop subs-left))) (unless (listp match) (error ":WILD-INFERIORS not paired in from and to ~ - patterns:~% ~S ~S" from to)) + patterns:~% ~S ~S" from to)) (dolist (x match) (res (maybe-diddle-case x diddle-case))))) (pattern @@ -1157,13 +1158,14 @@ (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) - (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-)) + (unless (and (typep ch 'standard-char) + (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))) (error 'namestring-parse-error :complaint "logical namestring character which ~ - is not alphanumeric or hyphen:~% ~S" + is not alphanumeric or hyphen:~% ~S" :args (list ch) :namestring word :offset i)))) - word)) + (coerce word 'base-string))) ;;; Given a logical host or string, return a logical host. If ERROR-P ;;; is NIL, then return NIL when no such host exists. @@ -1213,7 +1215,7 @@ (when (pattern) (error 'namestring-parse-error :complaint "double asterisk inside of logical ~ - word: ~S" + word: ~S" :args (list chunk) :namestring namestring :offset (+ (cdar chunks) pos))) @@ -1257,7 +1259,7 @@ ;;; Break up a logical-namestring, always a string, into its ;;; constituent parts. (defun parse-logical-namestring (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (collect ((directory)) (let ((host nil) @@ -1332,7 +1334,7 @@ (unless (and res (plusp res)) (error 'namestring-parse-error :complaint "expected a positive integer, ~ - got ~S" + got ~S" :args (list str) :namestring namestr :offset (+ pos (cdar chunks)))) @@ -1418,7 +1420,7 @@ (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) - (when (typep type 'simple-base-string) + (when (typep type 'simple-string) (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") @@ -1524,12 +1526,9 @@ (t (translate-logical-pathname (pathname pathname))))) (defvar *logical-pathname-defaults* - (%make-logical-pathname (make-logical-host :name "BOGUS") - :unspecific - nil - nil - nil - nil)) + (%make-logical-pathname + (make-logical-host :name (logical-word-or-lose "BOGUS")) + :unspecific nil nil nil nil)) (defun load-logical-pathname-translations (host) #!+sb-doc --- orig/src/runtime/gc-internal.h +++ mod/src/runtime/gc-internal.h @@ -94,7 +94,7 @@ /* If thing is an immediate then this is a cons. */ if (is_lisp_pointer(thing) || (fixnump(thing)) - || (widetag_of(thing) == BASE_CHAR_WIDETAG) + || (widetag_of(thing) == CHARACTER_WIDETAG) || (widetag_of(thing) == UNBOUND_MARKER_WIDETAG)) count = 2; else --- orig/src/compiler/ir1final.lisp +++ mod/src/compiler/ir1final.lisp @@ -42,7 +42,7 @@ (compiler-notify "~@" + ~2I~_~{~?~^~@:_~}~:>" note (messages)))) ;; As best I can guess, it's OK to fall off the end here ;; because if it's not a VALID-FUNCTION-USE, the user --- orig/src/compiler/generic/early-type-vops.lisp +++ mod/src/compiler/generic/early-type-vops.lisp @@ -11,7 +11,7 @@ (in-package "SB!VM") (defparameter *immediate-types* - (list unbound-marker-widetag base-char-widetag)) + (list unbound-marker-widetag character-widetag)) (defparameter *fun-header-widetags* (list funcallable-instance-header-widetag @@ -57,7 +57,7 @@ (if (subsetp headers *fun-header-widetags*) t (error "can't test for mix of function subtypes ~ - and normal header types")) + and normal header types")) nil))) (unless type-codes (error "At least one type must be supplied for TEST-TYPE.")) --- orig/tests/pathnames.impure.lisp +++ mod/tests/pathnames.impure.lisp @@ -309,6 +309,7 @@ (parse-namestring "SCRATCH:FOO.TXT.NEWEST") (parse-namestring "SCRATCH:FOO.TXT")))) (dolist (p pathnames) + (print p) (handler-case (let ((*print-readably* t)) (assert (equal (read-from-string (format nil "~S" p)) p))) --- orig/tests/character.pure.lisp +++ mod/tests/character.pure.lisp @@ -54,3 +54,10 @@ (digit-char 4 1) (digit-char 4 37))) (assert (raises-error? (apply (car form) (mapcar 'eval (cdr form))) type-error))) + +(dotimes (i 256) + (let* ((char (code-char i)) + (graphicp (graphic-char-p char)) + (name (char-name char))) + (unless graphicp + (assert name)))) --- orig/src/code/interr.lisp +++ mod/src/code/interr.lisp @@ -123,6 +123,16 @@ :datum object :expected-type 'base-string)) +(deferr object-not-vector-nil-error (object) + (error 'type-error + :datum object + :expected-type '(vector nil))) + +(deferr object-not-character-string-error (object) + (error 'type-error + :datum object + :expected-type '(vector character))) + (deferr object-not-bit-vector-error (object) (error 'type-error :datum object @@ -190,10 +200,10 @@ (deferr unbound-symbol-error (symbol) (error 'unbound-variable :name symbol)) -(deferr object-not-base-char-error (object) +(deferr object-not-character-error (object) (error 'type-error :datum object - :expected-type 'base-char)) + :expected-type 'character)) (deferr object-not-sap-error (object) (error 'type-error --- orig/src/code/late-type.lisp +++ mod/src/code/late-type.lisp @@ -2096,22 +2096,22 @@ (if (eq (car dims) '*) (case eltype (bit 'bit-vector) - (base-char 'base-string) + ((base-char) 'base-string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) - (base-char `(base-string ,(car dims))) + ((base-char) `(base-string ,(car dims))) (t `(vector ,eltype ,(car dims))))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) - (base-char 'simple-base-string) + ((base-char) 'simple-base-string) ((t) 'simple-vector) (t `(simple-array ,eltype (*)))) (case eltype (bit `(simple-bit-vector ,(car dims))) - (base-char `(simple-base-string ,(car dims))) + ((base-char) `(simple-base-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t @@ -2378,18 +2378,24 @@ (!def-type-translator member (&rest members) (if members - (let (ms numbers) + (let (ms numbers char-codes) (dolist (m (remove-duplicates members)) (typecase m (float (if (zerop m) (push m ms) (push (ctype-of m) numbers))) (real (push (ctype-of m) numbers)) + (character (push (sb!xc:char-code m) char-codes)) (t (push m ms)))) (apply #'type-union (if ms (make-member-type :members ms) *empty-type*) + (if char-codes + (make-character-set-type + :pairs (mapcar (lambda (x) (cons x x)) + (sort char-codes #'<))) + *empty-type*) (nreverse numbers))) *empty-type*)) @@ -2562,6 +2568,7 @@ ((type= type (specifier-type 'simple-string)) 'simple-string) ((type= type (specifier-type 'string)) 'string) ((type= type (specifier-type 'complex)) 'complex) + ((type= type (specifier-type 'standard-char)) 'standard-char) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2834,6 +2841,89 @@ (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) cdr-int2))))) + +;;;; CHARACTER-SET types + +(!define-type-class character-set) + +(!def-type-translator character-set + (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit))))) + (make-character-set-type :pairs pairs)) + +(!define-type-method (character-set :negate) (type) + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (make-negation-type :type type) + (let ((not-character + (make-negation-type + :type (make-character-set-type + :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) + (type-union + not-character + (make-character-set-type + :pairs (let (not-pairs) + (when (> (caar pairs) 0) + (push (cons 0 (1- (caar pairs))) not-pairs)) + (do* ((tail pairs (cdr tail)) + (high1 (cdar tail)) + (low2 (caadr tail))) + ((null (cdr tail)) + (when (< (cdar tail) (1- sb!xc:char-code-limit)) + (push (cons (1+ (cdar tail)) + (1- sb!xc:char-code-limit)) + not-pairs)) + (nreverse not-pairs)) + (push (cons (1+ high1) (1- low2)) not-pairs))))))))) + +(!define-type-method (character-set :unparse) (type) + (cond + ((type= type (specifier-type 'character)) 'character) + ((type= type (specifier-type 'base-char)) 'base-char) + ((type= type (specifier-type 'extended-char)) 'extended-char) + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t (let ((pairs (character-set-type-pairs type))) + `(member ,@(loop for (low . high) in pairs + append (loop for code from low upto high + collect (sb!xc:code-char code)))))))) + +(!define-type-method (character-set :simple-=) (type1 type2) + (let ((pairs1 (character-set-type-pairs type1)) + (pairs2 (character-set-type-pairs type2))) + (values (equal pairs1 pairs2) t))) + +(!define-type-method (character-set :simple-subtypep) (type1 type2) + (values + (dolist (pair (character-set-type-pairs type1) t) + (unless (position pair (character-set-type-pairs type2) + :test (lambda (x y) (and (>= (car x) (car y)) + (<= (cdr x) (cdr y))))) + (return nil))) + t)) + +(!define-type-method (character-set :simple-union2) (type1 type2) + ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function + ;; actually does the union for us. It might be a little fragile to + ;; rely on it. + (make-character-set-type + :pairs (merge 'list + (copy-alist (character-set-type-pairs type1)) + (copy-alist (character-set-type-pairs type2)) + #'< :key #'car))) + +(!define-type-method (character-set :simple-intersection2) (type1 type2) + ;; KLUDGE: brute force. + (let (pairs) + (dolist (pair1 (character-set-type-pairs type1) + (make-character-set-type + :pairs (sort pairs #'< :key #'car))) + (dolist (pair2 (character-set-type-pairs type2)) + (cond + ((<= (car pair1) (car pair2) (cdr pair1)) + (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) + ((<= (car pair2) (car pair1) (cdr pair2)) + (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))) ;;; Return the type that describes all objects that are in X but not ;;; in Y. If we can't determine this type, then return NIL. --- orig/src/runtime/print.c +++ mod/src/runtime/print.c @@ -218,7 +218,7 @@ type = widetag_of(obj); switch (type) { - case BASE_CHAR_WIDETAG: + case CHARACTER_WIDETAG: c = (obj>>8)&0xff; switch (c) { case '\0': @@ -275,7 +275,7 @@ printf(", unknown type (0x%0x)", type); switch (widetag_of(obj)) { - case BASE_CHAR_WIDETAG: + case CHARACTER_WIDETAG: printf(": "); brief_otherimm(obj); break; @@ -471,191 +471,193 @@ } switch (type) { - case BIGNUM_WIDETAG: - ptr += count; - NEWLINE_OR_RETURN; - printf("0x"); - while (count-- > 0) - printf("%08lx", (unsigned long) *--ptr); - break; - - case RATIO_WIDETAG: - print_slots(ratio_slots, count, ptr); - break; - - case COMPLEX_WIDETAG: - print_slots(complex_slots, count, ptr); - break; - - case SYMBOL_HEADER_WIDETAG: - print_slots(symbol_slots, count, ptr); - break; - - case SINGLE_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%g", ((struct single_float *)native_pointer(obj))->value); - break; - - case DOUBLE_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%g", ((struct double_float *)native_pointer(obj))->value); - break; - + case BIGNUM_WIDETAG: + ptr += count; + NEWLINE_OR_RETURN; + printf("0x"); + while (count-- > 0) + printf("%08lx", (unsigned long) *--ptr); + break; + + case RATIO_WIDETAG: + print_slots(ratio_slots, count, ptr); + break; + + case COMPLEX_WIDETAG: + print_slots(complex_slots, count, ptr); + break; + + case SYMBOL_HEADER_WIDETAG: + print_slots(symbol_slots, count, ptr); + break; + + case SINGLE_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%g", ((struct single_float *)native_pointer(obj))->value); + break; + + case DOUBLE_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%g", ((struct double_float *)native_pointer(obj))->value); + break; + #ifdef LONG_FLOAT_WIDETAG - case LONG_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%Lg", ((struct long_float *)native_pointer(obj))->value); - break; + case LONG_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%Lg", ((struct long_float *)native_pointer(obj))->value); + break; #endif - + #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG - case COMPLEX_SINGLE_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%g", ((struct complex_single_float *)native_pointer(obj))->real); - NEWLINE_OR_RETURN; - printf("%g", ((struct complex_single_float *)native_pointer(obj))->imag); - break; + case COMPLEX_SINGLE_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%g", ((struct complex_single_float *)native_pointer(obj))->real); + NEWLINE_OR_RETURN; + printf("%g", ((struct complex_single_float *)native_pointer(obj))->imag); + break; #endif - + #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG - case COMPLEX_DOUBLE_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%g", ((struct complex_double_float *)native_pointer(obj))->real); - NEWLINE_OR_RETURN; - printf("%g", ((struct complex_double_float *)native_pointer(obj))->imag); - break; + case COMPLEX_DOUBLE_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%g", ((struct complex_double_float *)native_pointer(obj))->real); + NEWLINE_OR_RETURN; + printf("%g", ((struct complex_double_float *)native_pointer(obj))->imag); + break; #endif - + #ifdef COMPLEX_LONG_FLOAT_WIDETAG - case COMPLEX_LONG_FLOAT_WIDETAG: - NEWLINE_OR_RETURN; - printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->real); - NEWLINE_OR_RETURN; - printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->imag); - break; -#endif - - case SIMPLE_BASE_STRING_WIDETAG: - NEWLINE_OR_RETURN; - cptr = (char *)(ptr+1); - putchar('"'); - while (length-- > 0) - putchar(*cptr++); - putchar('"'); - break; - - case SIMPLE_VECTOR_WIDETAG: - NEWLINE_OR_RETURN; - printf("length = %ld", length); - ptr++; - index = 0; - while (length-- > 0) { - sprintf(buffer, "%d: ", index++); - print_obj(buffer, *ptr++); - } - break; - - case INSTANCE_HEADER_WIDETAG: - NEWLINE_OR_RETURN; - printf("length = %ld", (long) count); - index = 0; - while (count-- > 0) { - sprintf(buffer, "%d: ", index++); - print_obj(buffer, *ptr++); - } - break; - - case SIMPLE_ARRAY_WIDETAG: - case SIMPLE_BIT_VECTOR_WIDETAG: - case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: - case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG: - case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG: - case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG: - case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG: + case COMPLEX_LONG_FLOAT_WIDETAG: + NEWLINE_OR_RETURN; + printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->real); + NEWLINE_OR_RETURN; + printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->imag); + break; +#endif + + case SIMPLE_BASE_STRING_WIDETAG: + case SIMPLE_CHARACTER_STRING_WIDETAG: /* FIXME */ + NEWLINE_OR_RETURN; + cptr = (char *)(ptr+1); + putchar('"'); + while (length-- > 0) + putchar(*cptr++); + putchar('"'); + break; + + case SIMPLE_VECTOR_WIDETAG: + NEWLINE_OR_RETURN; + printf("length = %ld", length); + ptr++; + index = 0; + while (length-- > 0) { + sprintf(buffer, "%d: ", index++); + print_obj(buffer, *ptr++); + } + break; + + case INSTANCE_HEADER_WIDETAG: + NEWLINE_OR_RETURN; + printf("length = %ld", (long) count); + index = 0; + while (count-- > 0) { + sprintf(buffer, "%d: ", index++); + print_obj(buffer, *ptr++); + } + break; + + case SIMPLE_ARRAY_WIDETAG: + case SIMPLE_BIT_VECTOR_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG: + case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG: #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG - case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG: + case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG: #endif #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG - case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG: + case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG: #endif #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG - case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG: + case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG: #endif #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG - case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG: + case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG: #endif - case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG: - case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG: + case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG: + case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG: #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG - case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG: + case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG: #endif #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG - case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG: + case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG: #endif #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG - case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG: + case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG: #endif #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG - case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG: + case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG: #endif - case COMPLEX_BASE_STRING_WIDETAG: - case COMPLEX_VECTOR_NIL_WIDETAG: - case COMPLEX_BIT_VECTOR_WIDETAG: - case COMPLEX_VECTOR_WIDETAG: - case COMPLEX_ARRAY_WIDETAG: - break; - - case CODE_HEADER_WIDETAG: - print_slots(code_slots, count-1, ptr); - break; - - case SIMPLE_FUN_HEADER_WIDETAG: - print_slots(fn_slots, 5, ptr); - break; - - case RETURN_PC_HEADER_WIDETAG: - print_obj("code: ", obj - (count * 4)); - break; - - case CLOSURE_HEADER_WIDETAG: - print_slots(closure_slots, count, ptr); - break; - - case FUNCALLABLE_INSTANCE_HEADER_WIDETAG: - print_slots(funcallable_instance_slots, count, ptr); - break; - - case VALUE_CELL_HEADER_WIDETAG: - print_slots(value_cell_slots, 1, ptr); - break; - - case SAP_WIDETAG: - NEWLINE_OR_RETURN; + case COMPLEX_BASE_STRING_WIDETAG: + case COMPLEX_CHARACTER_STRING_WIDETAG: + case COMPLEX_VECTOR_NIL_WIDETAG: + case COMPLEX_BIT_VECTOR_WIDETAG: + case COMPLEX_VECTOR_WIDETAG: + case COMPLEX_ARRAY_WIDETAG: + break; + + case CODE_HEADER_WIDETAG: + print_slots(code_slots, count-1, ptr); + break; + + case SIMPLE_FUN_HEADER_WIDETAG: + print_slots(fn_slots, 5, ptr); + break; + + case RETURN_PC_HEADER_WIDETAG: + print_obj("code: ", obj - (count * 4)); + break; + + case CLOSURE_HEADER_WIDETAG: + print_slots(closure_slots, count, ptr); + break; + + case FUNCALLABLE_INSTANCE_HEADER_WIDETAG: + print_slots(funcallable_instance_slots, count, ptr); + break; + + case VALUE_CELL_HEADER_WIDETAG: + print_slots(value_cell_slots, 1, ptr); + break; + + case SAP_WIDETAG: + NEWLINE_OR_RETURN; #ifndef alpha - printf("0x%08lx", (unsigned long) *ptr); + printf("0x%08lx", (unsigned long) *ptr); #else - printf("0x%016lx", *(lispobj*)(ptr+1)); + printf("0x%016lx", *(lispobj*)(ptr+1)); #endif - break; - - case WEAK_POINTER_WIDETAG: - print_slots(weak_pointer_slots, 1, ptr); - break; - - case BASE_CHAR_WIDETAG: - case UNBOUND_MARKER_WIDETAG: - NEWLINE_OR_RETURN; - printf("pointer to an immediate?"); - break; - - case FDEFN_WIDETAG: - print_slots(fdefn_slots, count, ptr); - break; - - default: - NEWLINE_OR_RETURN; - printf("Unknown header object?"); - break; + break; + + case WEAK_POINTER_WIDETAG: + print_slots(weak_pointer_slots, 1, ptr); + break; + + case CHARACTER_WIDETAG: + case UNBOUND_MARKER_WIDETAG: + NEWLINE_OR_RETURN; + printf("pointer to an immediate?"); + break; + + case FDEFN_WIDETAG: + print_slots(fdefn_slots, count, ptr); + break; + + default: + NEWLINE_OR_RETURN; + printf("Unknown header object?"); + break; } } } --- orig/src/compiler/dump.lisp +++ mod/src/compiler/dump.lisp @@ -33,7 +33,7 @@ ;; can get them from the table rather than dumping them again. The ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is ;; used for everything else. We use a separate EQ table to avoid - ;; performance patholigies with objects for which EQUAL degnerates + ;; performance pathologies with objects for which EQUAL degenerates ;; to EQL. Everything entered in the EQUAL table is also entered in ;; the EQ table. (equal-table (make-hash-table :test 'equal) :type hash-table) @@ -192,11 +192,19 @@ (declare (type fasl-output fasl-output)) (unless *cold-load-dump* (let ((handle (gethash x (fasl-output-equal-table fasl-output)))) - (cond (handle - (dump-push handle fasl-output) - t) - (t - nil))))) + (cond + (handle (dump-push handle fasl-output) t) + (t nil))))) +(defun string-check-table (x fasl-output) + (declare (type fasl-output fasl-output) + (type string x)) + (unless *cold-load-dump* + (let ((handle (cdr (assoc + (array-element-type x) + (gethash x (fasl-output-equal-table fasl-output)))))) + (cond + (handle (dump-push handle fasl-output) t) + (t nil))))) ;;; These functions are called after dumping an object to save the ;;; object in the table. The object (also passed in as X) must already @@ -217,7 +225,16 @@ (setf (gethash x (fasl-output-eq-table fasl-output)) handle) (dump-push handle fasl-output))) (values)) - +(defun string-save-object (x fasl-output) + (declare (type fasl-output fasl-output) + (type string x)) + (unless *cold-load-dump* + (let ((handle (dump-pop fasl-output))) + (push (cons (array-element-type x) handle) + (gethash x (fasl-output-equal-table fasl-output))) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output))) + (values)) ;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is ;;; true. This is called on objects that we are about to dump might ;;; have a circular path through them. @@ -280,17 +297,19 @@ ;; character code. (fasl-write-string (with-standard-io-syntax - (format nil - "~% ~ - compiled from ~S~% ~ - at ~A~% ~ - on ~A~% ~ - using ~A version ~A~%" - where - (format-universal-time nil (get-universal-time)) - (machine-instance) - (sb!xc:lisp-implementation-type) - (sb!xc:lisp-implementation-version))) + (let ((*print-readably* nil) + (*print-pretty* nil)) + (format nil + "~% ~ + compiled