Changeset 7393 for branches

Timestamp:

Oct 12, 2007, 2:26:02 AM (17 years ago)

Author:

Gary Byers

Message:

UTF-8 earlier.

File:

• branches/working-0710/ccl/level-0/l0-io.lisp (modified) (2 diffs)

branches/working-0710/ccl/level-0/l0-io.lisp

@@ -31 +31 @@
 
 
-; write nbytes bytes from buffer buf to file-descriptor fd.
+(defun utf-8-octets-in-string (string start end)
+  (if (>= end start)
+    (do* ((noctets 0)
+          (i start (1+ i)))
+         ((= i end) noctets)
+      (declare (fixnum noctets))
+      (let* ((code (char-code (schar string i))))
+        (declare (type (mod #x110000) code))
+        (incf noctets
+              (if (< code #x80)
+                1
+                (if (< code #x800)
+                  2
+                  (if (< code #x10000)
+                    3
+                    4))))))
+    0))
+
+(defun utf-8-memory-encode (string pointer idx start end)
+  (declare (fixnum idx))
+  (do* ((i start (1+ i)))
+       ((>= i end) idx)
+    (let* ((code (char-code (schar string i))))
+      (declare (type (mod #x110000) code))
+      (cond ((< code #x80)
+             (setf (%get-unsigned-byte pointer idx) code)
+             (incf idx))
+            ((< code #x800)
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xc0 (the fixnum (ash code -6))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand code #x3f))))
+             (incf idx 2))
+            ((< code #x10000)
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xe0 (the fixnum (ash code -12))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                   (logior #x80 (the fixnum (logand code #x3f))))
+             (incf idx 3))
+            (t
+             (setf (%get-unsigned-byte pointer idx)
+                   (logior #xf0
+                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
+                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
+             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
+                   (logand #x3f code))
+             (incf idx 4))))))
+
+(defun utf-8-memory-decode (pointer noctets idx string)
+  (declare (fixnum noctets idx))
+  (do* ((i 0 (1+ i))
+        (end (+ idx noctets))
+        (index idx (1+ index)))
+       ((>= index end) (if (= index end) index 0))
+    (let* ((1st-unit (%get-unsigned-byte pointer index)))
+      (declare (type (unsigned-byte 8) 1st-unit))
+      (let* ((char (if (< 1st-unit #x80)
+                     (code-char 1st-unit)
+                     (if (>= 1st-unit #xc2)
+                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
+                         (declare (type (unsigned-byte 8) 2nd-unit))
+                         (if (< 1st-unit #xe0)
+                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                             (code-char
+                              (logior
+                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
+                               (the fixnum (logxor 2nd-unit #x80)))))
+                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
+                             (declare (type (unsigned-byte 8) 3rd-unit))
+                             (if (< 1st-unit #xf0)
+                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                        (or (>= 1st-unit #xe1)
+                                            (>= 2nd-unit #xa0)))
+                                 (code-char (the fixnum
+                                              (logior (the fixnum
+                                                        (ash (the fixnum (logand 1st-unit #xf))
+                                                             12))
+                                                      (the fixnum
+                                                        (logior
+                                                         (the fixnum
+                                                           (ash (the fixnum (logand 2nd-unit #x3f))
+                                                                6))
+                                                         (the fixnum (logand 3rd-unit #x3f))))))))
+                               (if (< 1st-unit #xf8)
+                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
+                                   (declare (type (unsigned-byte 8) 4th-unit))
+                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
+                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
+                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
+                                            (or (>= 1st-unit #xf1)
+                                                (>= 2nd-unit #x90)))
+                                     (code-char
+                                      (logior
+                                       (the fixnum
+                                         (logior
+                                          (the fixnum
+                                            (ash (the fixnum (logand 1st-unit 7)) 18))
+                                          (the fixnum
+                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
+                                       (the fixnum
+                                         (logior
+                                          (the fixnum
+                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
+                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
+        (setf (schar string i) (or char #\Replacement_Character))))))
+
+(defun utf-8-length-of-memory-encoding (pointer noctets start)
+  (do* ((i start)
+        (end (+ start noctets))
+        (nchars 0 (1+ nchars)))
+       ((= i end) (values nchars i))
+    (let* ((code (%get-unsigned-byte pointer i))
+           (nexti (+ i (cond ((< code #x80) 1)
+                             ((< code #xe0) 2)
+                             ((< code #xf0) 3)
+                             (t 4)))))
+      (declare (type (unsigned-byte 8) code))
+      (if (> nexti end)
+        (return (values nchars i))
+        (setq i nexti)))))
+
+
+
+;;; write nbytes bytes from buffer buf to file-descriptor fd.
 (defun fd-write (fd buf nbytes)
   (syscall syscalls::write fd buf nbytes))
@@ -42 +171 @@
 
 (defun fd-open (path flags &optional (create-mode #o666))
-  (with-cstrs ((p path))
+  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
     (syscall syscalls::open p flags create-mode)))