Changeset 13215


Ignore:
Timestamp:
Nov 19, 2009, 8:00:27 AM (10 years ago)
Author:
gb
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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/purify/source/lib/nfcomp.lisp

    r12709 r13215  
    14891489    (double-float (fasl-dump-dfloat exp))
    14901490    (single-float (fasl-dump-sfloat exp))
    1491     (simple-string (let* ((n (length exp)))
    1492                      (fasl-out-opcode $fasl-nvstr exp)
    1493                      (fasl-out-count n)
    1494                      (fasl-out-simple-string exp 0 n)))
     1491    (simple-string (fasl-out-opcode $fasl-vstr exp) (fasl-out-vstring exp))
    14951492    (simple-bit-vector (fasl-dump-bit-vector exp))
    14961493    ((simple-array (unsigned-byte 8) (*))
     
    17681765(defun fasl-dump-package (pkg)
    17691766  (let ((name (package-name pkg)))
    1770     (fasl-out-opcode $fasl-nvpkg pkg)
    1771     (fasl-out-nvstring name)))
     1767    (fasl-out-opcode $fasl-vpkg pkg)
     1768    (fasl-out-vstring name)))
    17721769
    17731770
     
    18201817    (cond ((null pkg)
    18211818           (progn
    1822              (fasl-out-opcode (if idx $fasl-nvmksym-special $fasl-nvmksym) sym)
    1823              (fasl-out-nvstring name)))
     1819             (fasl-out-opcode (if idx $fasl-vmksym-special $fasl-vmksym) sym)
     1820             (fasl-out-vstring name)))
    18241821          (*fasdump-epush*
    18251822           (progn
    18261823             (fasl-out-byte (fasl-epush-op (if idx
    1827                                              $fasl-nvpkg-intern-special
    1828                                              $fasl-nvpkg-intern)))
     1824                                             $fasl-vpkg-intern-special
     1825                                             $fasl-vpkg-intern)))
    18291826             (fasl-dump-form pkg)
    18301827             (fasl-dump-epush sym)
    1831              (fasl-out-nvstring name)))
     1828             (fasl-out-vstring name)))
    18321829          (t
    18331830           (progn
    18341831             (fasl-out-byte (if idx
    1835                               $fasl-nvpkg-intern-special
    1836                               $fasl-nvpkg-intern))
     1832                              $fasl-vpkg-intern-special
     1833                              $fasl-vpkg-intern))
    18371834             (fasl-dump-form pkg)
    1838              (fasl-out-nvstring name))))))
     1835             (fasl-out-vstring name))))))
    18391836
    18401837
     
    18521849  (fasl-out-count (length str))
    18531850  (fasl-out-simple-string str 0 (length str)))
     1851
     1852(defun utf-8-extra-bytes (string start end)
     1853  (declare (simple-string string)
     1854           (fixnum start end))
     1855  (do* ((i start (1+ i))
     1856        (extra 0))
     1857       ((>= i end) extra)
     1858    (declare (fixnum i extra))
     1859    (let* ((code (%scharcode string i)))
     1860      (declare ((mod #x110000) code))
     1861      (cond ((>= code #x10000) (incf extra 3))
     1862            ((>= code #x800) (incf code 2))
     1863            ((>= code #x80) (incf code 1))))))
     1864
     1865(defun fasl-out-vstring (str)
     1866  (let* ((len (length str))
     1867         (nextra (utf-8-extra-bytes str 0 len)))
     1868    (declare (fixnum len nextra))
     1869    (fasl-out-count len)
     1870    (fasl-out-count nextra)
     1871    (dotimes (i len)
     1872      (let* ((code (%scharcode str i)))
     1873        (declare ((mod #x110000) code))
     1874        (cond ((< code #x80) (fasl-out-byte code))
     1875              ((< code #x800)
     1876               (let* ((y (ldb (byte 5 6) code))
     1877                      (z (ldb (byte 6 0) code)))
     1878                 (declare (fixnum y z))
     1879                 (fasl-out-byte (logior #xc0 y))
     1880                 (fasl-out-byte (logior #x80 z))))
     1881              ((< code #x10000)
     1882               (let* ((x (ldb (byte 4 12) code))
     1883                      (y (ldb (byte 6 6) code))
     1884                      (z (ldb (byte 6 0) code)))
     1885                 (declare (fixnum x y z))
     1886                 (fasl-out-byte (logior #xe0 x))
     1887                 (fasl-out-byte (logior #x80 y))
     1888                 (fasl-out-byte (logior #x80 z))))
     1889              (t
     1890                (let* ((w (ldb (byte 3 18) code))
     1891                       (x (ldb (byte 6 12) code))
     1892                       (y (ldb (byte 6 6) code))
     1893                       (z (ldb (byte 6 0) code)))
     1894                  (declare (fixnum w x y z))
     1895                  (fasl-out-byte (logior #xf0 w))
     1896                  (fasl-out-byte (logior #x80 x))
     1897                  (fasl-out-byte (logior #x80 y))
     1898                  (fasl-out-byte (logior #x80 z)))))))))
     1899
    18541900
    18551901(defun fasl-out-ivect (iv &optional
Note: See TracChangeset for help on using the changeset viewer.