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

Last change on this file since 10184 was 10184, checked in by gb, 11 years ago

FD-WRITE needs an IGNORING-EINTR, and has for some time. (Was fixed
in working-0711, but not here.)

Likewise, propagate some utf-8 memory encode/decode fixes here.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.7 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  #+darwinx8632-target
27  (require "DARWINX8632-SYSCALLS")
28  #+darwinx8664-target
29  (require "DARWINX8664-SYSCALLS")
30  #+freebsd-target
31  (require "X8664-FREEBSD-SYSCALLS")
32  #+solarisx8664-target
33  (require "X8664-SOLARIS-SYSCALLS")
34  )
35
36
37(defun utf-8-octets-in-string (string start end)
38  (if (>= end start)
39    (do* ((noctets 0)
40          (i start (1+ i)))
41         ((= i end) noctets)
42      (declare (fixnum noctets))
43      (let* ((code (char-code (schar string i))))
44        (declare (type (mod #x110000) code))
45        (incf noctets
46              (if (< code #x80)
47                1
48                (if (< code #x800)
49                  2
50                  (if (< code #x10000)
51                    3
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 utf-8-memory-decode (pointer noctets idx string)
91  (declare (fixnum noctets idx))
92  (do* ((i 0 (1+ i))
93        (end (+ idx noctets))
94        (index idx (1+ index)))
95       ((>= index end) (if (= index end) index 0))
96    (let* ((1st-unit (%get-unsigned-byte pointer index)))
97      (declare (type (unsigned-byte 8) 1st-unit))
98      (let* ((char (if (< 1st-unit #x80)
99                     (code-char 1st-unit)
100                     (if (>= 1st-unit #xc2)
101                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
102                         (declare (type (unsigned-byte 8) 2nd-unit))
103                         (if (< 1st-unit #xe0)
104                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
105                             (code-char
106                              (logior
107                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
108                               (the fixnum (logxor 2nd-unit #x80)))))
109                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
110                             (declare (type (unsigned-byte 8) 3rd-unit))
111                             (if (< 1st-unit #xf0)
112                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
113                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
114                                        (or (>= 1st-unit #xe1)
115                                            (>= 2nd-unit #xa0)))
116                                 (code-char (the fixnum
117                                              (logior (the fixnum
118                                                        (ash (the fixnum (logand 1st-unit #xf))
119                                                             12))
120                                                      (the fixnum
121                                                        (logior
122                                                         (the fixnum
123                                                           (ash (the fixnum (logand 2nd-unit #x3f))
124                                                                6))
125                                                         (the fixnum (logand 3rd-unit #x3f))))))))
126                               (if (< 1st-unit #xf8)
127                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
128                                   (declare (type (unsigned-byte 8) 4th-unit))
129                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
130                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
131                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
132                                            (or (>= 1st-unit #xf1)
133                                                (>= 2nd-unit #x90)))
134                                     (code-char
135                                      (logior
136                                       (the fixnum
137                                         (logior
138                                          (the fixnum
139                                            (ash (the fixnum (logand 1st-unit 7)) 18))
140                                          (the fixnum
141                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
142                                       (the fixnum
143                                         (logior
144                                          (the fixnum
145                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
146                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
147        (setf (schar string i) (or char #\Replacement_Character))))))
148
149(defun utf-8-length-of-memory-encoding (pointer noctets start)
150  (do* ((i start)
151        (end (+ start noctets))
152        (nchars 0 (1+ nchars)))
153       ((= i end) (values nchars (- i start)))
154    (let* ((code (%get-unsigned-byte pointer i))
155           (nexti (+ i (cond ((< code #xc2) 1)
156                             ((< code #xe0) 2)
157                             ((< code #xf0) 3)
158                             ((< code #xf8) 4)
159                             (t 1)))))
160      (declare (type (unsigned-byte 8) code))
161      (if (> nexti end)
162        (return (values nchars (- i start)))
163        (setq i nexti)))))
164
165
166
167;;; write nbytes bytes from buffer buf to file-descriptor fd.
168(defun fd-write (fd buf nbytes)
169  (ignoring-eintr 
170   (syscall syscalls::write fd buf nbytes)))
171
172(defun fd-read (fd buf nbytes)
173  (ignoring-eintr (syscall syscalls::read fd buf nbytes)))
174
175
176(defun fd-open (path flags &optional (create-mode #o666))
177  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
178    (let* ((fd (syscall syscalls::open p flags create-mode)))
179      (declare (fixnum fd))
180      (when (or (= fd (- #$EMFILE))
181                (= fd (- #$EMFILE)))
182        (gc)
183        (drain-termination-queue)
184        (setq fd (syscall syscalls::open p flags create-mode)))
185      fd)))
186
187(defun fd-chmod (fd mode)
188  (syscall syscalls::fchmod fd mode))
189
190;;; This should really be conditionalized on whether the seek system
191;;; call supports 64-bit offsets or on whether one has to use some
192;;; variant.
193#+(and ppc32-target linux-target)
194(defun fd-lseek (fd offset whence)
195  (let* ((high (ldb (byte 32 32) offset))
196         (low (ldb (byte 32 0) offset)))
197    (declare (type (unsigned-byte 32) high low))
198    (%stack-block ((pos 8))
199      (let* ((res (syscall syscalls::_llseek fd high low pos whence)))
200        (declare (fixnum res))
201        (if (< res 0)
202          res
203          (let* ((pos-high (%get-unsigned-long pos 0))
204                 (pos-low (%get-unsigned-long pos 4)))
205            (declare (type (unsigned-byte 32) pos-high pos-low))
206            (if (zerop pos-high)
207              pos-low
208              (dpb pos-high (byte 32 32) pos-low))))))))
209
210#-(and ppc32-target linux-target)
211(defun fd-lseek (fd offset whence)
212  #+freebsd-target
213  (syscall syscalls::lseek fd 0 offset whence)
214  #-freebsd-target
215  (syscall syscalls::lseek fd offset whence))
216
217(defun fd-close (fd)
218  (syscall syscalls::close fd)) 
219
220(defun fd-tell (fd)
221  (fd-lseek fd 0 #$SEEK_CUR))
222
223;;; Kernels prior to 2.4 don't seem to have a "stat" variant
224;;; that handles 64-bit file offsets.
225(defun fd-size (fd)
226  (without-interrupts
227   (let* ((curpos (fd-lseek fd 0 #$SEEK_CUR)))
228     (unwind-protect
229          (fd-lseek fd 0 #$SEEK_END)
230       (fd-lseek fd curpos #$SEEK_SET)))))
231
232(defun fd-ftruncate (fd new)
233  #-solaris-target
234  (syscall syscalls::ftruncate fd new)
235  #+solaris-target
236  (rlet ((lck #>flock))
237    (setf (pref lck :flock.l_whence) 0
238          (pref lck :flock.l_start) new
239          (pref lck :flock.l_type) #$F_WRLCK
240          (pref lck :flock.l_len) 0)
241    (syscall syscalls::fcntl fd #$F_FREESP lck)))
242
243(defun %string-to-stderr (str)
244  (with-cstrs ((s str))
245    (fd-write 2 s (length str))))
246
247(defun pdbg (string)
248  (%string-to-stderr string)
249  (%string-to-stderr #.(string #\LineFeed)))
250
251
252
253;;; Not really I/O, but ...
254(defun malloc (size)
255  (ff-call 
256   (%kernel-import target::kernel-import-malloc)
257   :unsigned-fullword size :address))
258
259(defun free (ptr)
260  (let* ((size (uvsize ptr))
261         (flags (if (= size target::xmacptr.size)
262                  (uvref ptr target::xmacptr.flags-cell)
263                  $flags_DisposPtr)))
264    (declare (fixnum size flags))
265    (if (= flags $flags_DisposPtr)
266      (with-macptrs ((addr ptr))
267        (when (= size target::xmacptr.size)
268          (%setf-macptr ptr (%null-ptr))
269          (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal))
270        (ff-call 
271         (%kernel-import target::kernel-import-free)
272         :address addr :void)))))
273
274
275
276
Note: See TracBrowser for help on using the repository browser.