source: branches/ia32/level-0/l0-io.lisp @ 8747

Last change on this file since 8747 was 8747, checked in by rme, 14 years ago

Require DARWINX8632-SYSCALLS on x8632.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.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  )
33
34
35; write nbytes bytes from buffer buf to file-descriptor fd.
36(defun fd-write (fd buf nbytes)
37  (syscall syscalls::write fd buf nbytes))
38
39(defun fd-read (fd buf nbytes)
40  (loop
41    (let* ((n  (syscall syscalls::read fd buf nbytes)))
42      (unless (eql n (- #$EINTR)) (return n)))))
43
44
45(defun fd-open (path flags &optional (create-mode #o666))
46  (with-cstrs ((p path))
47    (syscall syscalls::open p flags create-mode)))
48
49(defun fd-chmod (fd mode)
50  (syscall syscalls::fchmod fd mode))
51
52;;; This should really be conditionalized on whether the seek system
53;;; call supports 64-bit offsets or on whether one has to use some
54;;; variant.
55#+(and ppc32-target linux-target)
56(defun fd-lseek (fd offset whence)
57  (let* ((high (ldb (byte 32 32) offset))
58         (low (ldb (byte 32 0) offset)))
59    (declare (type (unsigned-byte 32) high low))
60    (%stack-block ((pos 8))
61      (let* ((res (syscall syscalls::_llseek fd high low pos whence)))
62        (declare (fixnum res))
63        (if (< res 0)
64          res
65          (let* ((pos-high (%get-unsigned-long pos 0))
66                 (pos-low (%get-unsigned-long pos 4)))
67            (declare (type (unsigned-byte 32) pos-high pos-low))
68            (if (zerop pos-high)
69              pos-low
70              (dpb pos-high (byte 32 32) pos-low))))))))
71
72#-(and ppc32-target linux-target)
73(defun fd-lseek (fd offset whence)
74  #+freebsd-target
75  (syscall syscalls::lseek fd 0 offset whence)
76  #-freebsd-target
77  (syscall syscalls::lseek fd offset whence))
78
79(defun fd-close (fd)
80  (syscall syscalls::close fd)) 
81
82(defun fd-tell (fd)
83  (fd-lseek fd 0 #$SEEK_CUR))
84
85;;; Kernels prior to 2.4 don't seem to have a "stat" variant
86;;; that handles 64-bit file offsets.
87(defun fd-size (fd)
88  (without-interrupts
89   (let* ((curpos (fd-lseek fd 0 #$SEEK_CUR)))
90     (unwind-protect
91          (fd-lseek fd 0 #$SEEK_END)
92       (fd-lseek fd curpos #$SEEK_SET)))))
93
94(defun fd-ftruncate (fd new)
95  (syscall syscalls::ftruncate fd new))
96
97(defun %string-to-stderr (str)
98  (with-cstrs ((s str))
99    (fd-write 2 s (length str))))
100
101(defun pdbg (string)
102  (%string-to-stderr string)
103  (%string-to-stderr #.(string #\LineFeed)))
104
105
106
107;;; Not really I/O, but ...
108(defun malloc (size)
109  (ff-call 
110   (%kernel-import target::kernel-import-malloc)
111   :unsigned-fullword size :address))
112
113(defun free (ptr)
114  (let* ((size (uvsize ptr))
115         (flags (if (= size target::xmacptr.size)
116                  (uvref ptr target::xmacptr.flags-cell)
117                  $flags_DisposPtr)))
118    (declare (fixnum size flags))
119    (if (= flags $flags_DisposPtr)
120      (with-macptrs ((addr ptr))
121        (when (= size target::xmacptr.size)
122          (%setf-macptr ptr (%null-ptr))
123          (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal))
124        (ff-call 
125         (%kernel-import target::kernel-import-free)
126         :address addr :void)))))
127
128
129
130
Note: See TracBrowser for help on using the repository browser.