Changeset 7393 for branches/working-0710


Ignore:
Timestamp:
Oct 12, 2007, 9:26:02 AM (13 years ago)
Author:
gb
Message:

UTF-8 earlier.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0710/ccl/level-0/l0-io.lisp

    r6181 r7393  
    3131
    3232
    33 ; write nbytes bytes from buffer buf to file-descriptor fd.
     33(defun utf-8-octets-in-string (string start end)
     34  (if (>= end start)
     35    (do* ((noctets 0)
     36          (i start (1+ i)))
     37         ((= i end) noctets)
     38      (declare (fixnum noctets))
     39      (let* ((code (char-code (schar string i))))
     40        (declare (type (mod #x110000) code))
     41        (incf noctets
     42              (if (< code #x80)
     43                1
     44                (if (< code #x800)
     45                  2
     46                  (if (< code #x10000)
     47                    3
     48                    4))))))
     49    0))
     50
     51(defun utf-8-memory-encode (string pointer idx start end)
     52  (declare (fixnum idx))
     53  (do* ((i start (1+ i)))
     54       ((>= i end) idx)
     55    (let* ((code (char-code (schar string i))))
     56      (declare (type (mod #x110000) code))
     57      (cond ((< code #x80)
     58             (setf (%get-unsigned-byte pointer idx) code)
     59             (incf idx))
     60            ((< code #x800)
     61             (setf (%get-unsigned-byte pointer idx)
     62                   (logior #xc0 (the fixnum (ash code -6))))
     63             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     64                   (logior #x80 (the fixnum (logand code #x3f))))
     65             (incf idx 2))
     66            ((< code #x10000)
     67             (setf (%get-unsigned-byte pointer idx)
     68                   (logior #xe0 (the fixnum (ash code -12))))
     69             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     70                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     71             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     72                   (logior #x80 (the fixnum (logand code #x3f))))
     73             (incf idx 3))
     74            (t
     75             (setf (%get-unsigned-byte pointer idx)
     76                   (logior #xf0
     77                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
     78             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     79                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
     80             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     81                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     82             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
     83                   (logand #x3f code))
     84             (incf idx 4))))))
     85
     86(defun utf-8-memory-decode (pointer noctets idx string)
     87  (declare (fixnum noctets idx))
     88  (do* ((i 0 (1+ i))
     89        (end (+ idx noctets))
     90        (index idx (1+ index)))
     91       ((>= index end) (if (= index end) index 0))
     92    (let* ((1st-unit (%get-unsigned-byte pointer index)))
     93      (declare (type (unsigned-byte 8) 1st-unit))
     94      (let* ((char (if (< 1st-unit #x80)
     95                     (code-char 1st-unit)
     96                     (if (>= 1st-unit #xc2)
     97                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
     98                         (declare (type (unsigned-byte 8) 2nd-unit))
     99                         (if (< 1st-unit #xe0)
     100                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     101                             (code-char
     102                              (logior
     103                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
     104                               (the fixnum (logxor 2nd-unit #x80)))))
     105                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
     106                             (declare (type (unsigned-byte 8) 3rd-unit))
     107                             (if (< 1st-unit #xf0)
     108                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     109                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     110                                        (or (>= 1st-unit #xe1)
     111                                            (>= 2nd-unit #xa0)))
     112                                 (code-char (the fixnum
     113                                              (logior (the fixnum
     114                                                        (ash (the fixnum (logand 1st-unit #xf))
     115                                                             12))
     116                                                      (the fixnum
     117                                                        (logior
     118                                                         (the fixnum
     119                                                           (ash (the fixnum (logand 2nd-unit #x3f))
     120                                                                6))
     121                                                         (the fixnum (logand 3rd-unit #x3f))))))))
     122                               (if (< 1st-unit #xf8)
     123                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
     124                                   (declare (type (unsigned-byte 8) 4th-unit))
     125                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     126                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     127                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
     128                                            (or (>= 1st-unit #xf1)
     129                                                (>= 2nd-unit #x90)))
     130                                     (code-char
     131                                      (logior
     132                                       (the fixnum
     133                                         (logior
     134                                          (the fixnum
     135                                            (ash (the fixnum (logand 1st-unit 7)) 18))
     136                                          (the fixnum
     137                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
     138                                       (the fixnum
     139                                         (logior
     140                                          (the fixnum
     141                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
     142                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
     143        (setf (schar string i) (or char #\Replacement_Character))))))
     144
     145(defun utf-8-length-of-memory-encoding (pointer noctets start)
     146  (do* ((i start)
     147        (end (+ start noctets))
     148        (nchars 0 (1+ nchars)))
     149       ((= i end) (values nchars i))
     150    (let* ((code (%get-unsigned-byte pointer i))
     151           (nexti (+ i (cond ((< code #x80) 1)
     152                             ((< code #xe0) 2)
     153                             ((< code #xf0) 3)
     154                             (t 4)))))
     155      (declare (type (unsigned-byte 8) code))
     156      (if (> nexti end)
     157        (return (values nchars i))
     158        (setq i nexti)))))
     159
     160
     161
     162;;; write nbytes bytes from buffer buf to file-descriptor fd.
    34163(defun fd-write (fd buf nbytes)
    35164  (syscall syscalls::write fd buf nbytes))
     
    42171
    43172(defun fd-open (path flags &optional (create-mode #o666))
    44   (with-cstrs ((p path))
     173  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
    45174    (syscall syscalls::open p flags create-mode)))
    46175
Note: See TracChangeset for help on using the changeset viewer.