source: branches/qres/ccl/level-0/l0-io.lisp @ 14055

Last change on this file since 14055 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.4 KB
Line 
1; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20
21
22
23(defun utf-8-octets-in-string (string start end)
24  (if (>= end start)
25    (do* ((noctets 0)
26          (i start (1+ i)))
27         ((= i end) noctets)
28      (declare (fixnum noctets))
29      (let* ((code (char-code (schar string i))))
30        (declare (type (mod #x110000) code))
31        (incf noctets
32              (if (< code #x80)
33                1
34                (if (< code #x800)
35                  2
36                  (if (< code #x10000)
37                    3
38                    4))))))
39    0))
40
41(defun utf-16-octets-in-string (string start end)
42  (if (>= end start)
43    (do* ((noctets 0)
44          (i start (1+ i)))
45         ((= i end) noctets)
46      (declare (fixnum noctets))
47      (let* ((code (char-code (schar string i))))
48        (declare (type (mod #x110000) code))
49        (incf noctets
50              (if (< code #x10000)
51                2
52                4))))
53    0))
54
55(defun utf-8-memory-encode (string pointer idx start end)
56  (declare (fixnum idx))
57  (do* ((i start (1+ i)))
58       ((>= i end) idx)
59    (let* ((code (char-code (schar string i))))
60      (declare (type (mod #x110000) code))
61      (cond ((< code #x80)
62             (setf (%get-unsigned-byte pointer idx) code)
63             (incf idx))
64            ((< code #x800)
65             (setf (%get-unsigned-byte pointer idx)
66                   (logior #xc0 (the fixnum (ash code -6))))
67             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
68                   (logior #x80 (the fixnum (logand code #x3f))))
69             (incf idx 2))
70            ((< code #x10000)
71             (setf (%get-unsigned-byte pointer idx)
72                   (logior #xe0 (the fixnum (ash code -12))))
73             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
74                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
75             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
76                   (logior #x80 (the fixnum (logand code #x3f))))
77             (incf idx 3))
78            (t
79             (setf (%get-unsigned-byte pointer idx)
80                   (logior #xf0
81                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
82             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
83                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
84             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
85                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
86             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
87                   (logior #x80 (logand #x3f code)))
88             (incf idx 4))))))
89
90(defun native-utf-16-memory-encode (string pointer idx start end)
91  (declare (fixnum idx))
92  (do* ((i start (1+ i)))
93       ((>= i end) idx)
94    (let* ((code (char-code (schar string i)))
95           (highbits (- code #x10000)))
96      (declare (type (mod #x110000) code)
97               (fixnum  highbits))
98      (cond ((< highbits 0)
99             (setf (%get-unsigned-word pointer idx) code)
100             (incf idx 2))
101            (t
102             (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
103             (incf idx 2)
104             (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff))))
105             (incf idx 2))))))
106
107(defun utf-8-memory-decode (pointer noctets idx string)
108  (declare (fixnum noctets idx))
109  (do* ((i 0 (1+ i))
110        (end (+ idx noctets))
111        (index idx (1+ index)))
112       ((>= index end) (if (= index end) index 0))
113    (let* ((1st-unit (%get-unsigned-byte pointer index)))
114      (declare (type (unsigned-byte 8) 1st-unit))
115      (let* ((char (if (< 1st-unit #x80)
116                     (code-char 1st-unit)
117                     (if (>= 1st-unit #xc2)
118                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
119                         (declare (type (unsigned-byte 8) 2nd-unit))
120                         (if (< 1st-unit #xe0)
121                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
122                             (code-char
123                              (logior
124                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
125                               (the fixnum (logxor 2nd-unit #x80)))))
126                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
127                             (declare (type (unsigned-byte 8) 3rd-unit))
128                             (if (< 1st-unit #xf0)
129                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
130                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
131                                        (or (>= 1st-unit #xe1)
132                                            (>= 2nd-unit #xa0)))
133                                 (code-char (the fixnum
134                                              (logior (the fixnum
135                                                        (ash (the fixnum (logand 1st-unit #xf))
136                                                             12))
137                                                      (the fixnum
138                                                        (logior
139                                                         (the fixnum
140                                                           (ash (the fixnum (logand 2nd-unit #x3f))
141                                                                6))
142                                                         (the fixnum (logand 3rd-unit #x3f))))))))
143                               (if (< 1st-unit #xf8)
144                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
145                                   (declare (type (unsigned-byte 8) 4th-unit))
146                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
147                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
148                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
149                                            (or (>= 1st-unit #xf1)
150                                                (>= 2nd-unit #x90)))
151                                     (code-char
152                                      (logior
153                                       (the fixnum
154                                         (logior
155                                          (the fixnum
156                                            (ash (the fixnum (logand 1st-unit 7)) 18))
157                                          (the fixnum
158                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
159                                       (the fixnum
160                                         (logior
161                                          (the fixnum
162                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
163                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
164        (setf (schar string i) (or char #\Replacement_Character))))))
165
166(defun utf-8-length-of-memory-encoding (pointer noctets start)
167  (do* ((i start)
168        (end (+ start noctets))
169        (nchars 0 (1+ nchars)))
170       ((= i end) (values nchars (- i start)))
171    (let* ((code (%get-unsigned-byte pointer i))
172           (nexti (+ i (cond ((< code #xc2) 1)
173                             ((< code #xe0) 2)
174                             ((< code #xf0) 3)
175                             ((< code #xf8) 4)
176                             (t 1)))))
177      (declare (type (unsigned-byte 8) code))
178      (if (> nexti end)
179        (return (values nchars (- i start)))
180        (setq i nexti)))))
181
182
183
184;;; write nbytes bytes from buffer buf to file-descriptor fd.
185(defun fd-write (fd buf nbytes)
186  (ignoring-eintr
187   (int-errno-ffcall
188    (%kernel-import target::kernel-import-lisp-write)
189             :int fd :address buf :ssize_t nbytes :ssize_t)))
190
191(defun fd-read (fd buf nbytes)
192  (ignoring-eintr
193   (int-errno-ffcall
194    (%kernel-import target::kernel-import-lisp-read)
195             :int fd :address buf :ssize_t nbytes :ssize_t)))
196
197
198(let* ((pathname-encoding-name ()))
199  (declare (ignorable pathname-encoding-name))
200  (defun pathname-encoding-name ()
201    #+darwin-target :utf-8
202    #+windows-target :utf-16le
203    #-(or darwin-target windows-target) pathname-encoding-name)
204  (defun set-pathname-encoding-name (new)
205    #+(or darwin-target windows-target) (declare (ignore new))
206    #+darwin-target :utf-8
207    #+windows-target :utf-16le
208    #-(or darwin-target windows-target)
209    (let* ((encoding (ensure-character-encoding new)))
210      (setq pathname-encoding-name
211            (unless (eq encoding (get-character-encoding nil))
212              (character-encoding-name encoding))))))
213
214
215(defun fd-open-path (p flags create-mode)
216  (let* ((fd (int-errno-ffcall
217              (%kernel-import target::kernel-import-lisp-open)
218              :address p :int flags :mode_t create-mode :int)))
219    (declare (fixnum fd))
220    (when (or (= fd (- #$EMFILE))
221              (= fd (- #$ENFILE)))
222      (gc)
223      (drain-termination-queue)
224      (setq fd (int-errno-ffcall
225                (%kernel-import target::kernel-import-lisp-open)
226                :address p :int flags :mode_t create-mode :int)))
227    fd))
228
229(defun fd-open (path flags &optional (create-mode #o666))
230  #+darwin-target (with-utf-8-cstrs ((p path))
231                    (fd-open-path p flags create-mode))
232  #+windows-target (with-native-utf-16-cstrs ((p path))
233                     (fd-open-path p flags create-mode))
234  #-(or darwin-target windows-target)
235  (let* ((encoding (pathname-encoding-name)))
236    (if encoding
237      (with-encoded-cstrs encoding ((p path))
238        (fd-open-path p flags create-mode))
239      (with-cstrs ((p path))
240        (fd-open-path p flags create-mode)))))
241
242(defun fd-chmod (fd mode)
243  (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fchmod)
244                    :int fd
245                    :mode_t mode
246                    :int))
247
248(defun fd-lseek (fd offset whence)
249  (int-errno-ffcall
250   (%kernel-import target::kernel-import-lisp-lseek)
251   :int fd
252   :signed-doubleword offset
253   :int whence
254   :signed-doubleword))
255
256(defun fd-close (fd)
257  (int-errno-ffcall (%kernel-import target::kernel-import-lisp-close)
258                    :int fd
259                    :int)) 
260
261(defun fd-tell (fd)
262  (fd-lseek fd 0 #$SEEK_CUR))
263
264;;; Kernels prior to 2.4 don't seem to have a "stat" variant
265;;; that handles 64-bit file offsets.
266(defun fd-size (fd)
267  (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat))
268    (if (eql 0 (ff-call (%kernel-import target::kernel-import-lisp-fstat)
269                        :int fd
270                        :address stat
271                        :int))
272      (pref stat
273            #-windows-target :stat.st_size
274            #+win64-target #>_stat64.st_size
275            #+win32-target #>__stat64.st_size)
276      -1)))
277
278
279(defun fd-ftruncate (fd new)
280  (int-errno-ffcall (%kernel-import target::kernel-import-lisp-ftruncate)
281                    :int fd :off_t new :int))
282
283(defun %string-to-stderr (str)
284  (with-cstrs ((s str))
285    (fd-write 2 s (length str))))
286
287(defun pdbg (string)
288  (%string-to-stderr string)
289  (%string-to-stderr #.(string #\LineFeed)))
290
291
292
293;;; Not really I/O, but ...
294(defun malloc (size)
295  (ff-call 
296   (%kernel-import target::kernel-import-malloc)
297   :unsigned-fullword size :address))
298
299(defun free (ptr)
300  (let* ((size (uvsize ptr))
301         (flags (if (= size target::xmacptr.size)
302                  (uvref ptr target::xmacptr.flags-cell)
303                  $flags_DisposPtr)))
304    (declare (fixnum size flags))
305    (if (= flags $flags_DisposPtr)
306      (with-macptrs ((addr ptr))
307        (when (= size target::xmacptr.size)
308          (%setf-macptr ptr (%null-ptr))
309          (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal))
310        (ff-call 
311         (%kernel-import target::kernel-import-free)
312         :address addr :void)))))
313
314
315
316
Note: See TracBrowser for help on using the repository browser.