source: trunk/source/level-0/l0-io.lisp @ 11202

Last change on this file since 11202 was 11202, checked in by gb, 12 years ago

PATHNAME-ENCODING-NAME returns an encoding name, even on platforms
(darwin, windows) where it's hardwired. On those platforms,
SET-PATHNAME-ENCODING-NAME returns the hardwired name.

FD-OPEN-PATH split off from FD-OPEN, sometimes pays attention
to PATHNAME-ENCODING-NAME.

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