1 (cl:in-package
:sb-posix-internal
)
3 (define-condition sb-posix
:syscall-error
(error)
4 ((errno :initarg
:errno
:reader sb-posix
:syscall-errno
))
6 (let ((errno (sb-posix:syscall-errno c
)))
7 (format s
"System call error ~A (~A)"
8 errno
(sb-int:strerror errno
))))))
10 (defun syscall-error ()
11 (error 'sb-posix
:syscall-error
:errno
(get-errno)))
13 (declaim (inline never-fails
))
14 (defun never-fails (&rest args
)
15 (declare (ignore args
))
20 (define-call "access" int minusp
(pathname filename
) (mode int
))
21 (define-call "chdir" int minusp
(pathname filename
))
22 (define-call "chmod" int minusp
(pathname filename
) (mode sb-posix
::mode-t
))
23 (define-call "chown" int minusp
(pathname filename
)
24 (owner sb-posix
::uid-t
) (group sb-posix
::gid-t
))
25 (define-call "close" int minusp
(fd file-descriptor
))
26 (define-call "creat" int minusp
(pathname filename
) (mode sb-posix
::mode-t
))
27 (define-call "dup" int minusp
(oldfd file-descriptor
))
28 (define-call "dup2" int minusp
(oldfd file-descriptor
) (newfd file-descriptor
))
29 (define-call "fchdir" int minusp
(fd file-descriptor
))
30 (define-call "fchmod" int minusp
(fd file-descriptor
) (mode sb-posix
::mode-t
))
31 (define-call "fchown" int minusp
(fd file-descriptor
)
32 (owner sb-posix
::uid-t
) (group sb-posix
::gid-t
))
33 (define-call "fdatasync" int minusp
(fd file-descriptor
))
34 (define-call "ftruncate" int minusp
(fd file-descriptor
) (length sb-posix
::off-t
))
35 (define-call "fsync" int minusp
(fd file-descriptor
))
36 (define-call "lchown" int minusp
(pathname filename
)
37 (owner sb-posix
::uid-t
) (group sb-posix
::gid-t
))
38 (define-call "link" int minusp
(oldpath filename
) (newpath filename
))
39 (define-call "lseek" sb-posix
::off-t minusp
(fd file-descriptor
) (offset sb-posix
::off-t
) (whence int
))
40 (define-call "mkdir" int minusp
(pathname filename
) (mode sb-posix
::mode-t
))
41 (define-call "mkfifo" int minusp
(pathname filename
) (mode sb-posix
::mode-t
))
42 (define-call-internally open-with-mode
"open" int minusp
(pathname filename
) (flags int
) (mode sb-posix
::mode-t
))
43 (define-call-internally open-without-mode
"open" int minusp
(pathname filename
) (flags int
))
44 (define-entry-point "open" (pathname flags
&optional
(mode nil mode-supplied
))
46 (open-with-mode pathname flags mode
)
47 (open-without-mode pathname flags
)))
48 ;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
49 (define-call "rename" int minusp
(oldpath filename
) (newpath filename
))
50 (define-call "rmdir" int minusp
(pathname filename
))
51 (define-call "symlink" int minusp
(oldpath filename
) (newpath filename
))
52 (define-call "sync" void never-fails
)
53 (define-call "truncate" int minusp
(pathname filename
) (length sb-posix
::off-t
))
54 (define-call "unlink" int minusp
(pathname filename
))
55 (define-call-internally ioctl-without-arg
"ioctl" int minusp
(fd file-descriptor
) (cmd int
))
56 (define-call-internally ioctl-with-int-arg
"ioctl" int minusp
(fd file-descriptor
) (cmd int
) (arg int
))
57 (define-call-internally ioctl-with-pointer-arg
"ioctl" int minusp
(fd file-descriptor
) (cmd int
) (arg alien-pointer-to-anything-or-nil
))
58 (define-entry-point "ioctl" (fd cmd
&optional
(arg nil arg-supplied
))
61 ((alien int
) (ioctl-with-int-arg fd cmd arg
))
62 ((or (alien (* t
)) null
) (ioctl-with-pointer-arg fd cmd arg
)))
63 (ioctl-without-arg fd cmd
)))
65 (define-call "opendir" (* t
) null-alien
(pathname filename
))
66 (define-call "readdir" (* t
)
67 ;; readdir() has the worst error convention in the world. It's just
68 ;; too painful to support. (return is NULL _and_ errno "unchanged"
69 ;; is not an error, it's EOF).
72 (define-call "closedir" int minusp
(dir (* t
)))
74 (define-call "umask" sb-posix
::mode-t never-fails
(mode sb-posix
::mode-t
))
78 (define-call "geteuid" sb-posix
::uid-t never-fails
) ; "always successful", it says
79 (define-call "getresuid" sb-posix
::uid-t never-fails
)
80 (define-call "getuid" sb-posix
::uid-t never-fails
)
81 (define-call "seteuid" int minusp
(uid sb-posix
::uid-t
))
82 (define-call "setfsuid" int minusp
(uid sb-posix
::uid-t
))
83 (define-call "setreuid" int minusp
84 (ruid sb-posix
::uid-t
) (euid sb-posix
::uid-t
))
85 (define-call "setresuid" int minusp
86 (ruid sb-posix
::uid-t
) (euid sb-posix
::uid-t
)
87 (suid sb-posix
::uid-t
))
88 (define-call "setuid" int minusp
(uid sb-posix
::uid-t
))
90 (define-call "getegid" sb-posix
::gid-t never-fails
)
91 (define-call "getgid" sb-posix
::gid-t never-fails
)
92 (define-call "getresgid" sb-posix
::gid-t never-fails
)
93 (define-call "setegid" int minusp
(gid sb-posix
::gid-t
))
94 (define-call "setfsgid" int minusp
(gid sb-posix
::gid-t
))
95 (define-call "setgid" int minusp
(gid sb-posix
::gid-t
))
96 (define-call "setregid" int minusp
97 (rgid sb-posix
::gid-t
) (egid sb-posix
::gid-t
))
98 (define-call "setresgid" int minusp
99 (rgid sb-posix
::gid-t
)
100 (egid sb-posix
::gid-t
) (sgid sb-posix
::gid-t
))
102 ;;; processes, signals
103 (define-call "alarm" int never-fails
(seconds unsigned
))
104 (define-call "getpgid" sb-posix
::pid-t minusp
(pid sb-posix
::pid-t
))
105 (define-call "getpid" sb-posix
::pid-t never-fails
)
106 (define-call "getppid" sb-posix
::pid-t never-fails
)
107 (define-call "getpgrp" sb-posix
::pid-t never-fails
)
108 (define-call "getsid" sb-posix
::pid-t minusp
(pid sb-posix
::pid-t
))
109 (define-call "kill" int minusp
(pid sb-posix
::pid-t
) (signal int
))
110 (define-call "killpg" int minusp
(pgrp int
) (signal int
))
111 (define-call "pause" int minusp
)
112 (define-call "setpgid" int minusp
113 (pid sb-posix
::pid-t
) (pgid sb-posix
::pid-t
))
114 (define-call "setpgrp" int minusp
)
117 (define-call "mmap" sb-sys
:system-area-pointer
118 ;; KLUDGE: #XFFFFFFFF is (void *)-1, which is the charming return
119 ;; value of mmap on failure. Except on 64 bit systems ...
121 (= (sb-sys:sap-int res
) #-alpha
#XFFFFFFFF
#+alpha
#xffffffffffffffff
))
122 (addr sap-or-nil
) (length unsigned
) (prot unsigned
)
123 (flags unsigned
) (fd file-descriptor
) (offset sb-posix
::off-t
))
125 (define-call "munmap" int minusp
126 (start sb-sys
:system-area-pointer
) (length unsigned
))
128 (define-call "msync" int minusp
129 (addr sb-sys
:system-area-pointer
) (length unsigned
) (flags int
))
131 (define-call "getpagesize" int minusp
)
133 (defmacro define-stat-call
(name arg designator-fun type
)
134 ;; FIXME: this isn't the documented way of doing this, surely?
135 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
137 (export ',lisp-name
:sb-posix
)
138 (declaim (inline ,lisp-name
))
139 (defun ,lisp-name
(,arg
&optional stat
)
140 (declare (type (or null sb-posix
::stat
) stat
))
142 (setq stat
(sb-posix::allocate-stat
)))
143 ;; FIXME: Hmm. WITH-PINNED-OBJECTS/WITHOUT-GCING or something
144 ;; is probably needed round here.
145 (let* ((s (sb-sys:int-sap
146 ;; FIXME: WILL NOT WORK ON 64-BIT LISP. VECTOR-SAP
147 ;; would be better if the STAT object were
148 ;; guaranteed to be a vector, but it's not (and may
149 ;; well turn into an alien soon).
150 (+ 8 (logandc2 (sb-kernel:get-lisp-obj-address stat
) 7))))
152 (extern-alien ,name
,type
)
153 (,designator-fun
,arg
)
158 (define-stat-call "stat" pathname sb-posix
::filename
159 ;; FIXME: (* T)? Ew. (* STAT) would be preferable
160 (function int c-string
(* t
)))
161 (define-stat-call "lstat" pathname sb-posix
::filename
162 (function int c-string
(* t
)))
163 (define-stat-call "fstat" fd sb-posix
::file-descriptor
164 (function int int
(* t
)))
168 (define-call "s_isreg" boolean never-fails
(mode sb-posix
::mode-t
))
169 (define-call "s_isdir" boolean never-fails
(mode sb-posix
::mode-t
))
170 (define-call "s_ischr" boolean never-fails
(mode sb-posix
::mode-t
))
171 (define-call "s_isblk" boolean never-fails
(mode sb-posix
::mode-t
))
172 (define-call "s_isfifo" boolean never-fails
(mode sb-posix
::mode-t
))
173 (define-call "s_islnk" boolean never-fails
(mode sb-posix
::mode-t
))
174 (define-call "s_issock" boolean never-fails
(mode sb-posix
::mode-t
))
176 (export 'sb-posix
::pipe
:sb-posix
)
177 (declaim (inline sb-posix
::pipe
))
178 (defun sb-posix::pipe
(&optional filedes2
)
179 (declare (type (or null
(simple-array (signed-byte 32) (2))) filedes2
))
181 (setq filedes2
(make-array 2 :element-type
'(signed-byte 32))))
182 (let ((r (alien-funcall
183 ;; FIXME: (* INT)? (ARRAY INT 2) would be better
184 (extern-alien "pipe" (function int
(* int
)))
185 (sb-sys:vector-sap filedes2
))))
188 (values (aref filedes2
0) (aref filedes2
1)))