Changeset 5106

Timestamp:

Sep 4, 2006, 4:04:41 PM (18 years ago)

Author:

Gary Byers

Message:

Use (UNSIGNED-BYTE 8) for array element type of rdtab.ttab.

Don't treat (code-char #xca) as whitespace; do treat (code-char #xa0)
as whitespace. (The former happens to be how the latter was encoded
in MacRoman.)

Handle U+<hex> syntax in NAME-CHAR.

File:

• trunk/ccl/level-1/l1-reader.lisp (modified) (9 diffs)

trunk/ccl/level-1/l1-reader.lisp

@@ -25 +25 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 
 (defparameter *name-char-alist*
@@ -60 +61 @@
 ;;;Otherwise, if it consists of two chars, the first of which  is ^,
 ;;; return %code-char(c xor 64), where c is the uppercased second char.
-;;;Otherwise, if it consists of octal digits, the digits are
-;;; interpreted as the (mod 256) ascii code of a character.
+;;;Otherwise, if it starts with the prefix "u+" or "U+" followed by
+;;; hex digits, the number denoted by those hex digits is interpreted as the
+;;; unicode code of the character; if this value is less than
+;;; CHAR-CODE-LIMIT, CODE-CHAR of that value is returned.
+;;;Otherwise, if it consists of octal digits, the number denoted by
+;;;  those octal digits is interpreted as per the U+ case above.
 ;;;Otherwise return NIL.
 
@@ -73 +78 @@
         (declare (fixnum namelen))
         (or (cdr (assoc name *name-char-alist* :test #'string-equal))
-         (if (= namelen 1)
-           (char name 0)
-           (if (and (= namelen 2) (eq (char name 0) #\^))
-             (code-char (the fixnum (logxor (the fixnum (char-code (char-upcase (char name 1)))) #x40)))
-             (let* ((n 0))
-               (dotimes (i namelen (code-char (logand n (1- char-code-limit))))
-                 (let* ((code (the fixnum (- (the fixnum (char-code (char name i)))
-                                             (char-code #\0)))))
-                   (declare (fixnum code))
-                   (if (and (>= code 0)
-                            (<= code 7))
-                     (setq n (logior code (the fixnum (ash n 3))))
-                     (return))))))))))))
+            (if (= namelen 1)
+              (char name 0)
+              (if (and (= namelen 2) (eq (char name 0) #\^))
+                (code-char (the fixnum (logxor (the fixnum (char-code (char-upcase (char name 1)))) #x40)))
+                (let* ((n 0))
+                  (or
+                   (if (and (> namelen 2)
+                            (or (eql (char name 0) #\U)
+                                (eql (char name 0) #\u))
+                            (eql (char name 1) #\+))
+                     (do* ((i 2 (1+ i)))
+                          ((= i namelen) (if (< n char-code-limit)
+                                           (code-char n)))
+                       (declare (fixnum i))
+                       (let* ((pos (position (char-upcase (char name i))
+                                             "0123456789ABCDEF")))
+                         (if pos
+                           (setq n (logior (ash n 4) pos))
+                           (progn
+                             (setq n 0)
+                             (return))))))
+                   (dotimes (i namelen (code-char (mod n char-code-limit)))
+                     (let* ((code (the fixnum (- (the fixnum (char-code (char name i)))
+                                                 (char-code #\0)))))
+                       (declare (fixnum code))
+                       (if (and (>= code 0)
+                                (<= code 7))
+                         (setq n (logior code (the fixnum (ash n 3))))
+                         (return)))))))))))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -94 +115 @@
                       (set-schar str 3 #\^@)
                       (set-schar str 4 #\^J)
-                      (set-schar str 5 (%code-char #xCA))
+                      (set-schar str 5 (code-char #xa0))
                       str))
 
@@ -104 +125 @@
                         (set-schar str 4 #\^@)
                         (set-schar str 5 #\^J)
-                        (set-schar str 6 (%code-char #xCA))
+                        (set-schar str 6 (code-char #xa0))
                         str))
 )
@@ -165 +186 @@
 ;;; This -really- gets initialized later in the file
 (defvar %initial-readtable%
-  (let* ((ttab (make-array 256 :element-type '(signed-byte 8)))
+  (let* ((ttab (make-array 256 :element-type '(unsigned-byte 8)))
          (macs `((#\# . (,#'read-dispatch))))
          (case :upcase))
@@ -187 +208 @@
              (readtable-arg to)
              (%istruct 'readtable
-                        (make-array 256 :element-type '(signed-byte 8))
+                        (make-array 256 :element-type '(unsigned-byte 8))
                          nil (rdtab.case from))))
   (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
@@ -193 +214 @@
   (let* ((fttab (rdtab.ttab from))
          (tttab (rdtab.ttab to)))
-    (dotimes (i 256 to)
-      (setf (uvref tttab i) (uvref fttab i)))))
+    (%copy-ivector-to-ivector fttab 0 tttab 0 257)))
 
 (declaim (inline %character-attribute))
@@ -200 +220 @@
 (defun %character-attribute (char attrtab)
   (declare (character char)
-           (type (simple-array (signed-byte 8) (*)) attrtab)
+           (type (simple-array (unsigned-byte 8) (256)) attrtab)
            (optimize (speed 3) (safety 0)))
   (let* ((code (char-code char)))
     (declare (fixnum code))
-    (aref attrtab code)))
+    (if (< code 256)
+      (aref attrtab code)
+      ;; Should probably have an extension mechanism for things
+      ;; like NBS.
+      $cht_cnst)))
 
 ;;; returns: (values attrib <aux-info>), where