1 (cl:in-package
:sb-posix
)
3 (defmacro define-protocol-class
4 (name alien-type superclasses slots
&rest options
)
5 (let ((to-protocol (intern (format nil
"ALIEN-TO-~A" name
)))
6 (to-alien (intern (format nil
"~A-TO-ALIEN" name
))))
8 (defclass ,name
,superclasses
9 ,(loop for slotd in slots
10 collect
(ldiff slotd
(member :array-length slotd
)))
12 (declaim (inline ,to-alien
,to-protocol
))
13 (declaim (inline ,to-protocol
,to-alien
))
14 (defun ,to-protocol
(alien &optional instance
)
15 (declare (type (sb-alien:alien
(* ,alien-type
)) alien
)
16 (type (or null
,name
) instance
))
18 (setf instance
(make-instance ',name
)))
19 ,@(loop for slotd in slots
20 ;; FIXME: slotds in source are more complicated in general
22 ;; FIXME: baroque construction of intricate fragility
23 for array-length
= (getf (cdr slotd
) :array-length
)
26 (let ((array (make-array ,array-length
)))
27 (setf (slot-value instance
',(car slotd
))
29 (dotimes (i ,array-length
)
32 (sb-alien:slot alien
',(car slotd
))
35 collect
`(setf (slot-value instance
',(car slotd
))
36 (sb-alien:slot alien
',(car slotd
))))
38 (defun ,to-alien
(instance &optional alien
)
39 (declare (type (or null
(sb-alien:alien
(* ,alien-type
))) alien
)
40 (type ,name instance
))
42 (setf alien
(sb-alien:make-alien
,alien-type
)))
43 ,@(loop for slotd in slots
44 for array-length
= (getf (cdr slotd
) :array-length
)
47 (let ((array (slot-value instance
',(car slotd
))))
48 (dotimes (i ,array-length
)
50 (sb-alien:slot alien
',(car slotd
))
54 collect
`(setf (sb-alien:slot alien
',(car slotd
))
55 (slot-value instance
',(car slotd
)))))
56 (find-class ',name
))))
58 (define-condition sb-posix
:syscall-error
(error)
59 ((errno :initarg
:errno
:reader sb-posix
:syscall-errno
))
60 (:report
(lambda (c s
)
61 (let ((errno (sb-posix:syscall-errno c
)))
62 (format s
"System call error ~A (~A)"
63 errno
(sb-int:strerror errno
))))))
65 (defun syscall-error ()
66 (error 'sb-posix
:syscall-error
:errno
(get-errno)))
68 (declaim (inline never-fails
))
69 (defun never-fails (&rest args
)
70 (declare (ignore args
))
73 ;;; Some systems may need C-level wrappers, which can live in the
74 ;;; runtime (so that save-lisp-and-die can produce standalone
75 ;;; executables). See REAL-C-NAME in macros.lisp for the use of this
77 (eval-when (:compile-toplevel
:load-toplevel
)
78 (setf *c-functions-in-runtime
*
79 '`(#+netbsd
,@("stat" "lstat" "fstat" "readdir" "opendir"))))
83 (defmacro define-call
* (name &rest arguments
)
84 #-win32
`(define-call ,name
,@arguments
)
85 #+win32
`(define-call ,(if (consp name
)
86 `(,(concatenate 'string
"_" (car name
))
88 (concatenate 'string
"_" name
))
91 (define-call* "access" int minusp
(pathname filename
) (mode int
))
92 (define-call* "chdir" int minusp
(pathname filename
))
93 (define-call* "chmod" int minusp
(pathname filename
) (mode mode-t
))
94 (define-call* "close" int minusp
(fd file-descriptor
))
95 (define-call* "creat" int minusp
(pathname filename
) (mode mode-t
))
96 (define-call* "dup" int minusp
(oldfd file-descriptor
))
97 (define-call* "dup2" int minusp
(oldfd file-descriptor
)
98 (newfd file-descriptor
))
99 (define-call* ("lseek" :options
:largefile
)
100 off-t minusp
(fd file-descriptor
) (offset off-t
)
102 (define-call* "mkdir" int minusp
(pathname filename
) (mode mode-t
))
105 (define-call-internally open-with-mode
,x int minusp
106 (pathname filename
) (flags int
) (mode mode-t
))
107 (define-call-internally open-without-mode
,x int minusp
108 (pathname filename
) (flags int
))
109 (define-entry-point ,x
110 (pathname flags
&optional
(mode nil mode-supplied
))
112 (open-with-mode pathname flags mode
)
113 (open-without-mode pathname flags
))))))
114 (def #-win32
"open" #+win32
"_open"))
115 (define-call "rename" int minusp
(oldpath filename
) (newpath filename
))
116 (define-call* "rmdir" int minusp
(pathname filename
))
117 (define-call* "unlink" int minusp
(pathname filename
))
118 (define-call #-netbsd
"opendir" #+netbsd
"_opendir"
119 (* t
) null-alien
(pathname filename
))
120 (define-call (#-netbsd
"readdir" #+netbsd
"_readdir" :options
:largefile
)
122 ;; readdir() has the worst error convention in the world. It's just
123 ;; too painful to support. (return is NULL _and_ errno "unchanged"
124 ;; is not an error, it's EOF).
127 (define-call "closedir" int minusp
(dir (* t
)))
128 ;; need to do this here because we can't do it in the DEFPACKAGE
129 (define-call* "umask" mode-t never-fails
(mode mode-t
))
130 (define-call* "getpid" pid-t never-fails
)
134 (define-call "chown" int minusp
(pathname filename
)
135 (owner uid-t
) (group gid-t
))
136 (define-call "chroot" int minusp
(pathname filename
))
137 (define-call "fchdir" int minusp
(fd file-descriptor
))
138 (define-call "fchmod" int minusp
(fd file-descriptor
) (mode mode-t
))
139 (define-call "fchown" int minusp
(fd file-descriptor
)
140 (owner uid-t
) (group gid-t
))
141 (define-call "fdatasync" int minusp
(fd file-descriptor
))
142 (define-call ("ftruncate" :options
:largefile
)
143 int minusp
(fd file-descriptor
) (length off-t
))
144 (define-call "fsync" int minusp
(fd file-descriptor
))
145 (define-call "lchown" int minusp
(pathname filename
)
146 (owner uid-t
) (group gid-t
))
147 (define-call "link" int minusp
(oldpath filename
) (newpath filename
))
148 (define-call "lockf" int minusp
(fd file-descriptor
) (cmd int
) (len off-t
))
149 (define-call "mkfifo" int minusp
(pathname filename
) (mode mode-t
))
150 (define-call "symlink" int minusp
(oldpath filename
) (newpath filename
))
151 (define-call "sync" void never-fails
)
152 (define-call ("truncate" :options
:largefile
)
153 int minusp
(pathname filename
) (length off-t
))
154 ;; FIXME: Windows does have _mktemp, which has a slightlty different
156 (defun mkstemp (template)
157 ;; we are emulating sb-alien's charset conversion for strings
158 ;; here, to accommodate for the call-by-reference nature of
159 ;; mkstemp's template strings.
160 (let ((arg (sb-ext:string-to-octets
162 :external-format sb-alien
::*default-c-string-external-format
*)))
163 (sb-sys:with-pinned-objects
(arg)
164 (let ((result (alien-funcall (extern-alien "mkstemp"
165 (function int c-string
))
166 (sap-alien (sb-alien::vector-sap arg
)
168 (when (minusp result
)
171 (sb-ext:octets-to-string
173 :external-format sb-alien
::*default-c-string-external-format
*))))))
174 (define-call-internally ioctl-without-arg
"ioctl" int minusp
175 (fd file-descriptor
) (cmd int
))
176 (define-call-internally ioctl-with-int-arg
"ioctl" int minusp
177 (fd file-descriptor
) (cmd int
) (arg int
))
178 (define-call-internally ioctl-with-pointer-arg
"ioctl" int minusp
179 (fd file-descriptor
) (cmd int
)
180 (arg alien-pointer-to-anything-or-nil
))
181 (define-entry-point "ioctl" (fd cmd
&optional
(arg nil argp
))
184 ((alien int
) (ioctl-with-int-arg fd cmd arg
))
185 ((or (alien (* t
)) null
) (ioctl-with-pointer-arg fd cmd arg
)))
186 (ioctl-without-arg fd cmd
)))
187 (define-call-internally fcntl-without-arg
"fcntl" int minusp
188 (fd file-descriptor
) (cmd int
))
189 (define-call-internally fcntl-with-int-arg
"fcntl" int minusp
190 (fd file-descriptor
) (cmd int
) (arg int
))
191 (define-call-internally fcntl-with-pointer-arg
"fcntl" int minusp
192 (fd file-descriptor
) (cmd int
)
193 (arg alien-pointer-to-anything-or-nil
))
194 (define-entry-point "fcntl" (fd cmd
&optional
(arg nil argp
))
197 ((alien int
) (fcntl-with-int-arg fd cmd arg
))
198 ((or (alien (* t
)) null
) (fcntl-with-pointer-arg fd cmd arg
)))
199 (fcntl-without-arg fd cmd
)))
202 (define-call "geteuid" uid-t never-fails
) ; "always successful", it says
203 (define-call "getresuid" uid-t never-fails
)
204 (define-call "getuid" uid-t never-fails
)
205 (define-call "seteuid" int minusp
(uid uid-t
))
206 (define-call "setfsuid" int minusp
(uid uid-t
))
207 (define-call "setreuid" int minusp
(ruid uid-t
) (euid uid-t
))
208 (define-call "setresuid" int minusp
(ruid uid-t
) (euid uid-t
) (suid uid-t
))
209 (define-call "setuid" int minusp
(uid uid-t
))
210 (define-call "getegid" gid-t never-fails
)
211 (define-call "getgid" gid-t never-fails
)
212 (define-call "getresgid" gid-t never-fails
)
213 (define-call "setegid" int minusp
(gid gid-t
))
214 (define-call "setfsgid" int minusp
(gid gid-t
))
215 (define-call "setgid" int minusp
(gid gid-t
))
216 (define-call "setregid" int minusp
(rgid gid-t
) (egid gid-t
))
217 (define-call "setresgid" int minusp
(rgid gid-t
) (egid gid-t
) (sgid gid-t
))
219 ;; processes, signals
220 (define-call "alarm" int never-fails
(seconds unsigned
))
224 #+mach-exception-handler
226 ;; FIXME this is a lie, of course this can fail, but there's no
227 ;; error handling here yet!
228 (define-call "setup_mach_exceptions" void never-fails
)
229 (define-call ("posix_fork" :c-name
"fork") pid-t minusp
)
231 (let ((pid (posix-fork)))
233 (setup-mach-exceptions))
235 (export 'fork
:sb-posix
))
237 #-mach-exception-handler
238 (define-call "fork" pid-t minusp
)
240 (define-call "getpgid" pid-t minusp
(pid pid-t
))
241 (define-call "getppid" pid-t never-fails
)
242 (define-call "getpgrp" pid-t never-fails
)
243 (define-call "getsid" pid-t minusp
(pid pid-t
))
244 (define-call "kill" int minusp
(pid pid-t
) (signal int
))
245 (define-call "killpg" int minusp
(pgrp int
) (signal int
))
246 (define-call "pause" int minusp
)
247 (define-call "setpgid" int minusp
(pid pid-t
) (pgid pid-t
))
248 (define-call "setpgrp" int minusp
))
252 (export 'readlink
:sb-posix
)
253 (defun readlink (pathspec)
254 (flet ((%readlink
(path buf length
)
256 (extern-alien "readlink" (function int c-string
(* t
) int
))
258 (loop for size
= 128 then
(* 2 size
)
259 for buf
= (make-alien c-string size
)
261 (let ((count (%readlink
(filename pathspec
) buf size
)))
262 (cond ((minusp count
)
265 (setf (sb-sys:sap-ref-8
(sb-alien:alien-sap buf
)
269 (sb-alien::c-string-to-string
270 (sb-alien:alien-sap buf
)
271 (sb-impl::default-external-format
)
273 (free-alien buf
))))))
277 (export 'wait
:sb-posix
)
278 (declaim (inline wait
))
279 (defun wait (&optional statusptr
)
280 (declare (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
281 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
283 (extern-alien "wait" (function pid-t
(* int
)))
284 (sb-sys:vector-sap ptr
))))
287 (values pid
(aref ptr
0))))))
291 (export 'waitpid
:sb-posix
)
292 (declaim (inline waitpid
))
293 (defun waitpid (pid options
&optional statusptr
)
294 (declare (type (sb-alien:alien pid-t
) pid
)
295 (type (sb-alien:alien int
) options
)
296 (type (or null
(simple-array (signed-byte 32) (1))) statusptr
))
297 (let* ((ptr (or statusptr
(make-array 1 :element-type
'(signed-byte 32))))
299 (extern-alien "waitpid" (function pid-t
301 pid
(sb-sys:vector-sap ptr
) options
)))
304 (values pid
(aref ptr
0)))))
306 (define-call "wifexited" boolean never-fails
(status int
))
307 (define-call "wexitstatus" int never-fails
(status int
))
308 (define-call "wifsignaled" boolean never-fails
(status int
))
309 (define-call "wtermsig" int never-fails
(status int
))
310 (define-call "wifstopped" boolean never-fails
(status int
))
311 (define-call "wstopsig" int never-fails
(status int
))
312 #+nil
; see alien/waitpid-macros.c
313 (define-call "wifcontinued" boolean never-fails
(status int
)))
318 (define-call ("mmap" :options
:largefile
) sb-sys
:system-area-pointer
320 (= (sb-sys:sap-int res
) #.
(1- (expt 2 sb-vm
::n-machine-word-bits
))))
321 (addr sap-or-nil
) (length unsigned
) (prot unsigned
)
322 (flags unsigned
) (fd file-descriptor
) (offset off-t
))
324 (define-call "munmap" int minusp
325 (start sb-sys
:system-area-pointer
) (length unsigned
))
327 (define-call "msync" int minusp
328 (addr sb-sys
:system-area-pointer
) (length unsigned
) (flags int
)))
331 (define-call "getpagesize" int minusp
)
333 ;;; KLUDGE: This could be taken from GetSystemInfo
334 (export (defun getpagesize () 4096))
338 (define-protocol-class passwd alien-passwd
()
339 ((name :initarg
:name
:accessor passwd-name
)
340 (passwd :initarg
:passwd
:accessor passwd-passwd
)
341 (uid :initarg
:uid
:accessor passwd-uid
)
342 (gid :initarg
:gid
:accessor passwd-gid
)
343 (gecos :initarg
:gecos
:accessor passwd-gecos
)
344 (dir :initarg
:dir
:accessor passwd-dir
)
345 (shell :initarg
:shell
:accessor passwd-shell
)))
347 (defmacro define-pw-call
(name arg type
)
349 ;; FIXME: this isn't the documented way of doing this, surely?
350 (let ((lisp-name (intern (string-upcase name
) :sb-posix
)))
352 (export ',lisp-name
:sb-posix
)
353 (declaim (inline ,lisp-name
))
354 (defun ,lisp-name
(,arg
)
355 (let ((r (alien-funcall (extern-alien ,name
,type
) ,arg
)))
358 (alien-to-passwd r
)))))))
360 (define-pw-call "getpwnam" login-name
(function (* alien-passwd
) c-string
))
361 (define-pw-call "getpwuid" uid
(function (* alien-passwd
) uid-t
))
364 (define-protocol-class timeval alien-timeval
()
365 ((sec :initarg
:tv-sec
:accessor timeval-sec
)
366 (usec :initarg
:tv-usec
:accessor timeval-usec
)))
368 (define-protocol-class stat alien-stat
()
369 ((mode :initarg
:mode
:accessor stat-mode
)
370 (ino :initarg
:ino
:accessor stat-ino
)
371 (dev :initarg
:dev
:accessor stat-dev
)
372 (nlink :initarg
:nlink
:accessor stat-nlink
)
373 (uid :initarg
:uid
:accessor stat-uid
)
374 (gid :initarg
:gid
:accessor stat-gid
)
375 (size :initarg
:size
:accessor stat-size
)
376 (atime :initarg
:atime
:accessor stat-atime
)
377 (mtime :initarg
:mtime
:accessor stat-mtime
)
378 (ctime :initarg
:ctime
:accessor stat-ctime
)))
380 (defmacro define-stat-call
(name arg designator-fun type
)
381 ;; FIXME: this isn't the documented way of doing this, surely?
382 (let ((lisp-name (lisp-for-c-symbol name
)))
384 (export ',lisp-name
:sb-posix
)
385 (declaim (inline ,lisp-name
))
386 (defun ,lisp-name
(,arg
&optional stat
)
387 (declare (type (or null
(sb-alien:alien
(* alien-stat
))) stat
))
388 (with-alien-stat a-stat
()
389 (let ((r (alien-funcall
390 (extern-alien ,(real-c-name (list name
:options
:largefile
)) ,type
)
391 (,designator-fun
,arg
)
395 (alien-to-stat a-stat stat
)))))))
397 (define-stat-call #-win32
"stat" #+win32
"_stat"
399 (function int c-string
(* alien-stat
)))
402 (define-stat-call "lstat"
404 (function int c-string
(* alien-stat
)))
405 ;;; No symbolic links on Windows, so use stat
408 (declaim (inline lstat
))
409 (export (defun lstat (filename &optional stat
)
410 (if stat
(stat filename stat
) (stat filename
)))))
412 (define-stat-call #-win32
"fstat" #+win32
"_fstat"
414 (function int int
(* alien-stat
)))
418 (define-call "s_isreg" boolean never-fails
(mode mode-t
))
419 (define-call "s_isdir" boolean never-fails
(mode mode-t
))
420 (define-call "s_ischr" boolean never-fails
(mode mode-t
))
421 (define-call "s_isblk" boolean never-fails
(mode mode-t
))
422 (define-call "s_isfifo" boolean never-fails
(mode mode-t
))
423 (define-call "s_islnk" boolean never-fails
(mode mode-t
))
424 (define-call "s_issock" boolean never-fails
(mode mode-t
))
428 (export 'pipe
:sb-posix
)
429 (declaim (inline pipe
))
430 (defun pipe (&optional filedes2
)
431 (declare (type (or null
(simple-array (signed-byte 32) (2))) filedes2
))
433 (setq filedes2
(make-array 2 :element-type
'(signed-byte 32))))
434 (let ((r (alien-funcall
435 ;; FIXME: (* INT)? (ARRAY INT 2) would be better
436 (extern-alien "pipe" (function int
(* int
)))
437 (sb-sys:vector-sap filedes2
))))
440 (values (aref filedes2
0) (aref filedes2
1))))
443 (define-protocol-class termios alien-termios
()
444 ((iflag :initarg
:iflag
:accessor sb-posix
:termios-iflag
)
445 (oflag :initarg
:oflag
:accessor sb-posix
:termios-oflag
)
446 (cflag :initarg
:cflag
:accessor sb-posix
:termios-cflag
)
447 (lflag :initarg
:lflag
:accessor sb-posix
:termios-lflag
)
448 (cc :initarg
:cc
:accessor sb-posix
:termios-cc
:array-length nccs
)))
452 (export 'tcsetattr
:sb-posix
)
453 (declaim (inline tcsetattr
))
454 (defun tcsetattr (fd actions termios
)
455 (declare (type termios termios
))
456 (with-alien-termios a-termios
()
457 (termios-to-alien termios a-termios
)
458 (let ((fd (file-descriptor fd
)))
459 (let* ((r (alien-funcall
462 (function int int int
(* alien-termios
)))
463 fd actions a-termios
)))
467 (export 'tcgetattr
:sb-posix
)
468 (declaim (inline tcgetattr
))
469 (defun tcgetattr (fd &optional termios
)
470 (declare (type (or null termios
) termios
))
471 (with-alien-termios a-termios
()
472 (let ((r (alien-funcall
473 (extern-alien "tcgetattr"
474 (function int int
(* alien-termios
)))
479 (setf termios
(alien-to-termios a-termios termios
))))
481 (export 'cfsetispeed
:sb-posix
)
482 (declaim (inline cfsetispeed
))
483 (defun cfsetispeed (speed &optional termios
)
484 (declare (type (or null termios
) termios
))
485 (with-alien-termios a-termios
()
486 (let ((r (alien-funcall
487 (extern-alien "cfsetispeed"
488 (function int
(* alien-termios
) speed-t
))
493 (setf termios
(alien-to-termios a-termios termios
))))
495 (export 'cfsetospeed
:sb-posix
)
496 (declaim (inline cfsetospeed
))
497 (defun cfsetospeed (speed &optional termios
)
498 (declare (type (or null termios
) termios
))
499 (with-alien-termios a-termios
()
500 (let ((r (alien-funcall
501 (extern-alien "cfsetospeed"
502 (function int
(* alien-termios
) speed-t
))
507 (setf termios
(alien-to-termios a-termios termios
))))
509 (export 'cfgetispeed
:sb-posix
)
510 (declaim (inline cfgetispeed
))
511 (defun cfgetispeed (termios)
512 (declare (type termios termios
))
513 (with-alien-termios a-termios
()
514 (termios-to-alien termios a-termios
)
515 (alien-funcall (extern-alien "cfgetispeed"
516 (function speed-t
(* alien-termios
)))
518 (export 'cfgetospeed
:sb-posix
)
519 (declaim (inline cfgetospeed
))
520 (defun cfgetospeed (termios)
521 (declare (type termios termios
))
522 (with-alien-termios a-termios
()
523 (termios-to-alien termios a-termios
)
524 (alien-funcall (extern-alien "cfgetospeed"
525 (function speed-t
(* alien-termios
)))
531 (export 'time
:sb-posix
)
533 (let ((result (alien-funcall (extern-alien "time"
534 (function time-t
(* time-t
)))
539 (export 'utime
:sb-posix
)
540 (defun utime (filename &optional access-time modification-time
)
541 (let ((fun (extern-alien "utime" (function int c-string
543 (name (filename filename
)))
544 (if (not (and access-time modification-time
))
545 (alien-funcall fun name nil
)
546 (with-alien ((utimbuf (struct alien-utimbuf
)))
547 (setf (slot utimbuf
'actime
) (or access-time
0)
548 (slot utimbuf
'modtime
) (or modification-time
0))
549 (let ((result (alien-funcall fun name
(alien-sap utimbuf
))))
553 (export 'utimes
:sb-posix
)
554 (defun utimes (filename &optional access-time modification-time
)
555 (flet ((seconds-and-useconds (time)
556 (multiple-value-bind (integer fractional
)
558 (values integer
(cl:truncate
(* fractional
1000000)))))
559 (maybe-syscall-error (value)
563 (let ((fun (extern-alien "utimes" (function int c-string
564 (* (array alien-timeval
2)))))
565 (name (filename filename
)))
566 (if (not (and access-time modification-time
))
567 (maybe-syscall-error (alien-funcall fun name nil
))
568 (with-alien ((buf (array alien-timeval
2)))
569 (let ((actime (deref buf
0))
570 (modtime (deref buf
1)))
571 (setf (values (slot actime
'sec
)
573 (seconds-and-useconds (or access-time
0))
574 (values (slot modtime
'sec
)
575 (slot modtime
'usec
))
576 (seconds-and-useconds (or modification-time
0)))
577 (maybe-syscall-error (alien-funcall fun name
578 (alien-sap buf
))))))))))
583 (export 'getenv
:sb-posix
)
585 (let ((r (alien-funcall
586 (extern-alien "getenv" (function (* char
) c-string
))
588 (declare (type (alien (* char
)) r
))
589 (unless (null-alien r
)
591 (define-call "putenv" int minusp
(string c-string
))
596 (export 'openlog
:sb-posix
)
597 (export 'syslog
:sb-posix
)
598 (export 'closelog
:sb-posix
)
599 (defun openlog (ident options
&optional
(facility log-user
))
600 (alien-funcall (extern-alien
601 "openlog" (function void c-string int int
))
602 ident options facility
))
603 (defun syslog (priority format
&rest args
)
604 "Send a message to the syslog facility, with severity level
605 PRIORITY. The message will be formatted as by CL:FORMAT (rather
606 than C's printf) with format string FORMAT and arguments ARGS."
607 (flet ((syslog1 (priority message
)
608 (alien-funcall (extern-alien
609 "syslog" (function void int c-string c-string
))
610 priority
"%s" message
)))
611 (syslog1 priority
(apply #'format nil format args
))))
612 (define-call "closelog" void never-fails
))