Changeset 13210 for branches/purify


Ignore:
Timestamp:
Nov 18, 2009, 4:45:21 PM (10 years ago)
Author:
gb
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:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/purify/source/level-0/nfasload.lisp

    r12300 r13210  
    142142       
    143143
     144(defun %fasl-read-utf-8-string (s string nchars nextra)
     145  (declare (fixnum nchars nextra))
     146  (if (eql 0 nextra)
     147    (dotimes (i nchars)
     148      (setf (%scharcode string i) (%fasl-read-byte s)))
     149    (flet ((trailer-byte ()
     150             (when (> nextra 0)
     151               (decf nextra)
     152               (let* ((b (%fasl-read-byte s)))
     153                 (declare ((unsigned-byte 8) b))
     154                 (and (>= b #x80)
     155                      (< b #xc0)
     156                      (logand b #x3f))))))
     157      (declare (inline trailer-byte))
     158      (dotimes (i nchars)
     159        (let* ((b0 (%fasl-read-byte s)))
     160          (declare ((unsigned-byte 8) b0))
     161          (setf (%scharcode string i)
     162                (or
     163                 (cond ((< b0 #x80) b0)
     164                       ((and (>= b0 #xc2)
     165                             (< b0 #xe0))
     166                        (let* ((b1 (trailer-byte)))
     167                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
     168                       ((and (>= b0 #xe0)
     169                             (< b0 #xf0))
     170                        (let* ((b1 (trailer-byte))
     171                               (b2 (trailer-byte)))
     172                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
     173                                             (logior (ash b1 6)
     174                                                     b2)))))
     175                       ((and (>= b0 #xf0)
     176                             (< b0 #xf5))
     177                        (let* ((b1 (trailer-byte))
     178                               (b2 (trailer-byte))
     179                               (b3 (trailer-byte)))
     180                          (and b1
     181                               b2
     182                               b3
     183                               (logior (ash (logand b0 #x7) 18)
     184                                       (logior (ash b1 12)
     185                                               (logior (ash b2 6)
     186                                                       b3)))))))
     187                 (char-code #\Replacement_Character))))))))
     188
     189
    144190(defun %fasl-vreadstr (s)
    145   (let* ((nbytes (%fasl-read-count s))
     191  (let* ((nchars (%fasl-read-count s))
     192         (nextra (%fasl-read-count s))
    146193         (copy t)
    147          (n nbytes)
     194         (n nchars)
    148195         (str (faslstate.faslstr s)))
    149     (declare (fixnum n nbytes))
     196    (declare (fixnum nchars n nextra))
    150197    (if (> n (length str))
    151         (setq str (make-string n :element-type 'base-char))
    152         (setq copy nil))
    153     (%fasl-read-n-bytes s str 0 nbytes)
    154     (values str n copy)))
     198      (setq str (make-string n :element-type 'base-char))
     199      (setq copy nil))
     200    (%fasl-read-utf-8-string s str nchars nextra)
     201    (values str nchars copy)))
    155202
    156203
     
    205252(defun %fasl-vmake-symbol (s &optional idx)
    206253  (let* ((n (%fasl-read-count s))
     254         (nextra (%fasl-read-count s))
    207255         (str (make-string n :element-type 'base-char)))
    208256    (declare (fixnum n))
    209     (%fasl-read-n-bytes s str 0 n)
     257    (%fasl-read-utf-8-string s str n nextra)
    210258    (let* ((sym (make-symbol str)))
    211259      (when idx (ensure-binding-index sym))
     
    424472
    425473(deffaslop $fasl-vstr (s)
    426   (let* ((n (%fasl-read-count s))
    427          (str (make-string (the fixnum n) :element-type 'base-char)))
     474  (let* ((nchars (%fasl-read-count s))
     475         (nextra (%fasl-read-count s))
     476         (str (make-string (the fixnum nchars) :element-type 'base-char)))
    428477    (%epushval s str)
    429     (%fasl-read-n-bytes s str 0 n)))
     478    (%fasl-read-utf-8-string s str nchars nextra)))
     479
    430480
    431481(deffaslop $fasl-nvstr (s)
  • branches/purify/source/xdump/xfasload.lisp

    r12886 r13210  
    11861186  (%epushval s (xload-make-sfloat *xload-readonly-space* (%fasl-read-long s))))
    11871187
     1188(defun xload-read-utf-8-string (s v o nchars nextra)
     1189  (declare (fixnum nchars nextra))
     1190  (if (eql 0 nextra)
     1191    (dotimes (i nextra)
     1192      (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
     1193            (%fasl-read-byte s)) )
     1194    (flet ((trailer-byte ()
     1195             (when (> nextra 0)
     1196               (decf nextra)
     1197               (let* ((b (%fasl-read-byte s)))
     1198                 (declare ((unsigned-byte 8) b))
     1199                 (and (>= b #x80)
     1200                      (< b #xc0)
     1201                      (logand b #x3f))))))
     1202      (declare (inline trailer-byte))
     1203      (dotimes (i nchars)
     1204        (let* ((b0 (%fasl-read-byte s)))
     1205          (declare ((unsigned-byte 8) b0))
     1206          (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
     1207                (or
     1208                 (cond ((< b0 #x80) b0)
     1209                       ((and (>= b0 #xc2)
     1210                             (< b0 #xe0))
     1211                        (let* ((b1 (trailer-byte)))
     1212                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
     1213                       ((and (>= b0 #xe0)
     1214                             (< b0 #xf0))
     1215                        (let* ((b1 (trailer-byte))
     1216                               (b2 (trailer-byte)))
     1217                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
     1218                                             (logior (ash b1 6)
     1219                                                     b2)))))
     1220                       ((and (>= b0 #xf0)
     1221                             (< b0 #xf5))
     1222                        (let* ((b1 (trailer-byte))
     1223                               (b2 (trailer-byte))
     1224                               (b3 (trailer-byte)))
     1225                          (and b1
     1226                               b2
     1227                               b3
     1228                               (logior (ash (logand b0 #x7) 18)
     1229                                       (logior (ash b1 12)
     1230                                               (logior (ash b2 6)
     1231                                                       b3)))))))
     1232                 (char-code #\Replacement_Character))))))))
     1233
     1234
    11881235(defxloadfaslop $fasl-vstr (s)
    1189   (let* ((n (%fasl-read-count s)))
    1190     (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n)
     1236  (let* ((nchars (%fasl-read-count s))
     1237         (nextra (%fasl-read-count s)))
     1238    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string nchars)
    11911239      (%epushval s str)
    1192       (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) n)
     1240      (xload-read-utf-8-string s v o nchars nextra)
    11931241      str)))
    11941242
Note: See TracChangeset for help on using the changeset viewer.