Changeset 10355


Ignore:
Timestamp:
Aug 5, 2008, 11:18:54 AM (11 years ago)
Author:
gb
Message:

Fixes from working-0711.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-unicode.lisp

    r9879 r10355  
    7777  octets-in-string-function              ;(STRING START END)
    7878
    79   ;; Returns the number of (full) characters encoded in VECTOR, and the index
    80   ;; of the first octet not used to encode them. (The second value may be less than END).
     79  ;; Returns the number of (full) characters encoded in VECTOR, and
     80  ;; the index the index of the first octet not used to encode
     81  ;; them. (The second value may be less than END.
    8182  length-of-vector-encoding-function    ;(VECTOR START END)
    8283
     
    113114(defconstant byte-order-mark #\u+feff)
    114115(defconstant byte-order-mark-char-code (char-code byte-order-mark))
    115 (defconstant swapped-byte-order-mark #\u+fffe)
    116 (defconstant swapped-byte-order-mark-char-code (char-code swapped-byte-order-mark))
     116(defconstant swapped-byte-order-mark-char-code #xfffe)
    117117
    118118
     
    179179  (if (>= end start)
    180180    (values (- end start) end)
    181     (values 0 0)))
     181    (values 0 start)))
    182182
    183183(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start)
    184184  (declare (ignore pointer start))
    185   noctets)
     185  (values noctets noctets))
    186186
    187187(define-character-encoding :iso-8859-1
     
    29892989                                    (or (>= 1st-unit #xe1)
    29902990                                        (>= s1 #xa0)))
    2991                              (code-char (the fixnum
     2991                             (or (code-char (the fixnum
    29922992                                          (logior (the fixnum
    29932993                                                    (ash (the fixnum (logand 1st-unit #xf))
     
    29992999                                                            6))
    30003000                                                     (the fixnum (logand s2 #x3f)))))))
     3001                                 #\Replacement_Character)
    30013002                             #\Replacement_Character)
    30023003                           (if (< 1st-unit #xf8)
     
    30633064                   (setf (aref vector (the fixnum (+ idx 2)))
    30643065                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    3065                    (setf (aref vector (the fixnum (+ idx 3))) (logand #x3f code))
     3066                   (setf (aref vector (the fixnum (+ idx 3)))
     3067                         (logior #x80 (logand #x3f code)))
    30663068                   (incf idx 4)))))))
    30673069    :vector-decode-function
     
    31413143             (nchars 0))
    31423144            ((>= i end)
    3143              (if (= i end) (values nchars i)))
     3145             (values nchars i))
    31443146         (declare (fixnum i))
    31453147         (let* ((code (aref vector i))
    3146                 (nexti (+ i (cond ((< code #x80) 1)
     3148                (nexti (+ i (cond ((< code #xc2) 1)
    31473149                                  ((< code #xe0) 2)
    31483150                                  ((< code #xf0) 3)
    3149                                   (t 4)))))
     3151                                  ((< code #xf8) 4)
     3152                                  (t 1)))))
    31503153           (declare (type (unsigned-byte 8) code))
    31513154           (if (> nexti end)
     
    36383641     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    36393642              (fixnum idx))
     3643     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
     3644     (incf idx 2)
    36403645     (do* ((i start (1+ i)))
    36413646            ((>= i end) idx)
     
    36623667     (declare (type (simple-array (unsigned-byte 16) (*)) vector)
    36633668              (type index idx))
    3664      (let* ((swap (if (>= noctets 2)
     3669     (let* ((origin idx)
     3670            (swap (if (>= noctets 2)
    36653671                    (case (%native-u8-ref-u16 vector idx)
    36663672                      (#.byte-order-mark-char-code
     
    36703676                      (t #+little-endian-target t)))))
    36713677       (do* ((i 0 (1+ i))
    3672              (end (+ idx noctets))
     3678             (end (+ origin noctets))
    36733679             (index idx))
    36743680            ((= index end) index)
     
    36983704   (lambda (string pointer idx start end)
    36993705     (declare (fixnum idx))
     3706     ;; Output a BOM.
     3707     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
     3708     (incf idx 2)
    37003709     (do* ((i start (1+ i)))
    37013710          ((>= i end) idx)
     
    37053714                  (fixnum highbits))
    37063715         (cond ((< highbits 0)
    3707                 (setf (%get-unsigned-word pointer idx) #+big-endian-target code #+little-endian-target (%swap-u16 code))
     3716                (setf (%get-unsigned-word pointer idx) code)
    37083717                (incf idx 2))
    37093718               (t
    3710                 (let* ((w1 (logior #xd800 (the fixnum (ash highbits -10))))
    3711                        (w2 (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
    3712                   (declare (type (unsigned-byte 16) w1 w2))
    3713                 (setf (%get-unsigned-word pointer idx)
    3714                       #+big-endian-target w1 #+little-endian-target (%swap-u16 w1))
     3719                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
    37153720                (setf (%get-unsigned-word pointer (the fixnum (+ idx 2)))
    3716                       #+big-endian-target w2
    3717                       #+little-endian-target (%swap-u16 w2))
    3718                 (incf idx 4))))))))
     3721                      (logior #xdc00 (the fixnum (logand highbits #x3ff))))
     3722                (incf idx 4)))))))
    37193723  :memory-decode-function
    37203724  (nfunction
     
    37563760             (setf (schar string i) (or char #\Replacement_Character))))))))
    37573761  :octets-in-string-function
    3758   #'utf-16-octets-in-string
     3762  (nfunction
     3763   utf-16-bom-octets-in-string
     3764   (lambda (string start end)
     3765     (+ 2 (utf-16-octets-in-string string start end))))
    37593766  :length-of-vector-encoding-function
    37603767  (nfunction
     
    37623769   (lambda (vector start end)
    37633770     (declare (type (simple-array (unsigned-byte 16) (*)) vector))
    3764      (let* ((swap (when (> end start)
     3771     (let* ((swap (when (>= end (+ start 2))
    37653772                    (case (%native-u8-ref-u16 vector start)
    37663773                      (#.byte-order-mark-char-code
     
    37753782             (nchars 0))
    37763783            ((> j end)
    3777              (if (= i end) (values nchars i)))
     3784             (values nchars i))
    37783785         (let* ((code (if swap
    37793786                        (%reversed-u8-ref-u16 vector i)
     
    37923799   utf-16-length-of-memory-encoding
    37933800   (lambda (pointer noctets start)
    3794      (let* ((swap (when (>= noctets 2)
     3801     (declare (fixnum noctets start))
     3802     (when (oddp noctets)
     3803       (setq noctets (1- noctets)))
     3804     (let* ((origin start)
     3805            (swap (when (>= noctets 2)
    37953806                    (case (%get-unsigned-word pointer (+ start start))
    37963807                      (#.byte-order-mark-char-code
    37973808                       (incf start 2)
    3798                        (decf noctets 2)
    37993809                       nil)
    38003810                      (#.swapped-byte-order-mark-char-code
    38013811                       (incf start 2)
    3802                        (decf noctets 2)
    38033812                       t)
    38043813                      (t #+little-endian-target t)))))
     3814       (declare (fixnum origin))
    38053815       (do* ((i start)
    38063816             (j (+ i 2) (+ i 2))
    3807              (end (+ start noctets))
     3817             (end (+ origin noctets))
    38083818             (nchars 0 (1+ nchars)))
    3809             ((> j end) (values nchars i))
     3819            ((> j end) (values nchars (- i origin)))
     3820         (declare (fixnum (i j end nchars)))
    38103821         (let* ((code (%get-unsigned-word pointer i)))
    38113822           (declare (type (unsigned-byte 16) code))
    38123823           (if swap (setq code (%swap-u16 code)))
    3813            (incf i
    3814                  (if (or (< code #xd800)
    3815                          (>= code #xdc00))
    3816                    2
    3817                    4)))))))
     3824           (let* ((nexti (+ i (if (or (< code #xd800)
     3825                                      (>= code #xdc00))
     3826                                2
     3827                                4))))
     3828             (declare (fixnum nexti))
     3829             (if (> nexti end)
     3830               (return (values nchars (- i origin)))
     3831               (setq i nexti))))))))
    38183832  :decode-literal-code-unit-limit #xd800
    38193833  :encode-literal-char-code-limit #x10000 
     
    38473861    (* 2 (- end start))
    38483862    0))
     3863
     3864(defun ucs-2-length-of-vector-encoding (vector start end)
     3865  (declare (ignore vector))
     3866  (let* ((noctets (max (- end start) 0)))
     3867    (values (ash noctets -1) (+ start (logandc2 noctets 1)))))
     3868
     3869(defun ucs-2-length-of-memory-encoding (pointer noctets start)
     3870  (declare (ignore pointer start))
     3871  (values (ash noctets -1) (logandc2 noctets 1)))
     3872
    38493873
    38503874
     
    39283952  #'ucs-2-octets-in-string
    39293953  :length-of-vector-encoding-function
    3930   (nfunction
    3931    native-ucs-2-length-of-vector-encoding
    3932    (lambda (vector start end)
    3933      (declare (ignore vector))
    3934      (do* ((i start (1+ i))
    3935            (j (+ i 2) (+ i 2))
    3936            (nchars 0 (1+ nchars)))
    3937           ((> j end) (values nchars i)))))
     3954  #'ucs-2-length-of-vector-encoding
    39383955  :length-of-memory-encoding-function
    3939   (nfunction
    3940    native-ucs-2-length-of-memory-encoding
    3941    (lambda (pointer noctets start)
    3942      (declare (ignore pointer))
    3943      (values (floor noctets 2) (+ start noctets))))
     3956  #'ucs-2-length-of-memory-encoding
    39443957  :decode-literal-code-unit-limit #x10000
    39453958  :encode-literal-char-code-limit #x10000 
     
    40274040  #'ucs-2-octets-in-string
    40284041  :length-of-vector-encoding-function
    4029   (nfunction
    4030    reversed-ucs-2-length-of-vector-encoding
    4031    (lambda (vector start end)
    4032      (declare (ignore vector))
    4033      (do* ((i start (1+ i))
    4034            (j (+ i 2) (+ i 2))
    4035            (nchars 0 (1+ nchars)))
    4036           ((> j end) (values nchars i)))))
     4042  #'ucs-2-length-of-vector-encoding
    40374043  :length-of-memory-encoding-function
    4038   (nfunction
    4039    reversed-ucs-2-length-of-memory-encoding
    4040    (lambda (pointer noctets start)
    4041      (declare (ignore pointer))
    4042      (values (floor noctets 2) (+ start noctets))))
     4044  #'ucs-2-length-of-memory-encoding
    40434045  :decode-literal-code-unit-limit #x10000
    40444046  :encode-literal-char-code-limit #x10000
     
    40664068     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    40674069              (fixnum idx))
     4070     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
     4071     (incf idx 2)
    40684072     (do* ((i start (1+ i)))
    40694073          ((>= i end) idx)
     
    41054109   (lambda (string pointer idx start end)
    41064110     (declare (fixnum idx))
     4111     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
     4112     (incf idx 2)
    41074113     (do* ((i start (1+ i)))
    41084114          ((>= i end) idx)
     
    41394145         (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))))
    41404146  :octets-in-string-function
    4141   #'ucs-2-octets-in-string
     4147  (nfunction
     4148   ucs-2-bom-octets-in-string
     4149   (lambda (string start end)
     4150     (+ 2 (ucs-2-octets-in-string string start end))))
    41424151  :length-of-vector-encoding-function
    41434152  (nfunction
    41444153   ucs-2-length-of-vector-encoding
    41454154   (lambda (vector start end)
    4146      (declare (ignore vector))
    4147      (do* ((i start (1+ i))
    4148            (j (+ i 2) (+ i 2))
     4155     (declare (fixnum start end))
     4156     (when (>= end (+ start 2))
     4157       (let* ((maybe-bom (%native-u8-ref-u16 vector start)))
     4158         (declare (type (unsigned-byte 16) maybe-bom))
     4159         (when (or (= maybe-bom byte-order-mark-char-code)
     4160                   (= maybe-bom swapped-byte-order-mark-char-code))
     4161           (incf start 2))))
     4162     (do* ((i start j)
     4163           (j (+ i 2) (+ j 2))
    41494164           (nchars 0 (1+ nchars)))
    41504165          ((> j end) (values nchars i)))))
     
    41534168   ucs-2-length-of-memory-encoding
    41544169   (lambda (pointer noctets start)
    4155      (when (> noctets 1)
    4156        (case (%get-unsigned-word pointer )
    4157          (#.byte-order-mark-char-code
    4158           (incf start 2)
    4159           (decf noctets 2))
    4160          (#.swapped-byte-order-mark-char-code
    4161           (incf start 2)
    4162           (decf noctets 2))))
    4163      (values (floor noctets 2) (+ start noctets))))
     4170     (let* ((skip
     4171             (when (> noctets 1)
     4172               (case (%get-unsigned-word pointer start)
     4173                 (#.byte-order-mark-char-code
     4174                  2)
     4175                 (#.swapped-byte-order-mark-char-code
     4176                  2)))))
     4177     (values (ash (- noctets skip) -1) (logandc2 noctets 1)))))
    41644178  :decode-literal-code-unit-limit #x10000
    41654179  :encode-literal-char-code-limit #x10000 
     
    43384352   (lambda (vector start end)
    43394353     (declare (ignore vector))
    4340      (do* ((i start (1+ i))
    4341            (j (+ i 4) (+ i 4))
     4354     (do* ((i start j)
     4355           (j (+ i 4) (+ j 4))
    43424356           (nchars 0 (1+ nchars)))
    43434357          ((> j end) (values nchars i)))))
     
    43474361   (lambda (pointer noctets start)
    43484362     (declare (ignore pointer))
    4349      (values (floor noctets 4) (+ start noctets))))
     4363     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    43504364  :decode-literal-code-unit-limit #x110000
    43514365  :encode-literal-char-code-limit #x110000
     
    44364450   (lambda (vector start end)
    44374451     (declare (ignore vector))
    4438      (do* ((i start (1+ i))
    4439            (j (+ i 4) (+ i 4))
     4452     (do* ((i start j)
     4453           (j (+ i 4) (+ j 4))
    44404454           (nchars 0 (1+ nchars)))
    44414455          ((> j end) (values nchars i)))))
     
    44454459   (lambda (pointer noctets start)
    44464460     (declare (ignore pointer))
    4447      (values (floor noctets 4) (+ start noctets))))
     4461     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    44484462  :decode-literal-code-unit-limit #x110000
    44494463  :encode-literal-char-code-limit #x110000
     
    44544468    "A 32-bit, fixed-length encoding in which all Unicode characters can be encoded in a single 32-bit word.  The endianness of the encoded data is indicated by the endianness of a byte-order-mark character (#\u+feff) prepended to the data; in the absence of such a character on input, input data is assumed to be in big-endian order.  Output is written in native byte order with a leading byte-order mark."
    44554469   
    4456   :aliases '(:utf-4)
     4470  :aliases '(:ucs-4)
    44574471  :max-units-per-char 1
    44584472  :code-unit-size 32
     
    44684482     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
    44694483              (fixnum idx))
     4484     (setf (%native-u8-ref-u32 vector idx) byte-order-mark-char-code)
     4485     (incf idx 4)
    44704486     (do* ((i start (1+ i)))
    44714487          ((>= i end) idx)
     
    45074523   (lambda (string pointer idx start end)
    45084524     (declare (fixnum idx))
    4509 
     4525     (setf (%get-unsigned-long pointer idx) byte-order-mark-char-code)
     4526     (incf idx 4)
    45104527     (do* ((i start (1+ i)))
    45114528          ((>= i end) idx)
     
    45414558                                    #\Replacement_Character)))))))
    45424559  :octets-in-string-function
    4543   #'ucs-4-octets-in-string
     4560  (nfunction
     4561   utf-32-bom-octets-in-string
     4562   (lambda (string start end)
     4563     (+ 4 (ucs-4-octets-in-string string start end))))
    45444564  :length-of-vector-encoding-function
    45454565  (nfunction
    45464566   utf-32-length-of-vector-encoding
    45474567   (lambda (vector start end)
    4548      (declare (ignore vector))
    4549      (do* ((i start (1+ i))
    4550            (j (+ i 2) (+ i 2))
     4568     (when (>= end (+ start 4))
     4569       (let* ((maybe-bom (%native-u8-ref-u32 vector start)))
     4570         (declare (type (unsigned-byte 32) maybe-bom))
     4571         (when (or (= maybe-bom byte-order-mark-char-code)
     4572                   (= maybe-bom swapped-byte-order-mark-char-code))
     4573           (incf start 4))))
     4574     (do* ((i start j)
     4575           (j (+ i 4) (+ J 4))
    45514576           (nchars 0 (1+ nchars)))
    45524577          ((> j end) (values nchars i)))))
     
    45554580   utf-32-length-of-memory-encoding
    45564581   (lambda (pointer noctets start)
    4557      (when (> noctets 1)
     4582     (when (> noctets 3)
    45584583       (case (%get-unsigned-long pointer )
    45594584         (#.byte-order-mark-char-code
     
    45634588          (incf start 4)
    45644589          (decf noctets 4))))
    4565      (values (floor noctets 4) (+ start noctets))))
     4590     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
    45664591  :decode-literal-code-unit-limit #x110000
    45674592  :encode-literal-char-code-limit #x110000 
     
    46044629(defvar *cr-newline-string* (make-string 1 :initial-element #\Return))
    46054630(defvar *crlf-newline-string* (make-array 2 :element-type 'character :initial-contents '(#\Return #\Linefeed)))
    4606 (defvar *nul-string (make-string 1 :initial-element #\Nul))
     4631(defvar *nul-string* (make-string 1 :initial-element #\Nul))
    46074632
    46084633(defun string-size-in-octets (string &key
Note: See TracChangeset for help on using the changeset viewer.