From d334bb7db90f9f88b22cd4786083ba96d976ba33 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 1 Nov 2004 18:20:47 +0000 Subject: [PATCH] 0.8.16.24: What I think are the final commonalities between the current tree and the soon-to-be-added #!+sb-unicode build option. This patch was brought to you by character_branch and much puzzling over diffs. --- src/code/fd-stream.lisp | 3 ++- src/code/fop.lisp | 13 +++++-------- src/code/run-program.lisp | 4 ++-- src/compiler/dump.lisp | 38 +++++++++++++++++++++++-------------- src/compiler/generic/genesis.lisp | 4 ++-- version.lisp-expr | 2 +- 6 files changed, 36 insertions(+), 28 deletions(-) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index a6fdf1a..528bd52 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1811,7 +1811,8 @@ (make-fd-stream 1 :name "standard output" :output t :buffering :line)) (setf *stderr* (make-fd-stream 2 :name "standard error" :output t :buffering :line)) - (let ((tty (sb!unix:unix-open "/dev/tty" sb!unix:o_rdwr #o666))) + (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) + (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty (setf *tty* (make-fd-stream tty diff --git a/src/code/fop.lisp b/src/code/fop.lisp index fab38c4..7f58e99 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -123,11 +123,8 @@ #-sb-xc-host (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-widetag)) -;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current -;;; SBCL as we have no extended characters, only 1-byte characters. -;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.) -(define-fop (fop-short-character 69) - (code-char (read-byte-arg))) +(define-cloned-fops (fop-character 68) (fop-short-character 69) + (code-char (clone-arg))) (define-cloned-fops (fop-struct 48) (fop-small-struct 49) (let* ((size (clone-arg)) @@ -344,9 +341,9 @@ ;;;; fops for loading arrays -(define-cloned-fops (fop-string 37) (fop-small-string 38) +(define-cloned-fops (fop-base-string 37) (fop-small-base-string 38) (let* ((arg (clone-arg)) - (res (make-string arg))) + (res (make-string arg :element-type 'base-char))) (read-string-as-bytes *fasl-input-stream* res) res)) @@ -639,7 +636,7 @@ bug.~:@>") (let* ((kind (pop-stack)) (code-object (pop-stack)) (len (read-byte-arg)) - (sym (make-string len))) + (sym (make-string len :element-type 'base-char))) (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object (read-word-arg) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index cc5a595..408b050 100644 --- a/src/code/run-program.lisp +++ b/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))) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 453daf4..a66ac81 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -600,7 +600,9 @@ (t (unless *cold-load-dump* (dump-fop 'fop-normal-load file)) - (dump-simple-string (package-name pkg) file) + (dump-simple-base-string + (coerce (package-name pkg) 'simple-base-string) + file) (dump-fop 'fop-package file) (unless *cold-load-dump* (dump-fop 'fop-maybe-cold-load file)) @@ -733,7 +735,7 @@ (typecase simple-version (simple-base-string (unless (equal-check-table x file) - (dump-simple-string simple-version file) + (dump-simple-base-string simple-version file) (equal-save-object x file))) (simple-vector (dump-simple-vector simple-version file) @@ -903,23 +905,31 @@ ;;; Dump characters and string-ish things. -(defun dump-character (ch file) +(defun dump-character (char file) + (let ((code (sb!xc:char-code char))) + (cond + ((< code 256) (dump-fop 'fop-short-character file) - (dump-byte (char-code ch) file)) + (dump-byte code file)) + (t + (dump-fop 'fop-character file) + (dump-word code file))))) -;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL -(defun dump-characters-of-string (s fasl-output) - (declare (type string s) (type fasl-output fasl-output)) +(defun dump-base-chars-of-string (s fasl-output) + (declare #+sb-xc-host (type simple-string s) + #-sb-xc-host (type simple-base-string s) + (type fasl-output fasl-output)) (dovector (c s) - (dump-byte (char-code c) fasl-output)) + (dump-byte (sb!xc:char-code c) fasl-output)) (values)) + ;;; Dump a SIMPLE-BASE-STRING. -;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then -(defun dump-simple-string (s file) - (declare (type simple-base-string s)) - (dump-fop* (length s) fop-small-string fop-string file) - (dump-characters-of-string s file) +(defun dump-simple-base-string (s file) + #+sb-xc-host (declare (type simple-string s)) + #-sb-xc-host (declare (type simple-base-string s)) + (dump-fop* (length s) fop-small-base-string fop-base-string file) + (dump-base-chars-of-string s file) (values)) ;;; If we get here, it is assumed that the symbol isn't in the table, @@ -969,7 +979,7 @@ file) (dump-word pname-length file))) - (dump-characters-of-string pname file) + (dump-base-chars-of-string pname file) (unless *cold-load-dump* (setf (gethash s (fasl-output-eq-table file)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index f9d6614..674db25 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2099,8 +2099,8 @@ core and return a descriptor to it." ;;;; cold fops for loading vectors -(clone-cold-fop (fop-string) - (fop-small-string) +(clone-cold-fop (fop-base-string) + (fop-small-base-string) (let* ((len (clone-arg)) (string (make-string len))) (read-string-as-bytes *fasl-input-stream* string) diff --git a/version.lisp-expr b/version.lisp-expr index cfd340d..9678c2e 100644 --- a/version.lisp-expr +++ b/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.23" +"0.8.16.24" -- 1.7.10.4