Changeset 13215

Timestamp:

Nov 19, 2009, 12:00:27 AM (15 years ago)

Author:

Gary Byers

Message:

Recycle those old FASL ops so that we effectively encode all strings
in UTF-8. After this is bootstrapped, can try to use the "new" string
ops to save a byte when encoding ASCII.

File:

• branches/purify/source/lib/nfcomp.lisp (modified) (4 diffs)

branches/purify/source/lib/nfcomp.lisp

@@ -1489 +1489 @@
     (double-float (fasl-dump-dfloat exp))
     (single-float (fasl-dump-sfloat exp))
-    (simple-string (let* ((n (length exp)))
-                     (fasl-out-opcode $fasl-nvstr exp)
-                     (fasl-out-count n)
-                     (fasl-out-simple-string exp 0 n)))
+    (simple-string (fasl-out-opcode $fasl-vstr exp) (fasl-out-vstring exp))
     (simple-bit-vector (fasl-dump-bit-vector exp))
     ((simple-array (unsigned-byte 8) (*))
@@ -1768 +1765 @@
 (defun fasl-dump-package (pkg)
   (let ((name (package-name pkg)))
-    (fasl-out-opcode $fasl-nvpkg pkg)
-    (fasl-out-nvstring name)))
+    (fasl-out-opcode $fasl-vpkg pkg)
+    (fasl-out-vstring name)))
 
 
@@ -1820 +1817 @@
     (cond ((null pkg) 
            (progn 
-             (fasl-out-opcode (if idx $fasl-nvmksym-special $fasl-nvmksym) sym)
-             (fasl-out-nvstring name)))
+             (fasl-out-opcode (if idx $fasl-vmksym-special $fasl-vmksym) sym)
+             (fasl-out-vstring name)))
           (*fasdump-epush*
            (progn
              (fasl-out-byte (fasl-epush-op (if idx
-                                             $fasl-nvpkg-intern-special
-                                             $fasl-nvpkg-intern)))
+                                             $fasl-vpkg-intern-special
+                                             $fasl-vpkg-intern)))
              (fasl-dump-form pkg)
              (fasl-dump-epush sym)
-             (fasl-out-nvstring name)))
+             (fasl-out-vstring name)))
           (t
            (progn
              (fasl-out-byte (if idx
-                              $fasl-nvpkg-intern-special
-                              $fasl-nvpkg-intern))
+                              $fasl-vpkg-intern-special
+                              $fasl-vpkg-intern))
              (fasl-dump-form pkg)
-             (fasl-out-nvstring name))))))
+             (fasl-out-vstring name))))))
 
 
@@ -1852 +1849 @@
   (fasl-out-count (length str))
   (fasl-out-simple-string str 0 (length str)))
+
+(defun utf-8-extra-bytes (string start end)
+  (declare (simple-string string)
+           (fixnum start end))
+  (do* ((i start (1+ i))
+        (extra 0))
+       ((>= i end) extra)
+    (declare (fixnum i extra))
+    (let* ((code (%scharcode string i)))
+      (declare ((mod #x110000) code))
+      (cond ((>= code #x10000) (incf extra 3))
+            ((>= code #x800) (incf code 2))
+            ((>= code #x80) (incf code 1))))))
+
+(defun fasl-out-vstring (str)
+  (let* ((len (length str))
+         (nextra (utf-8-extra-bytes str 0 len)))
+    (declare (fixnum len nextra))
+    (fasl-out-count len)
+    (fasl-out-count nextra)
+    (dotimes (i len)
+      (let* ((code (%scharcode str i)))
+        (declare ((mod #x110000) code))
+        (cond ((< code #x80) (fasl-out-byte code))
+              ((< code #x800)
+               (let* ((y (ldb (byte 5 6) code))
+                      (z (ldb (byte 6 0) code)))
+                 (declare (fixnum y z))
+                 (fasl-out-byte (logior #xc0 y))
+                 (fasl-out-byte (logior #x80 z))))
+              ((< code #x10000)
+               (let* ((x (ldb (byte 4 12) code))
+                      (y (ldb (byte 6 6) code))
+                      (z (ldb (byte 6 0) code)))
+                 (declare (fixnum x y z))
+                 (fasl-out-byte (logior #xe0 x))
+                 (fasl-out-byte (logior #x80 y))
+                 (fasl-out-byte (logior #x80 z))))
+              (t
+                (let* ((w (ldb (byte 3 18) code))
+                       (x (ldb (byte 6 12) code))
+                       (y (ldb (byte 6 6) code))
+                       (z (ldb (byte 6 0) code)))
+                  (declare (fixnum w x y z))
+                  (fasl-out-byte (logior #xf0 w))
+                  (fasl-out-byte (logior #x80 x))
+                  (fasl-out-byte (logior #x80 y))
+                  (fasl-out-byte (logior #x80 z)))))))))
+
 
 (defun fasl-out-ivect (iv &optional