Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32711/src/code
Modified Files:
Tag: character_branch
early-format.lisp late-format.lisp print.lisp
target-format.lisp
Log Message:
0.8.13.77.character.22:
"Are you a man or a mouse?"
Fix (FSVO "fix") remaining data structures scaling linearly with
CHAR-CODE-LIMIT.
... all defined format directives are base-char (but allow
construction of directives with characters)
... hack SYMBOL-QUOTEP into vague submission, but note that it
is in fact hideously buggy and needs a complete rewrite.
Index: early-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-format.lisp,v
retrieving revision 1.4
retrieving revision 1.4.46.1
diff -u -d -r1.4 -r1.4.46.1
--- early-format.lisp 14 Dec 2002 22:10:07 -0000 1.4
+++ early-format.lisp 17 Sep 2004 14:00:23 -0000 1.4.46.1
@@ -18,9 +18,9 @@
#-sb-xc-host (code-char tab-char-code)))
(defvar *format-directive-expanders*
- (make-array char-code-limit :initial-element nil))
+ (make-array base-char-code-limit :initial-element nil))
(defvar *format-directive-interpreters*
- (make-array char-code-limit :initial-element nil))
+ (make-array base-char-code-limit :initial-element nil))
(defvar *default-format-error-control-string* nil)
(defvar *default-format-error-offset* nil)
Index: late-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-format.lisp,v
retrieving revision 1.23.2.1
retrieving revision 1.23.2.2
diff -u -d -r1.23.2.1 -r1.23.2.2
--- late-format.lisp 7 Sep 2004 19:47:34 -0000 1.23.2.1
+++ late-format.lisp 17 Sep 2004 14:00:23 -0000 1.23.2.2
@@ -34,7 +34,7 @@
(string (missing-arg) :type simple-string)
(start (missing-arg) :type (and unsigned-byte fixnum))
(end (missing-arg) :type (and unsigned-byte fixnum))
- (character (missing-arg) :type base-char)
+ (character (missing-arg) :type chararacter)
(colonp nil :type (member t nil))
(atsignp nil :type (member t nil))
(params nil :type list))
@@ -219,8 +219,11 @@
(etypecase directive
(format-directive
(let ((expander
- (aref *format-directive-expanders*
- (char-code (format-directive-character directive))))
+ (let ((char (format-directive-character directive)))
+ (typecase char
+ (base-char
+ (aref *format-directive-expanders* (char-code char)))
+ (character nil))))
(*default-format-error-offset*
(1- (format-directive-end directive))))
(declare (type (or null function) expander))
Index: print.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/print.lisp,v
retrieving revision 1.53.2.1
retrieving revision 1.53.2.2
diff -u -d -r1.53.2.1 -r1.53.2.2
--- print.lisp 7 Sep 2004 19:47:34 -0000 1.53.2.1
+++ print.lisp 17 Sep 2004 14:00:23 -0000 1.53.2.2
@@ -615,10 +615,10 @@
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit
+ (make-array 160 ; FIXME
:element-type '(unsigned-byte 16)
:initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
*character-attributes*))
;;; constants which are a bit-mask for each interesting character attribute
@@ -672,17 +672,17 @@
(set-bit #\/ slash-attribute)
;; Mark anything not explicitly allowed as funny.
- (dotimes (i char-code-limit)
+ (dotimes (i 160) ; FIXME
(when (zerop (aref *character-attributes* i))
(setf (aref *character-attributes* i) funny-attribute))))
;;; For each character, the value of the corresponding element is the
;;; lowest base in which that character is a digit.
(defvar *digit-bases*
- (make-array char-code-limit
+ (make-array 128 ; FIXME
:element-type '(unsigned-byte 8)
:initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
*digit-bases*))
(dotimes (i 36)
(let ((char (digit-char i 36)))
@@ -698,7 +698,11 @@
,(if at-end '(go TEST-SIGN) '(return nil)))
(setq current (schar name index)
code (char-code current)
- bits (aref attributes code))
+ bits (cond ; FIXME
+ ((< code 160) (aref attributes code))
+ ((upper-case-p current) uppercase-attribute)
+ ((lower-case-p current) lowercase-attribute)
+ (t other-attribute)))
(incf index)
(go ,tag)))
(test (&rest attributes)
@@ -713,7 +717,8 @@
attributes))
bits)))))
(digitp ()
- `(< (the fixnum (aref bases code)) base)))
+ `(and (< code 128) ; FIXME
+ (< (the fixnum (aref bases code)) base))))
(prog ((len (length name))
(attributes *character-attributes*)
@@ -740,7 +745,13 @@
letter-attribute)))
(do ((i (1- index) (1+ i)))
((= i len) (return-from symbol-quotep nil))
- (unless (zerop (logand (aref attributes (char-code (schar name i)))
+ (unless (zerop (logand (let* ((char (schar name i))
+ (code (char-code char)))
+ (cond
+ ((< code 160) (aref attributes code))
+ ((upper-case-p char) uppercase-attribute)
+ ((lower-case-p char) lowercase-attribute)
+ (t other-attribute)))
mask))
(return-from symbol-quotep t))))
Index: target-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-format.lisp,v
retrieving revision 1.19.2.1
retrieving revision 1.19.2.2
diff -u -d -r1.19.2.1 -r1.19.2.2
--- target-format.lisp 7 Sep 2004 19:47:34 -0000 1.19.2.1
+++ target-format.lisp 17 Sep 2004 14:00:23 -0000 1.19.2.2
@@ -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
|