source: branches/objc-gf/ccl/level-0/l0-io.lisp @ 6049

Last change on this file since 6049 was 6049, checked in by gb, 13 years ago

FREE: be careful about gcable pointers.

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