Changeset 13527

Timestamp:

Mar 12, 2010, 2:05:36 PM (15 years ago)

Author:

gz

Message:

From trunk: support for non-ascii reader macros (r13498)

Location:

branches/working-0711/ccl

Files:

• . (modified) (1 prop)
• level-1/l1-reader.lisp (modified) (5 diffs)

branches/working-0711/ccl/level-1/l1-reader.lisp

@@ -1990 +1990 @@
 (defun copy-readtable (&optional (from *readtable*) to)
   (setq from (if from (readtable-arg from)  %standard-readtable%))
-  (setq to (if to 
-             (readtable-arg to)
-             (%istruct 'readtable
-                        (make-array 256 :element-type '(unsigned-byte 8))
+  (let* ((fttab (rdtab.ttab from))
+         (ttablen (uvsize fttab)))
+    (declare (fixnum ttablen))
+    (setq to (if to 
+               (readtable-arg to)
+               (%istruct 'readtable
+                         (make-array ttablen :element-type '(unsigned-byte 8))
                          nil (rdtab.case from))))
-  (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
-  (setf (rdtab.case to) (rdtab.case from))
-  (let* ((fttab (rdtab.ttab from))
-         (tttab (rdtab.ttab to)))
-    (%copy-ivector-to-ivector fttab 0 tttab 0 256))
-  to)
+    (setf (rdtab.alist to) (copy-tree (rdtab.alist from)))
+    (setf (rdtab.case to) (rdtab.case from))
+    (let* ((tttab (rdtab.ttab to)))
+      (%copy-ivector-to-ivector fttab 0 tttab 0 ttablen))
+    to))
 
 (declaim (inline %character-attribute))
@@ -2006 +2008 @@
 (defun %character-attribute (char attrtab)
   (declare (character char)
-           (type (simple-array (unsigned-byte 8) (256)) attrtab)
+           (type (simple-array (unsigned-byte 8) (*)) attrtab)
            (optimize (speed 3) (safety 0)))
   (let* ((code (char-code char)))
     (declare (fixnum code))
-    (if (< code 256)
+    (if (< code (uvsize attrtab))
       (aref attrtab code)
-      ;; Should probably have an extension mechanism for things
-      ;; like NBS.
       $cht_cnst)))
+
+(defun %set-character-attribute (char readtable attr)
+  (let* ((code (char-code char))
+         (attrtab (rdtab.ttab readtable))
+         (oldsize (uvsize attrtab)))
+    (declare (type (mod #x110000) code)
+             (type (simple-array (unsigned-byte 8) (*)) attrtab))
+    (when (>= code oldsize)
+      ;; Characters whose code is > the current size of the table
+      ;; are implicitly constituents; don't grow the table just to
+      ;; store that info explicitly.
+      (if (eql attr $cht_cnst)
+        (return-from %set-character-attribute attr)
+        (let* ((newsize (min (+ code code) char-code-limit))
+               (new (make-array newsize
+                                :element-type '(unsigned-byte 8)
+                                :initial-element $cht_cnst)))
+          (declare ((simple-array (unsigned-byte 8) (*)) new))
+          (%copy-ivector-to-ivector attrtab 0 new 0 oldsize)
+          (setf (rdtab.ttab readtable) (setq attrtab new)))))
+    (setf (aref attrtab code) attr)))
+
 
 ;;; returns: (values attrib <aux-info>), where
@@ -2047 +2069 @@
          (if old-to-info
            (setf (rdtab.alist to-readtable) (delq old-to-info (rdtab.alist to-readtable)))))
-       (if (and (= from-attr $cht_cnst)
-                (member to-char '(#\Newline #\Linefeed #\Page #\Return
-                                  #\Space #\Tab #\Backspace #\Rubout)))
-           (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) $cht_ill)
-           (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) from-attr)))
+       (%set-character-attribute to-char
+                                 to-readtable
+                                 (if (and (= from-attr $cht_cnst)
+                                          (member to-char '(#\Newline #\Linefeed #\Page #\Return
+                                                            #\Space #\Tab #\Backspace #\Rubout)))
+                                   $cht_ill
+                                   from-attr)))
       t)))
 
@@ -2078 +2102 @@
     (declare (list info))
     (without-interrupts
-     (setf (uvref (rdtab.ttab readtable) (char-code char))
-           (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
+     (%set-character-attribute char readtable
+                               (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac)))
      (if (and (null fn) info)
        (setf (rdtab.alist readtable) (delete info (rdtab.alist readtable) :test #'eq)) 
@@ -2115 +2139 @@
     (declare (list info))
     (without-interrupts
-     (setf (uvref (rdtab.ttab readtable) (char-code char))
+     (%set-character-attribute char readtable
            (if non-terminating-p $cht_ntmac $cht_tmac))
      (if info