1.0.10.24: Don't include CVS cruft in binary distributions.
[sbcl.git] / contrib / sb-posix / interface.lisp
1 (cl:in-package :sb-posix)
2
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))))
7     `(progn
8       (defclass ,name ,superclasses
9         ,(loop for slotd in slots
10                collect (ldiff slotd (member :array-length slotd)))
11         ,@options)
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))
17         (unless instance
18           (setf instance (make-instance ',name)))
19         ,@(loop for slotd in slots
20                 ;; FIXME: slotds in source are more complicated in general
21                 ;;
22                 ;; FIXME: baroque construction of intricate fragility
23                 for array-length = (getf (cdr slotd) :array-length)
24                 if array-length
25                   collect `(progn
26                              (let ((array (make-array ,array-length)))
27                                (setf (slot-value instance ',(car slotd))
28                                      array)
29                                (dotimes (i ,array-length)
30                                  (setf (aref array i)
31                                        (sb-alien:deref
32                                         (sb-alien:slot alien ',(car slotd))
33                                         i)))))
34                 else
35                   collect `(setf (slot-value instance ',(car slotd))
36                                  (sb-alien:slot alien ',(car slotd))))
37         instance)
38       (defun ,to-alien (instance &optional alien)
39         (declare (type (or null (sb-alien:alien (* ,alien-type))) alien)
40                  (type ,name instance))
41         (unless alien
42           (setf alien (sb-alien:make-alien ,alien-type)))
43         ,@(loop for slotd in slots
44                 for array-length = (getf (cdr slotd) :array-length)
45                 if array-length
46                   collect `(progn
47                              (let ((array (slot-value instance ',(car slotd))))
48                                (dotimes (i ,array-length)
49                                  (setf (sb-alien:deref
50                                         (sb-alien:slot alien ',(car slotd))
51                                         i)
52                                        (aref array i)))))
53                 else
54                   collect `(setf (sb-alien:slot alien ',(car slotd))
55                                  (slot-value instance ',(car slotd)))))
56       (find-class ',name))))
57
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))))))
64
65 (defun syscall-error ()
66   (error 'sb-posix:syscall-error :errno (get-errno)))
67
68 (declaim (inline never-fails))
69 (defun never-fails (&rest args)
70   (declare (ignore args))
71   nil)
72
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
76 ;;; variable.
77 (eval-when (:compile-toplevel :load-toplevel)
78   (setf *c-functions-in-runtime*
79         '`(#+netbsd ,@("stat" "lstat" "fstat" "readdir" "opendir"))))
80
81
82 ;;; filesystem access
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))
87                                 ,@(cdr name))
88                              (concatenate 'string "_" name))
89                ,@arguments))
90
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)
101     (whence int))
102 (define-call* "mkdir" int minusp (pathname filename) (mode mode-t))
103 (macrolet ((def (x)
104                `(progn
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))
111                    (if 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)
121   (* dirent)
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).
125   not
126   (dir (* t)))
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)
131
132 #-win32
133 (progn
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
155   ;; interface
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
161                 (filename template)
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)
167                                                 (* char)))))
168           (when (minusp result)
169             (syscall-error))
170           (values result
171                   (sb-ext:octets-to-string
172                    arg
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))
182     (if argp
183         (etypecase arg
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))
195     (if argp
196         (etypecase arg
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)))
200
201   ;; uid, gid
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))
218
219   ;; processes, signals
220   (define-call "alarm" int never-fails (seconds unsigned))
221
222
223
224   #+mach-exception-handler
225   (progn
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)
230     (defun fork ()
231       (let ((pid (posix-fork)))
232         (when (= pid 0)
233           (setup-mach-exceptions))
234         pid))
235     (export 'fork :sb-posix))
236
237   #-mach-exception-handler
238   (define-call "fork" pid-t minusp)
239
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))
249
250 (defmacro with-growing-c-string ((buffer size) &body body)
251   (sb-int:with-unique-names (c-string-block)
252     `(block ,c-string-block
253        (let (,buffer)
254          (flet ((,buffer (&optional (size-incl-null))
255                   (when size-incl-null
256                     (setf (sb-sys:sap-ref-8 (sb-alien:alien-sap ,buffer) size-incl-null)
257                           0))
258                   (return-from ,c-string-block
259                     (sb-alien::c-string-to-string
260                      (sb-alien:alien-sap ,buffer)
261                      (sb-impl::default-external-format)
262                      'character))))
263            (loop for ,size = 128 then (* 2 ,size)
264                  do (unwind-protect
265                          (progn
266                            (setf ,buffer (make-alien c-string ,size))
267                            ,@body)
268                       (when ,buffer
269                         (free-alien ,buffer)))))))))
270
271 #-win32
272 (progn
273   (export 'readlink :sb-posix)
274   (defun readlink (pathspec)
275     (flet ((%readlink (path buf length)
276              (alien-funcall
277               (extern-alien "readlink" (function int c-string (* t) int))
278               path buf length)))
279       (with-growing-c-string (buf size)
280         (let ((count (%readlink (filename pathspec) buf size)))
281           (cond ((minusp count)
282                  (syscall-error))
283                 ((< 0 count size)
284                  (buf count))))))))
285
286 (progn
287   (export 'getcwd :sb-posix)
288   (defun getcwd ()
289     (flet ((%getcwd (buffer size)
290              (alien-funcall
291               (extern-alien #-win32 "getcwd"
292                             #+win32 "_getcwd" (function c-string (* t) int))
293               buffer size)))
294       (with-growing-c-string (buf size)
295         (let ((result (%getcwd buf size)))
296           (cond (result
297                  (buf))
298                 ((/= (get-errno) sb-posix:erange)
299                  (syscall-error))))))))
300
301 #-win32
302 (progn
303  (export 'wait :sb-posix)
304  (declaim (inline wait))
305  (defun wait (&optional statusptr)
306    (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr))
307    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
308           (pid (sb-sys:with-pinned-objects (ptr)
309                  (alien-funcall
310                   (extern-alien "wait" (function pid-t (* int)))
311                   (sb-sys:vector-sap ptr)))))
312      (if (minusp pid)
313          (syscall-error)
314          (values pid (aref ptr 0))))))
315
316 #-win32
317 (progn
318  (export 'waitpid :sb-posix)
319  (declaim (inline waitpid))
320  (defun waitpid (pid options &optional statusptr)
321    (declare (type (sb-alien:alien pid-t) pid)
322             (type (sb-alien:alien int) options)
323             (type (or null (simple-array (signed-byte 32) (1))) statusptr))
324    (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32))))
325           (pid (sb-sys:with-pinned-objects (ptr)
326                  (alien-funcall
327                   (extern-alien "waitpid" (function pid-t
328                                                     pid-t (* int) int))
329                   pid (sb-sys:vector-sap ptr) options))))
330      (if (minusp pid)
331          (syscall-error)
332          (values pid (aref ptr 0)))))
333  ;; waitpid macros
334  (define-call "wifexited" boolean never-fails (status int))
335  (define-call "wexitstatus" int never-fails (status int))
336  (define-call "wifsignaled" boolean never-fails (status int))
337  (define-call "wtermsig" int never-fails (status int))
338  (define-call "wifstopped" boolean never-fails (status int))
339  (define-call "wstopsig" int never-fails (status int))
340  #+nil ; see alien/waitpid-macros.c
341  (define-call "wifcontinued" boolean never-fails (status int)))
342
343 ;;; mmap, msync
344 #-win32
345 (progn
346  (define-call ("mmap" :options :largefile) sb-sys:system-area-pointer
347    (lambda (res)
348      (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits))))
349    (addr sap-or-nil) (length unsigned) (prot unsigned)
350    (flags unsigned) (fd file-descriptor) (offset off-t))
351
352  (define-call "munmap" int minusp
353    (start sb-sys:system-area-pointer) (length unsigned))
354
355 (define-call "msync" int minusp
356   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
357
358 #-win32
359 (define-call "getpagesize" int minusp)
360 #+win32
361 ;;; KLUDGE: This could be taken from GetSystemInfo
362 (export (defun getpagesize () 4096))
363
364 ;;; passwd database
365 #-win32
366 (define-protocol-class passwd alien-passwd ()
367   ((name :initarg :name :accessor passwd-name)
368    (passwd :initarg :passwd :accessor passwd-passwd)
369    (uid :initarg :uid :accessor passwd-uid)
370    (gid :initarg :gid :accessor passwd-gid)
371    (gecos :initarg :gecos :accessor passwd-gecos)
372    (dir :initarg :dir :accessor passwd-dir)
373    (shell :initarg :shell :accessor passwd-shell)))
374
375 (defmacro define-pw-call (name arg type)
376   #-win32
377   ;; FIXME: this isn't the documented way of doing this, surely?
378   (let ((lisp-name (intern (string-upcase name) :sb-posix)))
379     `(progn
380       (export ',lisp-name :sb-posix)
381       (declaim (inline ,lisp-name))
382       (defun ,lisp-name (,arg)
383         (let ((r (alien-funcall (extern-alien ,name ,type) ,arg)))
384           (if (null r)
385               r
386               (alien-to-passwd r)))))))
387
388 (define-pw-call "getpwnam" login-name (function (* alien-passwd) c-string))
389 (define-pw-call "getpwuid" uid (function (* alien-passwd) uid-t))
390
391 #-win32
392 (define-protocol-class timeval alien-timeval ()
393   ((sec :initarg :tv-sec :accessor timeval-sec)
394    (usec :initarg :tv-usec :accessor timeval-usec)))
395
396 (define-protocol-class stat alien-stat ()
397   ((mode :initarg :mode :accessor stat-mode)
398    (ino :initarg :ino :accessor stat-ino)
399    (dev :initarg :dev :accessor stat-dev)
400    (nlink :initarg :nlink :accessor stat-nlink)
401    (uid :initarg :uid :accessor stat-uid)
402    (gid :initarg :gid :accessor stat-gid)
403    (size :initarg :size :accessor stat-size)
404    (atime :initarg :atime :accessor stat-atime)
405    (mtime :initarg :mtime :accessor stat-mtime)
406    (ctime :initarg :ctime :accessor stat-ctime)))
407
408 (defmacro define-stat-call (name arg designator-fun type)
409   ;; FIXME: this isn't the documented way of doing this, surely?
410   (let ((lisp-name (lisp-for-c-symbol name)))
411     `(progn
412       (export ',lisp-name :sb-posix)
413       (declaim (inline ,lisp-name))
414       (defun ,lisp-name (,arg &optional stat)
415         (declare (type (or null (sb-alien:alien (* alien-stat))) stat))
416         (with-alien-stat a-stat ()
417           (let ((r (alien-funcall
418                     (extern-alien ,(real-c-name (list name :options :largefile)) ,type)
419                     (,designator-fun ,arg)
420                     a-stat)))
421             (when (minusp r)
422               (syscall-error))
423             (alien-to-stat a-stat stat)))))))
424
425 (define-stat-call #-win32 "stat" #+win32 "_stat"
426                   pathname filename
427                   (function int c-string (* alien-stat)))
428
429 #-win32
430 (define-stat-call "lstat"
431                   pathname filename
432                   (function int c-string (* alien-stat)))
433 ;;; No symbolic links on Windows, so use stat
434 #+win32
435 (progn
436   (declaim (inline lstat))
437   (export (defun lstat (filename &optional stat)
438             (if stat (stat filename stat) (stat filename)))))
439
440 (define-stat-call #-win32 "fstat" #+win32 "_fstat"
441                   fd file-descriptor
442                   (function int int (* alien-stat)))
443
444
445 ;;; mode flags
446 (define-call "s_isreg" boolean never-fails (mode mode-t))
447 (define-call "s_isdir" boolean never-fails (mode mode-t))
448 (define-call "s_ischr" boolean never-fails (mode mode-t))
449 (define-call "s_isblk" boolean never-fails (mode mode-t))
450 (define-call "s_isfifo" boolean never-fails (mode mode-t))
451 (define-call "s_islnk" boolean never-fails (mode mode-t))
452 (define-call "s_issock" boolean never-fails (mode mode-t))
453
454 #-win32
455 (progn
456  (export 'pipe :sb-posix)
457  (declaim (inline pipe))
458  (defun pipe (&optional filedes2)
459    (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2))
460    (unless filedes2
461      (setq filedes2 (make-array 2 :element-type '(signed-byte 32))))
462    (let ((r (sb-sys:with-pinned-objects (filedes2)
463               (alien-funcall
464                ;; FIXME: (* INT)?  (ARRAY INT 2) would be better
465                (extern-alien "pipe" (function int (* int)))
466                (sb-sys:vector-sap filedes2)))))
467      (when (minusp r)
468        (syscall-error)))
469    (values (aref filedes2 0) (aref filedes2 1))))
470
471 #-win32
472 (define-protocol-class termios alien-termios ()
473   ((iflag :initarg :iflag :accessor sb-posix:termios-iflag)
474    (oflag :initarg :oflag :accessor sb-posix:termios-oflag)
475    (cflag :initarg :cflag :accessor sb-posix:termios-cflag)
476    (lflag :initarg :lflag :accessor sb-posix:termios-lflag)
477    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs)))
478
479 #-win32
480 (progn
481  (export 'tcsetattr :sb-posix)
482  (declaim (inline tcsetattr))
483  (defun tcsetattr (fd actions termios)
484    (declare (type termios termios))
485    (with-alien-termios a-termios ()
486      (termios-to-alien termios a-termios)
487      (let ((fd (file-descriptor fd)))
488        (let* ((r (alien-funcall
489                   (extern-alien
490                    "tcsetattr"
491                    (function int int int (* alien-termios)))
492                   fd actions a-termios)))
493          (when (minusp r)
494            (syscall-error)))
495        (values))))
496  (export 'tcgetattr :sb-posix)
497  (declaim (inline tcgetattr))
498  (defun tcgetattr (fd &optional termios)
499    (declare (type (or null termios) termios))
500    (with-alien-termios a-termios ()
501      (let ((r (alien-funcall
502                (extern-alien "tcgetattr"
503                              (function int int (* alien-termios)))
504                (file-descriptor fd)
505                a-termios)))
506        (when (minusp r)
507          (syscall-error))
508        (setf termios (alien-to-termios a-termios termios))))
509    termios)
510  (export 'cfsetispeed :sb-posix)
511  (declaim (inline cfsetispeed))
512  (defun cfsetispeed (speed &optional termios)
513    (declare (type (or null termios) termios))
514    (with-alien-termios a-termios ()
515      (let ((r (alien-funcall
516                (extern-alien "cfsetispeed"
517                              (function int (* alien-termios) speed-t))
518                a-termios
519                speed)))
520        (when (minusp r)
521          (syscall-error))
522        (setf termios (alien-to-termios a-termios termios))))
523    termios)
524  (export 'cfsetospeed :sb-posix)
525  (declaim (inline cfsetospeed))
526  (defun cfsetospeed (speed &optional termios)
527    (declare (type (or null termios) termios))
528    (with-alien-termios a-termios ()
529      (let ((r (alien-funcall
530                (extern-alien "cfsetospeed"
531                              (function int (* alien-termios) speed-t))
532                a-termios
533                speed)))
534        (when (minusp r)
535          (syscall-error))
536        (setf termios (alien-to-termios a-termios termios))))
537    termios)
538  (export 'cfgetispeed :sb-posix)
539  (declaim (inline cfgetispeed))
540  (defun cfgetispeed (termios)
541    (declare (type termios termios))
542    (with-alien-termios a-termios ()
543      (termios-to-alien termios a-termios)
544      (alien-funcall (extern-alien "cfgetispeed"
545                                   (function speed-t (* alien-termios)))
546                     a-termios)))
547  (export 'cfgetospeed :sb-posix)
548  (declaim (inline cfgetospeed))
549  (defun cfgetospeed (termios)
550    (declare (type termios termios))
551    (with-alien-termios a-termios ()
552      (termios-to-alien termios a-termios)
553      (alien-funcall (extern-alien "cfgetospeed"
554                                  (function speed-t (* alien-termios)))
555                     a-termios))))
556
557
558 #-win32
559 (progn
560   (export 'time :sb-posix)
561   (defun time ()
562     (let ((result (alien-funcall (extern-alien "time"
563                                                (function time-t (* time-t)))
564                                  nil)))
565       (if (minusp result)
566           (syscall-error)
567           result)))
568   (export 'utime :sb-posix)
569   (defun utime (filename &optional access-time modification-time)
570     (let ((fun (extern-alien "utime" (function int c-string
571                                                (* alien-utimbuf))))
572           (name (filename filename)))
573       (if (not (and access-time modification-time))
574           (alien-funcall fun name nil)
575           (with-alien ((utimbuf (struct alien-utimbuf)))
576             (setf (slot utimbuf 'actime) (or access-time 0)
577                   (slot utimbuf 'modtime) (or modification-time 0))
578             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
579               (if (minusp result)
580                   (syscall-error)
581                   result))))))
582   (export 'utimes :sb-posix)
583   (defun utimes (filename &optional access-time modification-time)
584     (flet ((seconds-and-useconds (time)
585              (multiple-value-bind (integer fractional)
586                  (cl:truncate time)
587                (values integer (cl:truncate (* fractional 1000000)))))
588            (maybe-syscall-error (value)
589              (if (minusp value)
590                  (syscall-error)
591                  value)))
592       (let ((fun (extern-alien "utimes" (function int c-string
593                                                   (* (array alien-timeval 2)))))
594             (name (filename filename)))
595         (if (not (and access-time modification-time))
596             (maybe-syscall-error (alien-funcall fun name nil))
597             (with-alien ((buf (array alien-timeval 2)))
598               (let ((actime (deref buf 0))
599                     (modtime (deref buf 1)))
600                 (setf (values (slot actime 'sec)
601                               (slot actime 'usec))
602                       (seconds-and-useconds (or access-time 0))
603                       (values (slot modtime 'sec)
604                               (slot modtime 'usec))
605                       (seconds-and-useconds (or modification-time 0)))
606                 (maybe-syscall-error (alien-funcall fun name
607                                                     (alien-sap buf))))))))))
608
609
610 ;;; environment
611
612 (export 'getenv :sb-posix)
613 (defun getenv (name)
614   (let ((r (alien-funcall
615             (extern-alien "getenv" (function (* char) c-string))
616             name)))
617     (declare (type (alien (* char)) r))
618     (unless (null-alien r)
619       (cast r c-string))))
620 (define-call "putenv" int minusp (string c-string))
621
622 ;;; syslog
623 #-win32
624 (progn
625   (export 'openlog :sb-posix)
626   (export 'syslog :sb-posix)
627   (export 'closelog :sb-posix)
628   (defun openlog (ident options &optional (facility log-user))
629     (alien-funcall (extern-alien
630                     "openlog" (function void c-string int int))
631                    ident options facility))
632   (defun syslog (priority format &rest args)
633     "Send a message to the syslog facility, with severity level
634 PRIORITY.  The message will be formatted as by CL:FORMAT (rather
635 than C's printf) with format string FORMAT and arguments ARGS."
636     (flet ((syslog1 (priority message)
637              (alien-funcall (extern-alien
638                              "syslog" (function void int c-string c-string))
639                             priority "%s" message)))
640       (syslog1 priority (apply #'format nil format args))))
641   (define-call "closelog" void never-fails))