Changeset 13219 for branches/purify


Ignore:
Timestamp:
Nov 20, 2009, 12:11:58 PM (10 years ago)
Author:
gb
Message:

Try to save strings in ASCII if possible.

File:
1 edited

Legend:

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

    r13216 r13219  
    1 ;;-*-Mode: LISP; Package: CCL -*-
     1;;;-*-Mode: LISP; Package: CCL -*-
    22;;;
    33;;;   Copyright (C) 1994-2001 Digitool, Inc
     
    14891489    (double-float (fasl-dump-dfloat exp))
    14901490    (single-float (fasl-dump-sfloat exp))
    1491     (simple-string (fasl-out-opcode $fasl-vstr exp) (fasl-out-vstring exp))
     1491    (simple-string
     1492     (let* ((nextra (utf-8-extra-bytes exp)))
     1493       (cond ((= 0 nextra)
     1494              (fasl-out-opcode $fasl-nvstr exp)
     1495              (fasl-out-nvstring exp))
     1496             (t (fasl-out-opcode $fasl-vstr exp)
     1497                (fasl-out-vstring exp nextra)))))
    14921498    (simple-bit-vector (fasl-dump-bit-vector exp))
    14931499    ((simple-array (unsigned-byte 8) (*))
     
    17641770
    17651771(defun fasl-dump-package (pkg)
    1766   (let ((name (package-name pkg)))
    1767     (fasl-out-opcode $fasl-vpkg pkg)
    1768     (fasl-out-vstring name)))
     1772  (let* ((name (package-name pkg))
     1773         (nextra (utf-8-extra-bytes name)))
     1774    (cond ((eql nextra 0)
     1775           (fasl-out-opcode $fasl-nvpkg pkg)
     1776           (fasl-out-nvstring name))
     1777          (t
     1778           (fasl-out-opcode $fasl-vpkg pkg)
     1779           (fasl-out-vstring name nextra)))))
    17691780
    17701781
     
    18121823  (let* ((pkg (symbol-package sym))
    18131824         (name (symbol-name sym))
     1825         (nextra (utf-8-extra-bytes name))
     1826         (ascii (eql nextra 0))
    18141827         (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
    18151828                (declare (fixnum i))
     
    18171830    (cond ((null pkg)
    18181831           (progn
    1819              (fasl-out-opcode (if idx $fasl-vmksym-special $fasl-vmksym) sym)
    1820              (fasl-out-vstring name)))
     1832             (fasl-out-opcode (if idx
     1833                                (if ascii $fasl-nvmksym-special $fasl-vmksym-special)
     1834                                (if ascii $fasl-nvmksym $fasl-vmksym))
     1835                              sym)
     1836             (if ascii
     1837               (fasl-out-nvstring name)
     1838               (fasl-out-vstring name nextra))))
    18211839          (*fasdump-epush*
    18221840           (progn
    18231841             (fasl-out-byte (fasl-epush-op (if idx
    1824                                              $fasl-vpkg-intern-special
    1825                                              $fasl-vpkg-intern)))
     1842                                             (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
     1843                                             (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern))))
    18261844             (fasl-dump-form pkg)
    18271845             (fasl-dump-epush sym)
    1828              (fasl-out-vstring name)))
     1846             (if ascii
     1847               (fasl-out-nvstring name)
     1848               (fasl-out-vstring name nextra))))
    18291849          (t
    18301850           (progn
    18311851             (fasl-out-byte (if idx
    1832                               $fasl-vpkg-intern-special
    1833                               $fasl-vpkg-intern))
     1852                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special)
     1853                              (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern)))
    18341854             (fasl-dump-form pkg)
    1835              (fasl-out-vstring name))))))
     1855             (if ascii
     1856               (fasl-out-nvstring name)
     1857               (fasl-out-vstring name nextra)))))))
    18361858
    18371859
     
    18441866       ((= k end))
    18451867    (declare (fixnum k))
    1846     (fasl-out-count (char-code (schar str k)))))
     1868    (fasl-out-byte (char-code (schar str k)))))
    18471869
    18481870(defun fasl-out-nvstring (str)
     
    18501872  (fasl-out-simple-string str 0 (length str)))
    18511873
    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 extra 2))
    1863             ((>= code #x80) (incf extra 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))
     1874(defun utf-8-extra-bytes (string)
     1875  (declare (simple-string string))
     1876  (let* ((extra 0))
     1877    (declare (fixnum extra))
     1878    (dotimes (i (length string) extra)
     1879      (let* ((code (%scharcode string i)))
     1880        (declare ((mod #x110000) code))
     1881        (cond ((>= code #x10000) (incf extra 3))
     1882              ((>= code #x800) (incf extra 2))
     1883              ((>= code #x80) (incf extra 1)))))))
     1884
     1885(defun fasl-out-vstring (str nextra)
     1886  (declare (fixnum nextra))
     1887  (let* ((len (length str)))
     1888    (declare (fixnum len))
    18691889    (fasl-out-count len)
    18701890    (fasl-out-count nextra)
Note: See TracChangeset for help on using the changeset viewer.