source: branches/working-0710/ccl/level-0/l0-io.lisp @ 7393

Last change on this file since 7393 was 7393, checked in by gb, 13 years ago

UTF-8 earlier.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.1 KB
Line 
1; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel)
20  #+linuxppc-target
21  (require "PPC-LINUX-SYSCALLS")
22  #+linuxx8664-target
23  (require "X8664-LINUX-SYSCALLS")
24  #+darwinppc-target
25  (require "DARWINPPC-SYSCALLS")
26  #+darwinx8664-target
27  (require "DARWINX8664-SYSCALLS")
28  #+freebsd-target
29  (require "X8664-FREEBSD-SYSCALLS")
30  )
31
32
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.
163(defun fd-write (fd buf nbytes)
164  (syscall syscalls::write fd buf nbytes))
165
166(defun fd-read (fd buf nbytes)
167  (loop
168    (let* ((n  (syscall syscalls::read fd buf nbytes)))
169      (unless (eql n (- #$EINTR)) (return n)))))
170
171
172(defun fd-open (path flags &optional (create-mode #o666))
173  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
174    (syscall syscalls::open p flags create-mode)))
175
176(defun fd-chmod (fd mode)
177  (syscall syscalls::fchmod fd mode))
178
179;;; This should really be conditionalized on whether the seek system
180;;; call supports 64-bit offsets or on whether one has to use some
181;;; variant.
182#+(and ppc32-target linux-target)
183(defun fd-lseek (fd offset whence)
184  (let* ((high (ldb (byte 32 32) offset))
185         (low (ldb (byte 32 0) offset)))
186    (declare (type (unsigned-byte 32) high low))
187    (%stack-block ((pos 8))
188      (let* ((res (syscall syscalls::_llseek fd high low pos whence)))
189        (declare (fixnum res))
190        (if (< res 0)
191          res
192          (let* ((pos-high (%get-unsigned-long pos 0))
193                 (pos-low (%get-unsigned-long pos 4)))
194            (declare (type (unsigned-byte 32) pos-high pos-low))
195            (if (zerop pos-high)
196              pos-low
197              (dpb pos-high (byte 32 32) pos-low))))))))
198
199#-(and ppc32-target linux-target)
200(defun fd-lseek (fd offset whence)
201  #+freebsd-target
202  (syscall syscalls::lseek fd 0 offset whence)
203  #-freebsd-target
204  (syscall syscalls::lseek fd offset whence))
205
206(defun fd-close (fd)
207  (syscall syscalls::close fd)) 
208
209(defun fd-tell (fd)
210  (fd-lseek fd 0 #$SEEK_CUR))
211
212;;; Kernels prior to 2.4 don't seem to have a "stat" variant
213;;; that handles 64-bit file offsets.
214(defun fd-size (fd)
215  (without-interrupts
216   (let* ((curpos (fd-lseek fd 0 #$SEEK_CUR)))
217     (unwind-protect
218          (fd-lseek fd 0 #$SEEK_END)
219       (fd-lseek fd curpos #$SEEK_SET)))))
220
221(defun fd-ftruncate (fd new)
222  (syscall syscalls::ftruncate fd new))
223
224(defun %string-to-stderr (str)
225  (with-cstrs ((s str))
226    (fd-write 2 s (length str))))
227
228(defun pdbg (string)
229  (%string-to-stderr string)
230  (%string-to-stderr #.(string #\LineFeed)))
231
232
233
234;;; Not really I/O, but ...
235(defun malloc (size)
236  (ff-call 
237   (%kernel-import target::kernel-import-malloc)
238   :unsigned-fullword size :address))
239
240(defun free (ptr)
241  (let* ((size (uvsize ptr))
242         (flags (if (= size target::xmacptr.size)
243                  (uvref ptr target::xmacptr.flags-cell)
244                  $flags_DisposPtr)))
245    (declare (fixnum size flags))
246    (if (= flags $flags_DisposPtr)
247      (with-macptrs ((addr ptr))
248        (when (= size target::xmacptr.size)
249          (%setf-macptr ptr (%null-ptr))
250          (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal))
251        (ff-call 
252         (%kernel-import target::kernel-import-free)
253         :address addr :void)))))
254
255
256
257
Note: See TracBrowser for help on using the repository browser.