Context Navigation

l0-io.lisp @ 15601

Visit:

Last change on this file since 15601 was 15236, checked in by gb, 9 years ago

Change the initial-values *TERMINAL-CHARACTER-ENCODING-NAME* and
*DEFAULT-FILE-CHARACTER-ENCODING* to :UTF-8, mostly for the benefit of
the Init-File-Editing-Impaired. (I've resolved not to make fun of
the IFEI.) Note that this may require changes to startup scripts etc.

Define new conditions CCL:DECODING-PROBLEM and CCL:ENCODING-PROBLEM.
Signal these conditions (via SIGNAL) when decoding characters
from/enoding them to a stream, pointer or octet vector and a substitution
or replacement character would be used.

New macros (CCL:WITH-DECODING-PROBLEMS-AS-ERRORS &body body) and
(CCL:WITH-ENCODING-PROBLEMS-AS-ERRORS &body body) signal the corresponding
conditions as ERRORs if they are signaled during execution of the body.

(Arguably) fixes ticket:749.

FILE-STRING-LENGTH checks to see if the encoding wants to use a
byte-order-mark before subtracting the length of an encoded BOM
from the encoded string length if the file is at its beginning.

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 12.5 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 (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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: