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 (note-vector-decoding-problem pointer index :utf-8))))))) |
---|
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 | |
---|