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

Last change on this file since 10151 was 10151, checked in by rme, 11 years ago

REQUIRE appropriate syscalls for darwinx8632-target.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.6 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                   (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))
154    (let* ((code (%get-unsigned-byte pointer i))
155           (nexti (+ i (cond ((< code #x80) 1)
156                             ((< code #xe0) 2)
157                             ((< code #xf0) 3)
158                             (t 4)))))
159      (declare (type (unsigned-byte 8) code))
160      (if (> nexti end)
161        (return (values nchars i))
162        (setq i nexti)))))
163
164
165
166;;; write nbytes bytes from buffer buf to file-descriptor fd.
167(defun fd-write (fd buf nbytes)
168  (ignoring-eintr (syscall syscalls::write fd buf nbytes)))
169
170(defun fd-read (fd buf nbytes)
171  (ignoring-eintr (syscall syscalls::read fd buf nbytes)))
172
173
174(defun fd-open (path flags &optional (create-mode #o666))
175  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
176    (let* ((fd (syscall syscalls::open p flags create-mode)))
177      (declare (fixnum fd))
178      (when (or (= fd (- #$EMFILE))
179                (= fd (- #$EMFILE)))
180        (gc)
181        (drain-termination-queue)
182        (setq fd (syscall syscalls::open p flags create-mode)))
183      fd)))
184
185(defun fd-chmod (fd mode)
186  (syscall syscalls::fchmod fd mode))
187
188;;; This should really be conditionalized on whether the seek system
189;;; call supports 64-bit offsets or on whether one has to use some
190;;; variant.
191#+(and ppc32-target linux-target)
192(defun fd-lseek (fd offset whence)
193  (let* ((high (ldb (byte 32 32) offset))
194         (low (ldb (byte 32 0) offset)))
195    (declare (type (unsigned-byte 32) high low))
196    (%stack-block ((pos 8))
197      (let* ((res (syscall syscalls::_llseek fd high low pos whence)))
198        (declare (fixnum res))
199        (if (< res 0)
200          res
201          (let* ((pos-high (%get-unsigned-long pos 0))
202                 (pos-low (%get-unsigned-long pos 4)))
203            (declare (type (unsigned-byte 32) pos-high pos-low))
204            (if (zerop pos-high)
205              pos-low
206              (dpb pos-high (byte 32 32) pos-low))))))))
207
208#-(and ppc32-target linux-target)
209(defun fd-lseek (fd offset whence)
210  #+freebsd-target
211  (syscall syscalls::lseek fd 0 offset whence)
212  #-freebsd-target
213  (syscall syscalls::lseek fd offset whence))
214
215(defun fd-close (fd)
216  (syscall syscalls::close fd)) 
217
218(defun fd-tell (fd)
219  (fd-lseek fd 0 #$SEEK_CUR))
220
221;;; Kernels prior to 2.4 don't seem to have a "stat" variant
222;;; that handles 64-bit file offsets.
223(defun fd-size (fd)
224  (without-interrupts
225   (let* ((curpos (fd-lseek fd 0 #$SEEK_CUR)))
226     (unwind-protect
227          (fd-lseek fd 0 #$SEEK_END)
228       (fd-lseek fd curpos #$SEEK_SET)))))
229
230(defun fd-ftruncate (fd new)
231  #-solaris-target
232  (syscall syscalls::ftruncate fd new)
233  #+solaris-target
234  (rlet ((lck #>flock))
235    (setf (pref lck :flock.l_whence) 0
236          (pref lck :flock.l_start) new
237          (pref lck :flock.l_type) #$F_WRLCK
238          (pref lck :flock.l_len) 0)
239    (syscall syscalls::fcntl fd #$F_FREESP lck)))
240
241(defun %string-to-stderr (str)
242  (with-cstrs ((s str))
243    (fd-write 2 s (length str))))
244
245(defun pdbg (string)
246  (%string-to-stderr string)
247  (%string-to-stderr #.(string #\LineFeed)))
248
249
250
251;;; Not really I/O, but ...
252(defun malloc (size)
253  (ff-call 
254   (%kernel-import target::kernel-import-malloc)
255   :unsigned-fullword size :address))
256
257(defun free (ptr)
258  (let* ((size (uvsize ptr))
259         (flags (if (= size target::xmacptr.size)
260                  (uvref ptr target::xmacptr.flags-cell)
261                  $flags_DisposPtr)))
262    (declare (fixnum size flags))
263    (if (= flags $flags_DisposPtr)
264      (with-macptrs ((addr ptr))
265        (when (= size target::xmacptr.size)
266          (%setf-macptr ptr (%null-ptr))
267          (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal))
268        (ff-call 
269         (%kernel-import target::kernel-import-free)
270         :address addr :void)))))
271
272
273
274
Note: See TracBrowser for help on using the repository browser.