scsh-0.5/scsh/syscalls.scm

1141 lines
34 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
;;; POSIX system-call Scheme binding.
;;; Copyright (c) 1993 by Olin Shivers. See file COPYING.
1995-10-13 23:34:21 -04:00
;;; Scheme48 implementation.
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
(foreign-source
"#include <sys/signal.h>"
"#include <sys/types.h>"
"#include <sys/times.h>"
"#include <sys/time.h>"
"#include <fcntl.h> /* for O_RDWR */" ; ???
"#include <sys/stat.h>"
"#include <errno.h>"
1995-10-13 23:34:21 -04:00
"#include <netdb.h>"
"#include <pwd.h>"
"#include <unistd.h>"
""
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
"#include \"dirstuff1.h\""
"#include \"fdports1.h\""
"#include \"select1.h\""
"#include \"syscalls1.h\""
"#include \"userinfo1.h\""
""
1995-10-13 23:34:21 -04:00
"#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno))"
"#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
"#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)" ; Not a function.
"" "")
1996-08-22 16:13:14 -04:00
;;; Macro for converting syscalls that return error codes to ones that
1995-10-13 23:34:21 -04:00
;;; raise exceptions on errors.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from
;;; one that returns an error code as its first return value -- #f for win,
1996-08-22 16:13:14 -04:00
;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall),
;;; we try again.
1995-10-13 23:34:21 -04:00
;;;
;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
;;;
;;; (define (SYSCALL . ARGS)
;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
1996-08-22 16:13:14 -04:00
;;; (cond ((not err) (values . RET-VALS)) ; Win
;;; ((= err errno/intr) (SYSCALL . ARGS)) ; Retry
;;; (else (errno-error err SYSCALL . ARGS))))); Lose
1995-10-13 23:34:21 -04:00
(define-syntax define-errno-syscall
(syntax-rules ()
((define-errno-syscall (syscall arg ...) syscall/errno
ret-val ...)
(define (syscall arg ...)
(receive (err ret-val ...) (syscall/errno arg ...)
1996-08-22 16:13:14 -04:00
(cond ((not err) (values ret-val ...)) ; Win
((= err errno/intr) (syscall arg ...)) ; Retry
(else (errno-error err syscall arg ...)))))) ; Lose
1995-10-13 23:34:21 -04:00
;;; This case handles rest args
((define-errno-syscall (syscall . args) syscall/errno
ret-val ...)
(define (syscall . args)
1996-08-22 16:13:14 -04:00
(receive (err ret-val ...) (apply syscall/errno args)
(cond ((not err) (values ret-val ...)) ; Win
((= err errno/intr) (apply syscall args)) ; Retry
(else (apply errno-error err syscall args)))))))); Lose
1995-10-13 23:34:21 -04:00
;;; By the way, it would be better to insert a (LET LP () ...) for the
;;; the errno/intr retries, instead of calling the top-level definition
;;; (because in Scheme you have to allow for the fact that top-level
;;; defns can be re-defined, so the compiler can't just turn it into a
;;; jump), but the brain-dead S48 byte-compiler will cons a closure for
;;; the LP loop, which means that little syscalls like read-char can cons
;;; like crazy. So I'm doing it this way. Ech.
1995-10-13 23:34:21 -04:00
;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %%exec/errno
(scheme_exec (string prog)
(vector-desc argv)
(desc env)) ; string vector or #t.
integer)
(define (%%exec prog argv env)
(errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
1995-10-13 23:34:21 -04:00
(define (%exec prog arg-list env)
(let ((argv (mapv! stringify (list->vector arg-list)))
(prog (stringify prog))
(env (if (eq? env #t) #t (alist->env-vec env))))
1995-10-13 23:34:21 -04:00
(%%exec prog argv env)))
(define-foreign exit/errno ; errno -- misnomer.
(exit (integer status))
ignore)
(define-foreign %exit/errno ; errno -- misnomer
(_exit (integer status))
ignore)
(define (%exit . maybe-status)
(%exit/errno (:optional maybe-status 0))
1995-10-13 23:34:21 -04:00
(error "Yikes! %exit returned."))
(define-foreign %%fork/errno (fork)
(multi-rep (to-scheme pid_t errno_or_false)
pid_t))
;;; If the fork fails, and we are doing early zombie reaping, then reap
;;; some zombies to try and free up a some space in the process table,
;;; and try again.
;;;
;;; This ugly little hack will have to stay in until I do early
;;; zombie reaping with SIGCHLD interrupts.
1995-10-13 23:34:21 -04:00
(define (%%fork-with-retry/errno)
(receive (err pid) (%%fork/errno)
(cond ((and err (eq? 'early (autoreap-policy)))
(reap-zombies)
(%%fork/errno))
(else (values err pid)))))
(define-errno-syscall (%%fork) %%fork-with-retry/errno
pid)
1995-10-13 23:34:21 -04:00
;;; Posix waitpid(2) call.
(define-foreign %wait-pid/errno (wait_pid (integer pid) (integer options))
desc ; errno or #f
integer ; process' id
integer) ; process' status
;;; Miscellaneous process state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Working directory
(define-foreign %chdir/errno
(chdir (string directory))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%chdir dir) %chdir/errno)
1995-10-13 23:34:21 -04:00
(define (chdir . maybe-dir)
(let ((dir (:optional maybe-dir (home-dir))))
1995-10-13 23:34:21 -04:00
(%chdir (ensure-file-name-is-nondirectory dir))))
(define-foreign cwd/errno (scheme_cwd)
(to-scheme integer "False_on_zero") ; errno or #f
string) ; directory (or #f on error)
(define-errno-syscall (cwd) cwd/errno
dir)
;;; GID
(define-foreign user-gid (getgid) gid_t)
(define-foreign user-effective-gid (getegid) gid_t)
(define-foreign set-gid/errno (setgid (gid_t id)) no-declare ; for SunOS 4.x
1995-10-13 23:34:21 -04:00
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-gid gid) set-gid/errno)
1995-10-13 23:34:21 -04:00
(define-foreign %num-supplementary-gids/errno (num_supp_groups)
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-foreign load-groups/errno (get_groups (vector-desc group-vec))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define (user-supplementary-gids)
(receive (err numgroups) (%num-supplementary-gids/errno)
(if err (errno-error err user-supplementary-gids)
(let ((vec (make-vector numgroups)))
(receive (err numgroups2) (load-groups/errno vec)
(if err (errno-error err user-supplementary-gids)
(vector->list vec)))))))
;;; UID
(define-foreign user-uid (getuid) uid_t)
(define-foreign user-effective-uid (geteuid) uid_t)
(define-foreign set-uid/errno (setuid (uid_t id)) no-declare ; for SunOS 4.x
1995-10-13 23:34:21 -04:00
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-uid uid_t) set-uid/errno)
1995-10-13 23:34:21 -04:00
(define-foreign %user-login-name (my_username)
static-string)
(define (user-login-name)
(or (%user-login-name)
(error "Cannot get your name")))
;;; PID
(define-foreign pid (getpid) pid_t)
(define-foreign parent-pid (getppid) pid_t)
1995-10-26 09:35:40 -04:00
;;; Process groups and session ids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1995-10-13 23:34:21 -04:00
(define-foreign process-group (getpgrp) pid_t)
(define-foreign %set-process-group/errno
(setpgid (pid_t pid) (pid_t groupid))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%set-process-group pid pgrp)
1995-10-13 23:34:21 -04:00
%set-process-group/errno)
1995-10-26 09:35:40 -04:00
1995-10-13 23:34:21 -04:00
(define (set-process-group arg1 . maybe-arg2)
(receive (pid pgrp) (if (null? maybe-arg2)
(values (pid) arg1)
(values arg1 (car maybe-arg2)))
(%set-process-group pid pgrp)))
1995-10-26 09:35:40 -04:00
(define-foreign become-session-leader/errno (setsid)
(multi-rep (to-scheme pid_t errno_or_false)
pid_t))
(define-errno-syscall (become-session-leader) become-session-leader/errno
sid)
1995-10-13 23:34:21 -04:00
;;; UMASK
(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
mode_t)
(define (umask)
(let ((m (set-umask 0)))
(set-umask m)
m))
;;; PROCESS TIMES
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
;;; OOPS: The ret values should be clock_t, not int, but cig can't handle it.
1995-10-13 23:34:21 -04:00
(define-foreign process-times/errno (process_times)
(to-scheme integer errno_or_false)
integer ; user cpu time
integer ; system cpu time
integer ; user cpu time for me and all my descendants.
integer) ; system cpu time for me and all my descendants.
(define-errno-syscall (process-times) process-times/errno
utime stime cutime cstime)
(define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer)
;;; File system
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Useful little utility for generic ops that work on filenames, fd's or
;;; ports.
(define (generic-file-op thing fd-op fname-op)
(if (string? thing) (fname-op thing)
(call/fdes thing fd-op)))
(define-foreign set-file-mode/errno
(chmod (string path) (mode_t mode)) no-declare ; integer on SunOS
(to-scheme integer errno_or_false))
; IBM's AIX include files declare fchmod(char*, mode_t).
; Amazing, but true. So we must prevent this def-foreign from issuing
; the conflicting, correct declaration. Hence the NO-DECLARE.
(define-foreign set-fdes-mode/errno
(fchmod (integer fd) (mode_t mode)) ; integer on SunOS
no-declare ; Workaround for AIX bug.
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-file-mode thing mode)
1995-10-13 23:34:21 -04:00
(lambda (thing mode)
(generic-file-op thing
(lambda (fd) (set-fdes-mode/errno fd mode))
(lambda (fname) (set-file-mode/errno fname mode)))))
;;; NO-DECLARE: gcc unistd.h bogusness.
(define-foreign set-file-uid&gid/errno
(chown (string path) (uid_t uid) (gid_t gid)) no-declare
(to-scheme integer errno_or_false))
(define-foreign set-fdes-uid&gid/errno
(fchown (integer fd) (uid_t uid) (gid_t gid)) no-declare ; for NT Cygwin
1995-10-13 23:34:21 -04:00
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-file-owner thing uid)
1995-10-13 23:34:21 -04:00
(lambda (thing uid)
(generic-file-op thing
(lambda (fd) (set-fdes-uid&gid/errno fd uid -1))
(lambda (fname) (set-file-uid&gid/errno fname uid -1)))))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-file-group thing gid)
1995-10-13 23:34:21 -04:00
(lambda (thing gid)
(generic-file-op thing
1997-04-02 15:12:33 -05:00
(lambda (fd) (set-fdes-uid&gid/errno fd -1 gid))
(lambda (fname) (set-file-uid&gid/errno fname -1 gid)))))
1995-10-13 23:34:21 -04:00
;;; Uses real uid and gid, not effective. I don't use this anywhere.
(define-foreign %file-ruid-access-not?
(access (string path)
(integer perms))
bool)
;(define (file-access? path perms)
; (not (%file-access-not? path perms)))
;
;(define (file-executable? fname)
; (file-access? fname 1))
;
;(define (file-writable? fname)
; (file-access? fname 2))
;
;(define (file-readable? fname)
; (file-access? fname 4))
(define-foreign create-hard-link/errno
(link (string original-name) (string new-name))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (create-hard-link original-name new-name)
1995-10-13 23:34:21 -04:00
create-hard-link/errno)
(define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode))
no-declare ; integer on SunOS
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (create-fifo path mode) create-fifo/errno)
1995-10-13 23:34:21 -04:00
(define-foreign create-directory/errno
(mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS.
(to-scheme integer errno_or_false))
(define (create-directory path . maybe-mode)
(let ((mode (:optional maybe-mode #o777))
1995-10-13 23:34:21 -04:00
(fname (ensure-file-name-is-nondirectory path)))
(cond ((create-directory/errno fname mode) =>
(lambda (err)
(if err (errno-error err create-directory path mode)))))))
1995-10-13 23:34:21 -04:00
(define-foreign read-symlink/errno (scm_readlink (string path))
(multi-rep (to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
static-string))
(define-errno-syscall (read-symlink path) read-symlink/errno
new-path)
(define-foreign %rename-file/errno
(rename (string old-name) (string new-name))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%rename-file old-name new-name)
1995-10-13 23:34:21 -04:00
%rename-file/errno)
(define-foreign delete-directory/errno
(rmdir (string path))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (delete-directory path) delete-directory/errno)
1995-10-13 23:34:21 -04:00
(define-foreign %utime/errno (scm_utime (string path)
(integer ac_hi) (integer ac_lo)
(integer m_hi) (integer m_lo))
(to-scheme integer errno_or_false))
(define-foreign %utime-now/errno (scm_utime_now (string path))
(to-scheme integer errno_or_false))
;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time])
(define (set-file-times/errno path . maybe-times)
(if (pair? maybe-times)
(let* ((access-time (real->exact-integer (car maybe-times)))
(mod-time (if (pair? (cddr maybe-times))
(error "Too many arguments to set-file-times/errno"
(cons path maybe-times))
(real->exact-integer (cadr maybe-times)))))
(%utime/errno path (hi8 access-time) (lo24 access-time)
(hi8 mod-time) (lo24 mod-time)))
(%utime-now/errno path)))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (set-file-times . args) set-file-times/errno)
1995-10-13 23:34:21 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STAT
(define-foreign stat-file/errno
(scheme_stat (string path) (vector-desc data) (bool chase?))
(to-scheme integer "False_on_zero")) ; errno or #f
;(define-errno-syscall (stat-file fd data chase?) stat-file/errno)
(define-foreign stat-fdes/errno
(scheme_fstat (integer fd) (vector-desc data))
(to-scheme integer "False_on_zero")) ; errno or #f
;(define-errno-syscall (stat-fdes fd data) stat-fdes/errno)
(define-record file-info
type
device
inode
mode
nlinks
uid
gid
size
atime
mtime
ctime
)
;;; Should be redone to return multiple-values.
(define (file-info/errno fd/port/fname chase?)
(let ((ans-vec (make-vector 14))
(time-hack (lambda (lo-24 hi-8)
(let ((val (+ (arithmetic-shift hi-8 24) lo-24)))
(if (zero? (bitwise-and hi-8 #x80)) val
;; Oops -- it's a negative 32-bit value.
;; Or in all the sign bits.
(bitwise-ior (bitwise-not #xffffffff)
val)))))
(file-type (lambda (type-code)
(vector-ref '#(block-special char-special directory fifo
regular socket symlink)
type-code))))
(cond ((generic-file-op fd/port/fname
(lambda (fd)
(stat-fdes/errno fd ans-vec))
(lambda (fname)
(stat-file/errno fname ans-vec chase?)))
=> (lambda (err) (values err #f)))
(else (values #f (make-file-info (file-type (vector-ref ans-vec 0))
(vector-ref ans-vec 1)
(vector-ref ans-vec 2)
(vector-ref ans-vec 3)
(vector-ref ans-vec 4)
(vector-ref ans-vec 5)
(vector-ref ans-vec 6)
(vector-ref ans-vec 7)
(time-hack (vector-ref ans-vec 8)
(vector-ref ans-vec 9))
(time-hack (vector-ref ans-vec 10)
(vector-ref ans-vec 11))
(time-hack (vector-ref ans-vec 12)
(vector-ref ans-vec 13))))))))
(define (file-info fd/port/fname . maybe-chase?)
(let ((chase? (:optional maybe-chase? #t)))
(receive (err info) (file-info/errno fd/port/fname chase?)
(if err (errno-error err file-info fd/port/fname chase?)
info))))
1995-10-13 23:34:21 -04:00
(define file-attributes
(deprecated-proc file-info "file-attributes" "Use file-info instead."))
;;; "no-declare" as there is no agreement among the OS's as to whether or not
;;; the OLD-NAME arg is "const". It *should* be const.
(define-foreign create-symlink/errno
(symlink (string old-name) (string new-name)) no-declare
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
;(define-errno-syscall (create-symlink old-name new-name)
1995-10-13 23:34:21 -04:00
; create-symlink/errno)
;;; "no-declare" as there is no agreement among the OS's as to whether or not
;;; the PATH arg is "const". It *should* be const.
(define-foreign truncate-file/errno
(truncate (string path) (off_t length)) no-declare
(to-scheme integer errno_or_false))
(define-foreign truncate-fdes/errno
(ftruncate (integer fd) (off_t length)) no-declare ; Indigo bogosity.
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (truncate-file path length)
1995-10-13 23:34:21 -04:00
(lambda (thing length)
(generic-file-op thing
(lambda (fd) (truncate-fdes/errno fd length))
(lambda (fname) (truncate-file/errno fname length)))))
(define-foreign delete-file/errno
(unlink (string path))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (delete-file path) delete-file/errno)
1995-10-13 23:34:21 -04:00
(define-foreign sync-file/errno (fsync (integer fd))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (sync-file fd/port)
1995-10-13 23:34:21 -04:00
(lambda (fd/port)
(if (output-port? fd/port) (force-output fd/port))
(sleazy-call/fdes fd/port sync-file/errno)))
1995-10-13 23:34:21 -04:00
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int
ignore)
;;; I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %close-fdes/errno (close (integer fd))
(to-scheme integer "errno_or_false"))
(define (%close-fdes fd)
(let lp ()
(let ((errno (%close-fdes/errno fd)))
(cond ((not errno) #t) ; Successful close.
((= errno errno/badf) #f) ; File descriptor already closed.
((= errno errno/intr) (lp)) ; Retry.
(else
(errno-error errno %close-fdes fd)))))) ; You lose.
(define-foreign %dup/errno
(dup (integer fd))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-errno-syscall (%dup fd) %dup/errno
new-fd)
(define-foreign %dup2/errno
(dup2 (integer fd-from) (integer fd-to))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno
new-fd)
(define-foreign %fd-seek/errno
(lseek (integer fd) (off_t offset) (integer whence))
(multi-rep (to-scheme off_t errno_or_false)
off_t))
(define seek/set 0) ;Unix codes for "whence"
(define seek/delta 1)
(define seek/end 2)
(define (seek fd/port offset . maybe-whence)
(let ((whence (:optional maybe-whence seek/set)))
(receive (err cursor)
((if (integer? fd/port) %fd-seek/errno %fdport-seek/errno)
fd/port
offset
whence)
(if err (errno-error err seek fd/port offset whence) cursor))))
1995-10-13 23:34:21 -04:00
(define (tell fd/port)
(receive (err offset) (if (integer? fd/port)
(%fd-seek/errno fd/port 0 seek/delta) ; seek(fd)
(%fdport-tell/errno fd/port)) ; ftell(f)
(if err (errno-error err tell fd/port) offset)))
1995-10-13 23:34:21 -04:00
(define-foreign %char-ready-fdes?/errno
(char_ready_fdes (integer fd))
desc) ; errno, #t, or #f
(define (%char-ready-fdes? fd)
(let ((retval (%char-ready-fdes?/errno fd)))
(if (integer? retval) (errno-error retval %char-ready-fdes? fd)
retval)))
(define-foreign %open/errno
(open (string path)
(integer flags)
(mode_t mode)) ; integer on SunOS
no-declare ; NOTE
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-errno-syscall (%open path flags mode) %open/errno
fd)
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
(%open path flags (:optional maybe-mode #o666)))
1995-10-13 23:34:21 -04:00
(define-foreign pipe-fdes/errno (scheme_pipe)
(to-scheme integer "False_on_zero") ; Win: #f, lose: errno
integer ; r
integer) ; w
(define-errno-syscall (pipe-fdes) pipe-fdes/errno
r w)
(define (pipe)
(receive (r-fd w-fd) (pipe-fdes)
(let ((r (fdes->inport r-fd))
(w (fdes->outport w-fd)))
(release-port-handle r)
(release-port-handle w)
(values r w))))
(define-foreign %read-fdes-char
(read_fdes_char (integer fd))
desc) ; Char or errno or #f (eof).
(define (read-fdes-char fd)
(let ((c (%read-fdes-char fd)))
(if (integer? c) (errno-error c read-fdes-char fd) c)))
1995-10-13 23:34:21 -04:00
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (integer fd))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
1995-10-13 23:34:21 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read and write
(define-foreign read-fdes-substring!/errno
(read_fdes_substring (string-desc buf)
(integer start)
(integer end)
(integer fd))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-foreign write-fdes-substring/errno
(write_fdes_substring (string-desc buf)
(integer start)
(integer end)
(integer fd))
(multi-rep (to-scheme integer errno_or_false)
integer))
;;; Signals (rather incomplete)
;;; ---------------------------
(define-foreign signal-pid/errno
(kill (pid_t pid) (integer signal))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (signal-pid pid signal) signal-pid/errno)
1995-10-13 23:34:21 -04:00
(define (signal-process proc signal)
(signal-pid (cond ((proc? proc) (proc:pid proc))
((integer? proc) proc)
(else (error "Illegal proc passed to signal-process" proc)))
signal))
(define (signal-process-group proc-group signal)
(signal-pid (- (cond ((proc? proc-group) (proc:pid proc-group))
((integer? proc-group) proc-group)
(else (error "Illegal proc passed to signal-process-group"
proc-group))))
signal))
;;; SunOS, not POSIX:
;;; (define-foreign signal-process-group/errno
;;; (killpg (integer proc-group) (integer signal))
;;; (to-scheme integer errno_or_false))
;;;
1996-08-22 16:13:14 -04:00
;;; (define-errno-syscall (signal-process-group proc-group signal)
1995-10-13 23:34:21 -04:00
;;; signal-process-group/errno)
(define-foreign pause-until-interrupt (pause) no-declare ignore)
(define-foreign itimer (alarm (uint_t secs)) uint_t)
;;; User info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record user-info
name uid gid home-dir shell
;; Make user-info records print like #{user-info shivers}.
((disclose ui)
(list "user-info" (user-info:name ui))))
(define-foreign %uid->user-info (user_info_uid (uid_t uid))
bool ; win?
static-string ; name
gid_t ; gid
static-string ; home-dir
static-string); shell
(define-foreign %name->user-info (user_info_name (string name))
bool ; win?
uid_t ; uid
gid_t ; gid
static-string ; home-dir
static-string); shell
(define (uid->user-info uid)
(receive (win? name gid home-dir shell)
(%uid->user-info uid)
(if win? (make-user-info name uid gid home-dir shell)
(error "Cannot get user's information" uid->user-info uid))))
(define (name->user-info name)
(receive (win? uid gid home-dir shell)
(%name->user-info name)
(if win? (make-user-info name uid gid home-dir shell)
(error "Cannot get user's information" name->user-info name))))
(define (user-info uid/name)
((cond ((string? uid/name) name->user-info)
((integer? uid/name) uid->user-info)
(else (error "user-info arg must be string or integer" uid/name)))
uid/name))
;;; Derived functions
(define (->uid uid/name)
(user-info:uid (user-info uid/name)))
(define (->username uid/name)
(user-info:name (user-info uid/name)))
(define (%homedir uid/name)
(user-info:home-dir (user-info uid/name)))
;;; Group info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record group-info
name gid members
;; Make group-info records print like #{group-info wheel}.
((disclose gi) (list "group-info" (group-info:name gi))))
;;; These guys return static structs, so they aren't reentrant.
;;; Must be fixed for threaded version.
(define-foreign %gid->group-info
(group_info_gid (integer gid))
bool ; win?
static-string ; name
(C char**) ; members
integer) ; num members
(define-foreign %name->group-info
(group_info_name (string name))
bool ; win?
integer ; gid
(C char**) ; members
integer) ; num members
(define (gid->group-info gid)
(receive (win? name members nmembers)
(%gid->group-info gid)
(if win?
(make-group-info name gid
(vector->list (C-string-vec->Scheme members nmembers)))
(error "Cannot get group's information for gid" gid))))
(define (name->group-info name)
(receive (win? gid members nmembers)
(%name->group-info name)
(if win?
(make-group-info name gid
(vector->list (C-string-vec->Scheme members nmembers)))
(error "Cannot get group's information for name" name))))
(define (group-info gid/name)
((cond ((string? gid/name) name->group-info)
((integer? gid/name) gid->group-info)
(else (error "group-info arg must be string or integer" gid/name)))
gid/name))
;;; Derived functions
(define (->gid name)
(group-info:gid (group-info name)))
(define (->groupname gid)
(group-info:name (group-info gid)))
;;; Directory stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %open-dir (open_dir (string dir-name))
(to-scheme integer "False_on_zero") ; Win: #f, lose: errno
(C char**) ; Vector of strings
integer) ; Length of strings
;;; Takes a null-terminated C vector of strings -- filenames.
;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others.
(define-foreign %sort-file-vector
(scm_sort_filevec ((C "const char** ~a") cvec)
1995-10-13 23:34:21 -04:00
(integer veclen))
ignore)
(define (directory-files . args)
(let-optionals args ((dir ".")
(dotfiles? #f))
1995-10-13 23:34:21 -04:00
(check-arg string? dir directory-files)
(receive (err cvec numfiles)
(%open-dir (ensure-file-name-is-nondirectory dir))
(if err (errno-error err directory-files dir dotfiles?))
1995-10-13 23:34:21 -04:00
(%sort-file-vector cvec numfiles)
(let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
(if dotfiles? files
(filter (lambda (f) (not (char=? (string-ref f 0) #\.)))
files))))))
;;; I do this one in C, I'm not sure why:
;;; It is used by MATCH-FILES.
;;; 99/7: No one is using this function, so I'm commenting it out.
;;; Later, we could tune up the globber or regexp file-matcher to use
;;; it (but should shift it into the rx directory). But I should also go
;;; to a file-at-a-time cursor model for directory fetching. -Olin
;(define-foreign %filter-C-strings!
; (filter_stringvec (string-desc pattern) ((C "char const ** ~a") cvec))
; integer) ; number of files that pass the filter.
;(define (match-files regexp . maybe-dir)
; (let ((dir (:optional maybe-dir ".")))
; (check-arg string? dir match-files)
; (receive (err cvec numfiles)
; (%open-dir (ensure-file-name-is-nondirectory dir))
; (if err (errno-error err match-files regexp dir))
; (receive (numfiles) (%filter-C-strings! regexp cvec)
; ;(if err (error err match-files))
; (%sort-file-vector cvec numfiles)
; (let ((files (C-string-vec->Scheme&free cvec numfiles)))
; (vector->list files))))))
1995-10-13 23:34:21 -04:00
;;; Environment manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (var . val) / "var=val" rep conversion:
(define (split-env-string var=val)
(let ((i (string-index var=val #\=)))
1995-10-13 23:34:21 -04:00
(if i (values (substring var=val 0 i)
(substring var=val (+ i 1) (string-length var=val)))
(error "No \"=\" in environment string" var=val))))
(define (env-list->alist env-list)
(map (lambda (var=val)
(call-with-values (lambda () (split-env-string var=val))
cons))
env-list))
(define (alist->env-vec alist)
(list->vector (map (lambda (var.val)
(string-append (car var.val) "=" (cdr var.val)))
alist)))
1995-10-13 23:34:21 -04:00
;;; ENV->ALIST
(define-foreign %load-env (scm_envvec)
(C char**) ; char **environ
fixnum) ; & its length.
(define (env->list)
(receive (C-env nelts) (%load-env)
(vector->list (C-string-vec->Scheme C-env nelts))))
(define (env->alist) (env-list->alist (env->list)))
;;; ALIST->ENV
(define-foreign %install-env/errno
(install_env (vector-desc env-vec))
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%install-env env-vec) %install-env/errno)
1995-10-13 23:34:21 -04:00
(define (alist->env alist)
(%install-env (alist->env-vec alist)))
1995-10-13 23:34:21 -04:00
;;; GETENV, PUTENV, SETENV
(define-foreign getenv (getenv (string var))
static-string)
(foreign-source
"#define errno_on_nonzero_or_false(x) ((x) ? ENTER_FIXNUM(errno) : SCHFALSE)"
"" "")
;(define-foreign putenv/errno
; (put_env (string var=val))
; desc) ; #f or errno
;;; putenv takes a constant: const char *, cig can't figure that out..
(define-foreign putenv/errno
(putenv (string-copy var=val)) no-declare
(to-scheme integer errno_on_nonzero_or_false)) ; #f or errno
(define-foreign delete-env (delete_env (string var))
ignore)
(define (putenv var=val)
(if (putenv/errno var=val)
(error "malloc failure in putenv" var=val)))
(define (setenv var val)
(if val
(putenv (string-append var "=" val))
(delete-env var)))
;;; Fd-ports
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign close-fdport*/errno (close_fdport (desc data))
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
(define (close-fdport* data)
(let lp ()
(let ((errno (close-fdport*/errno data)))
(cond ((not errno) #t) ; Successful close.
((= errno errno/badf) #f) ; File descriptor already closed.
((= errno errno/intr) (lp)) ; Retry.
(else
(errno-error errno close-fdport* data)))))) ; You lose.
(define-foreign %fdport*-read-char/errno (fdport_getchar (desc data))
desc) ; char, errno, or #f for end-of-file.
(define (%fdport*-read-char data)
(let ((c (%fdport*-read-char/errno data)))
1996-08-22 16:13:14 -04:00
(if (integer? c)
(if (= c errno/intr)
(%fdport*-read-char data) ; Retry
(errno-error c %fdport*-read-char data)) ; Lose
(or c eof-object)))) ; Win
1995-10-13 23:34:21 -04:00
(define-foreign %fdport*-char-ready?/errno
(fdport_char_readyp (desc data))
desc)
(define (%fdport*-char-ready? data)
(let ((val (%fdport*-char-ready?/errno data)))
(if (integer? val) (errno-error val %fdport*-char-ready? data)
1995-10-13 23:34:21 -04:00
val)))
(define-foreign %fdport*-write-char/errno
(fdport_putchar (desc data) (char c))
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%fdport*-write-char desc c)
1995-10-13 23:34:21 -04:00
%fdport*-write-char/errno)
(define-foreign flush-fdport*/errno (flush_fdport (desc data))
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
;;; FLUSH-FDPORT* isn't defined with DEFINE-ERRNO-SYSCALL because that would
;;; return 0 values, which blows up S48's extended-port machinery. This
;;; version returns #f.
;;; ???
(define (flush-fdport* data)
(cond ((flush-fdport*/errno data) =>
(lambda (err) (if (= err errno/intr)
(flush-fdport* data)
(errno-error err flush-fdport* data))))
(else #f)))
1995-10-13 23:34:21 -04:00
(define-foreign flush-all-ports/errno (flush_all_ports)
(to-scheme integer errno_or_false))
1996-08-22 16:13:14 -04:00
(define-errno-syscall (flush-all-ports)
1995-10-13 23:34:21 -04:00
flush-all-ports/errno)
(define-foreign %fdport*-seek/errno
(seek_fdport (desc data) (off_t offset) (integer whence))
(to-scheme integer "False_on_zero") ; errno
integer) ; new position
(define-foreign %fdport*-tell/errno
(tell_fdport (desc data))
(to-scheme integer "False_on_zero") ; errno
integer)
(define-foreign %fdport*-set-buffering/errno
(set_fdbuf (desc data) (integer policy) (integer size))
(to-scheme integer "False_on_zero")) ; errno
(define-foreign %set-cloexec (set_cloexec (integer fd) (bool val))
(to-scheme integer "errno_or_false"))
(define-foreign %init-fdports! (init_fdports) ignore)
1995-10-13 23:34:21 -04:00
(define-foreign %install-port/errno
(install_port (integer fd) (desc port) (integer revealed))
1995-10-13 23:34:21 -04:00
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
(define-errno-syscall (%install-port fd port revealed) %install-port/errno)
1995-10-13 23:34:21 -04:00
(define-foreign %maybe-fdes->port (maybe_fdes2port (integer fd))
desc) ; fd or #f
;;; Doesn't signal on error. Clients must check return value.
(define-foreign %move-fdport
(move_fdport (integer fd) (desc port) (integer new-revealed-count))
bool) ; Win: #f, lose: #t
(define-foreign read-fdport*-substring!/errno
(read_fdport_substring (string-desc buf)
(integer start)
(integer end)
(desc data))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-foreign write-fdport*-substring/errno
(write_fdport_substring (string-desc buf)
(integer start)
(integer end)
(desc fdport))
(multi-rep (to-scheme integer errno_or_false)
integer))
;;; Some of fcntl()
;;;;;;;;;;;;;;;;;;;
(define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command))
(multi-rep (to-scheme integer errno_or_false)
integer))
(define-foreign %fcntl-write/errno
(fcntl_write (fixnum fd) (fixnum command) (fixnum val))
(to-scheme integer errno_or_false))
(define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value)
1996-08-22 16:13:14 -04:00
(define-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
1995-10-13 23:34:21 -04:00
;;; fcntl()'s F_GETFD and F_SETFD. Note that the SLEAZY- prefix on the
;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
;;; of these procedures. Straight CALL/FDES modifies unrevealed file
;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it
;;; would interfere with the reading and writing of that bit!
(define (fdes-flags fd/port)
(sleazy-call/fdes fd/port
(lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags))))
(define (set-fdes-flags fd/port flags)
(sleazy-call/fdes fd/port
(lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags))))
;;; fcntl()'s F_GETFL and F_SETFL.
;;; Get: Returns open flags + get-status flags (below)
;;; Set: append, sync, async, nbio, nonblocking, no-delay
(define (fdes-status fd/port)
(sleazy-call/fdes fd/port
(lambda (fd) (%fcntl-read fd fcntl/get-status-flags))))
1995-10-13 23:34:21 -04:00
(define (set-fdes-status fd/port flags)
(sleazy-call/fdes fd/port
(lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))
1995-10-13 23:34:21 -04:00
;;; Miscellaneous
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; usleep(3): Try to sleep for USECS microseconds.
;;; sleep(3): Try to sleep for SECS seconds.
; De-released -- not POSIX and not on SGI systems.
; (define-foreign usleep (usleep (integer usecs)) integer)
(define (sleep secs) (sleep-until (+ secs (time))))
(define (sleep-until when)
(let* ((when (floor when)) ; Painful to do real->int in Scheme.
(when (if (exact? when) when (inexact->exact when)))
(h (hi8 when)) (l (lo24 when)))
(let lp ()
(or (%sleep-until h l) (lp)))))
(define-foreign %sleep-until (sleep_until (fixnum hi)
(fixnum lo))
desc)
1995-10-13 23:34:21 -04:00
(define-foreign %gethostname (scm_gethostname)
static-string)
(define system-name %gethostname)
(define-foreign errno-msg (errno_msg (integer i))
static-string)