Changeset 13210

Timestamp:

Nov 18, 2009, 8:45:21 AM (15 years ago)

Author:

Gary Byers

Message:

Revive some old fasl ops that assumed 8-bit characters; make the
new versions handle UTF-8 in a way that hopefully makes the ASCII
subset of UTF-8 easier to deal with.

Location:

branches/purify/source

Files:

• level-0/nfasload.lisp (modified) (3 diffs)
• xdump/xfasload.lisp (modified) (1 diff)

branches/purify/source/level-0/nfasload.lisp

@@ -142 +142 @@
         
 
+(defun %fasl-read-utf-8-string (s string nchars nextra)
+  (declare (fixnum nchars nextra))
+  (if (eql 0 nextra)
+    (dotimes (i nchars)
+      (setf (%scharcode string i) (%fasl-read-byte s)))
+    (flet ((trailer-byte ()
+             (when (> nextra 0)
+               (decf nextra)
+               (let* ((b (%fasl-read-byte s)))
+                 (declare ((unsigned-byte 8) b))
+                 (and (>= b #x80)
+                      (< b #xc0)
+                      (logand b #x3f))))))
+      (declare (inline trailer-byte))
+      (dotimes (i nchars)
+        (let* ((b0 (%fasl-read-byte s)))
+          (declare ((unsigned-byte 8) b0))
+          (setf (%scharcode string i)
+                (or
+                 (cond ((< b0 #x80) b0)
+                       ((and (>= b0 #xc2)
+                             (< b0 #xe0))
+                        (let* ((b1 (trailer-byte)))
+                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
+                       ((and (>= b0 #xe0)
+                             (< b0 #xf0))
+                        (let* ((b1 (trailer-byte))
+                               (b2 (trailer-byte)))
+                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
+                                             (logior (ash b1 6)
+                                                     b2)))))
+                       ((and (>= b0 #xf0)
+                             (< b0 #xf5))
+                        (let* ((b1 (trailer-byte))
+                               (b2 (trailer-byte))
+                               (b3 (trailer-byte)))
+                          (and b1
+                               b2
+                               b3
+                               (logior (ash (logand b0 #x7) 18)
+                                       (logior (ash b1 12)
+                                               (logior (ash b2 6)
+                                                       b3)))))))
+                 (char-code #\Replacement_Character))))))))
+
+
 (defun %fasl-vreadstr (s)
-  (let* ((nbytes (%fasl-read-count s))
+  (let* ((nchars (%fasl-read-count s))
+         (nextra (%fasl-read-count s))
          (copy t)
-         (n nbytes)
+         (n nchars)
          (str (faslstate.faslstr s)))
-    (declare (fixnum n nbytes))
+    (declare (fixnum nchars n nextra))
     (if (> n (length str))
-        (setq str (make-string n :element-type 'base-char))
-        (setq copy nil))
-    (%fasl-read-n-bytes s str 0 nbytes)
-    (values str n copy)))
+      (setq str (make-string n :element-type 'base-char))
+      (setq copy nil))
+    (%fasl-read-utf-8-string s str nchars nextra)
+    (values str nchars copy)))
 
 
@@ -205 +252 @@
 (defun %fasl-vmake-symbol (s &optional idx)
   (let* ((n (%fasl-read-count s))
+         (nextra (%fasl-read-count s))
          (str (make-string n :element-type 'base-char)))
     (declare (fixnum n))
-    (%fasl-read-n-bytes s str 0 n)
+    (%fasl-read-utf-8-string s str n nextra)
     (let* ((sym (make-symbol str)))
       (when idx (ensure-binding-index sym))
@@ -424 +472 @@
 
 (deffaslop $fasl-vstr (s)
-  (let* ((n (%fasl-read-count s))
-         (str (make-string (the fixnum n) :element-type 'base-char)))
+  (let* ((nchars (%fasl-read-count s))
+         (nextra (%fasl-read-count s))
+         (str (make-string (the fixnum nchars) :element-type 'base-char)))
     (%epushval s str)
-    (%fasl-read-n-bytes s str 0 n)))
+    (%fasl-read-utf-8-string s str nchars nextra)))
+
 
 (deffaslop $fasl-nvstr (s)

branches/purify/source/xdump/xfasload.lisp

@@ -1186 +1186 @@
   (%epushval s (xload-make-sfloat *xload-readonly-space* (%fasl-read-long s))))
 
+(defun xload-read-utf-8-string (s v o nchars nextra)
+  (declare (fixnum nchars nextra))
+  (if (eql 0 nextra)
+    (dotimes (i nextra)
+      (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
+            (%fasl-read-byte s)) )
+    (flet ((trailer-byte ()
+             (when (> nextra 0)
+               (decf nextra)
+               (let* ((b (%fasl-read-byte s)))
+                 (declare ((unsigned-byte 8) b))
+                 (and (>= b #x80)
+                      (< b #xc0)
+                      (logand b #x3f))))))
+      (declare (inline trailer-byte))
+      (dotimes (i nchars)
+        (let* ((b0 (%fasl-read-byte s)))
+          (declare ((unsigned-byte 8) b0))
+          (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
+                (or
+                 (cond ((< b0 #x80) b0)
+                       ((and (>= b0 #xc2)
+                             (< b0 #xe0))
+                        (let* ((b1 (trailer-byte)))
+                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
+                       ((and (>= b0 #xe0)
+                             (< b0 #xf0))
+                        (let* ((b1 (trailer-byte))
+                               (b2 (trailer-byte)))
+                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
+                                             (logior (ash b1 6)
+                                                     b2)))))
+                       ((and (>= b0 #xf0)
+                             (< b0 #xf5))
+                        (let* ((b1 (trailer-byte))
+                               (b2 (trailer-byte))
+                               (b3 (trailer-byte)))
+                          (and b1
+                               b2
+                               b3
+                               (logior (ash (logand b0 #x7) 18)
+                                       (logior (ash b1 12)
+                                               (logior (ash b2 6)
+                                                       b3)))))))
+                 (char-code #\Replacement_Character))))))))
+
+
 (defxloadfaslop $fasl-vstr (s)
-  (let* ((n (%fasl-read-count s)))
-    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n)
+  (let* ((nchars (%fasl-read-count s))
+         (nextra (%fasl-read-count s)))
+    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string nchars)
       (%epushval s str)
-      (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) n)
+      (xload-read-utf-8-string s v o nchars nextra)
       str)))