Changeset 13219

Timestamp:

Nov 20, 2009, 4:11:58 AM (15 years ago)

Author:

Gary Byers

Message:

Try to save strings in ASCII if possible.

File:

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

branches/purify/source/lib/nfcomp.lisp

@@ -1 @@
-;;-*-Mode: LISP; Package: CCL -*-
+;;;-*-Mode: LISP; Package: CCL -*-
 ;;;
 ;;;   Copyright (C) 1994-2001 Digitool, Inc
@@ -1489 +1489 @@
     (double-float (fasl-dump-dfloat exp))
     (single-float (fasl-dump-sfloat exp))
-    (simple-string (fasl-out-opcode $fasl-vstr exp) (fasl-out-vstring exp))
+    (simple-string
+     (let* ((nextra (utf-8-extra-bytes exp)))
+       (cond ((= 0 nextra)
+              (fasl-out-opcode $fasl-nvstr exp)
+              (fasl-out-nvstring exp))
+             (t (fasl-out-opcode $fasl-vstr exp)
+                (fasl-out-vstring exp nextra)))))
     (simple-bit-vector (fasl-dump-bit-vector exp))
     ((simple-array (unsigned-byte 8) (*))
@@ -1764 +1770 @@
 
 (defun fasl-dump-package (pkg)
-  (let ((name (package-name pkg)))
-    (fasl-out-opcode $fasl-vpkg pkg)
-    (fasl-out-vstring name)))
+  (let* ((name (package-name pkg))
+         (nextra (utf-8-extra-bytes name)))
+    (cond ((eql nextra 0)
+           (fasl-out-opcode $fasl-nvpkg pkg)
+           (fasl-out-nvstring name))
+          (t
+           (fasl-out-opcode $fasl-vpkg pkg)
+           (fasl-out-vstring name nextra)))))
 
 
@@ -1812 +1823 @@
   (let* ((pkg (symbol-package sym))
          (name (symbol-name sym))
+         (nextra (utf-8-extra-bytes name))
+         (ascii (eql nextra 0))
          (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
                 (declare (fixnum i))
@@ -1817 +1830 @@
     (cond ((null pkg) 
            (progn 
-             (fasl-out-opcode (if idx $fasl-vmksym-special $fasl-vmksym) sym)
-             (fasl-out-vstring name)))
+             (fasl-out-opcode (if idx
+                                (if ascii $fasl-nvmksym-special $fasl-vmksym-special)
+                                (if ascii $fasl-nvmksym $fasl-vmksym))
+                              sym)
+             (if ascii
+               (fasl-out-nvstring name)
+               (fasl-out-vstring name nextra))))
           (*fasdump-epush*
            (progn
              (fasl-out-byte (fasl-epush-op (if idx
-                                             $fasl-vpkg-intern-special
-                                             $fasl-vpkg-intern)))
+                                             (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
+                                             (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern))))
              (fasl-dump-form pkg)
              (fasl-dump-epush sym)
-             (fasl-out-vstring name)))
+             (if ascii
+               (fasl-out-nvstring name)
+               (fasl-out-vstring name nextra))))
           (t
            (progn
              (fasl-out-byte (if idx
-                              $fasl-vpkg-intern-special
-                              $fasl-vpkg-intern))
+                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
+                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern)))
              (fasl-dump-form pkg)
-             (fasl-out-vstring name))))))
+             (if ascii
+               (fasl-out-nvstring name)
+               (fasl-out-vstring name nextra)))))))
 
 
@@ -1844 +1866 @@
        ((= k end))
     (declare (fixnum k))
-    (fasl-out-count (char-code (schar str k)))))
+    (fasl-out-byte (char-code (schar str k)))))
 
 (defun fasl-out-nvstring (str)
@@ -1850 +1872 @@
   (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 extra 2))
-            ((>= code #x80) (incf extra 1))))))
-
-(defun fasl-out-vstring (str)
-  (let* ((len (length str))
-         (nextra (utf-8-extra-bytes str 0 len)))
-    (declare (fixnum len nextra))
+(defun utf-8-extra-bytes (string)
+  (declare (simple-string string))
+  (let* ((extra 0))
+    (declare (fixnum extra))
+    (dotimes (i (length string) extra)
+      (let* ((code (%scharcode string i)))
+        (declare ((mod #x110000) code))
+        (cond ((>= code #x10000) (incf extra 3))
+              ((>= code #x800) (incf extra 2))
+              ((>= code #x80) (incf extra 1)))))))
+
+(defun fasl-out-vstring (str nextra)
+  (declare (fixnum nextra))
+  (let* ((len (length str)))
+    (declare (fixnum len))
     (fasl-out-count len)
     (fasl-out-count nextra)