scsh-0.6/scsh/syscalls.scm

815 lines
25 KiB
Scheme

;;; POSIX system-call Scheme binding.
;;; Copyright (c) 1993 by Olin Shivers.
;;; Scheme48 implementation.
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
(foreign-init-name "syscalls")
(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 <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\"" JMG
"#include \"select1.h\""
"#include \"syscalls1.h\""
"#include \"userinfo1.h\""
""
"extern int errno;"
""
"#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))"
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
"#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)" ; Not a function.
"" "")
;;; Macro for converting syscalls that return error codes to ones that
;;; 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,
;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall),
;;; we try again.
;;;
;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
;;;
;;; (define (SYSCALL . ARGS)
;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
;;; (cond ((not err) (values . RET-VALS)) ; Win
;;; ((= err errno/intr) (SYSCALL . ARGS)) ; Retry
;;; (else (errno-error err SYSCALL . ARGS))))); Lose
(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 ...)
(cond ((not err) (values ret-val ...)) ; Win
((= err errno/intr)
(syscall arg ...)) ; Retry
(else (errno-error err syscall arg ...)))))) ; Lose
;;; This case handles rest args
((define-errno-syscall (syscall . args) syscall/errno
ret-val ...)
(define (syscall . args)
(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
;;; 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.
(define-syntax define-retrying-syscall
(syntax-rules ()
((define-retrying-syscall syscall syscall/eintr)
(define (syscall . args)
(let loop ()
(with-errno-handler
((errno packet)
((errno/intr) (display "eintr")(loop)))
(apply syscall/eintr args)))))))
;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; we can't algin env here, because exec-path/env calls
;; %%exec/errno directly F*&% *P
(define-stubless-foreign %%exec/errno (prog argv env) "scheme_exec")
(define (%%exec prog argv env)
(errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
(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))))
(%%exec prog argv env)))
(define-stubless-foreign exit/errno ; errno -- misnomer.
(status) "scsh_exit")
(define-stubless-foreign %exit/errno ; errno -- misnomer
(status) "scsh__exit")
(define (%exit . maybe-status)
(%exit/errno (:optional maybe-status 0))
(error "Yikes! %exit returned."))
(define-stubless-foreign %%fork () "scsh_fork")
;;; Posix waitpid(2) call.
(define-stubless-foreign %wait-pid/errno-list (pid options)
"wait_pid")
(define (%wait-pid/errno pid options)
(apply values (%wait-pid/errno-list pid options)))
;;; Miscellaneous process state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Working directory
(define-stubless-foreign %chdir (directory) "scsh_chdir")
;;; These calls change/reveal the process working directory
;;;
(define (process-chdir . maybe-dir)
(let ((dir (:optional maybe-dir (home-dir))))
(%chdir (ensure-file-name-is-nondirectory dir))))
;; TODO: we get an error if cwd does not exist on startup
(define-stubless-foreign process-cwd () "scheme_cwd")
;;; GID
(define-stubless-foreign user-gid () "scsh_getgid")
(define-stubless-foreign user-effective-gid () "scsh_getegid")
(define-stubless-foreign set-gid (gid) "scsh_setgid")
(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")
(define-stubless-foreign user-supplementary-gids () "get_groups")
;;; UID
(define-stubless-foreign user-uid () "scsh_getuid")
(define-stubless-foreign user-effective-uid () "scsh_geteuid")
(define-stubless-foreign set-uid (uid) "scsh_setuid")
(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")
(import-lambda-definition %user-login-name () "my_username")
(define (user-login-name)
(or (%user-login-name)
(error "Cannot get your name")))
;;; PID
(define-stubless-foreign pid () "scsh_getpid")
(define-stubless-foreign parent-pid () "scsh_getppid")
;;; Process groups and session ids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-stubless-foreign process-group () "scsh_getpgrp")
(define-stubless-foreign %set-process-group/eintr
(pid groupid) "setpgid")
(define-retrying-syscall %set-process-group %set-process-group/eintr)
(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)))
(define-stubless-foreign become-session-leader/eintr () "scsh_setsid")
(define-retrying-syscall become-session-leader become-session-leader/eintr)
;;; UMASK
(define-stubless-foreign set-process-umask (mask) "scsh_umask")
(define (process-umask)
(let ((m (set-process-umask 0)))
(set-process-umask m)
m))
;;; PROCESS TIMES
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
(define-stubless-foreign process-times/eintr-list () "process_times")
(define (process-times)
(define-retrying-syscall process-times/list process-times/eintr-list)
(apply values (process-times/list)))
(define-stubless-foreign cpu-ticks/sec () "cpu_clock_ticks_per_sec")
;;; 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-stubless-foreign %set-file-mode/eintr (path mode) "scsh_chmod")
(define-retrying-syscall %set-file-mode %set-file-mode/eintr)
(define-stubless-foreign %set-fdes-mode/eintr (path mode) "scsh_fchmod")
(define-retrying-syscall %set-fdes-mode %set-fdes-mode/eintr)
(define (set-file-mode thing mode)
(generic-file-op thing
(lambda (fd) (%set-fdes-mode fd mode))
(lambda (fname) (%set-file-mode fname mode))))
(define-stubless-foreign set-file-uid&gid/eintr (path uid gid) "scsh_chown")
(define-retrying-syscall set-file-uid&gid set-file-uid&gid/eintr)
(define-stubless-foreign set-fdes-uid&gid/eintr (fd uid gid) "scsh_fchown")
(define-retrying-syscall set-fdes-uid&gid set-fdes-uid&gid/eintr)
(define (set-file-owner thing uid)
(generic-file-op thing
(lambda (fd) (set-fdes-uid&gid fd uid -1))
(lambda (fname) (set-file-uid&gid fname uid -1))))
(define (set-file-group thing gid)
(generic-file-op thing
(lambda (fd) (set-fdes-uid&gid fd -1 gid))
(lambda (fname) (set-file-uid&gid fname -1 gid))))
;;; Uses real uid and gid, not effective. I don't use this anywhere.
(define-stubless-foreign %file-ruid-access-not? (path perms) "scsh_access")
;(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-stubless-foreign create-hard-link/eintr (original-name new-name)
"scsh_link")
(define-retrying-syscall %create-hard-link create-hard-link/eintr)
(define-stubless-foreign create-fifo/eintr (path mode) "scsh_mkfifo")
(define-retrying-syscall %create-fifo create-fifo/eintr)
(define-stubless-foreign create-directory/eintr (path mode) "scsh_mkdir")
(define-retrying-syscall %%create-directory create-directory/eintr)
(define (%create-directory path . maybe-mode)
(let ((mode (:optional maybe-mode #o777))
(fname (ensure-file-name-is-nondirectory path)))
(%%create-directory fname mode)))
(define-stubless-foreign read-symlink/eintr (path) "scsh_readlink")
(define-retrying-syscall read-symlink read-symlink/eintr)
(define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename")
(define-retrying-syscall %rename-file %rename-file/eintr)
(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir")
(define-retrying-syscall delete-directory delete-directory/eintr)
(define-stubless-foreign %utime/eintr (path ac m) "scm_utime")
(define-retrying-syscall %utime %utime/eintr)
(define-stubless-foreign %utime-now/eintr (path) "scm_utime_now")
(define-retrying-syscall %utime-now %utime-now/eintr)
;;; (SET-FILE-TIMES path [access-time mod-time])
(define (set-file-times 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 path access-time
mod-time ))
(%utime-now path)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STAT
(define-stubless-foreign stat-file/eintr (path data chase?) "scheme_stat")
(define-retrying-syscall stat-file stat-file/eintr)
(define-stubless-foreign stat-fdes/eintr (fd data) "scheme_fstat")
(define-retrying-syscall stat-fdes stat-fdes/eintr)
(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 fd/port/fname chase?)
(let ((ans-vec (make-vector 11))
(file-type (lambda (type-code)
(vector-ref '#(block-special char-special directory fifo
regular socket symlink)
type-code))))
(generic-file-op fd/port/fname
(lambda (fd)
(stat-fdes fd ans-vec))
(lambda (fname)
(stat-file fname ans-vec chase?)))
(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)
(vector-ref ans-vec 8)
(vector-ref ans-vec 9)
(vector-ref ans-vec 10))))
(define (file-info fd/port/fname . maybe-chase?)
(with-cwd-aligned
(let ((chase? (:optional maybe-chase? #t)))
(%file-info fd/port/fname chase?))))
(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-stubless-foreign create-symlink/eintr (old-name new-name) "scsh_symlink")
(define-retrying-syscall %create-symlink create-symlink/eintr)
;;; "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-stubless-foreign %truncate-file/eintr (path length) "scsh_truncate")
(define-retrying-syscall %truncate-file %truncate-file/eintr)
(define-stubless-foreign %truncate-fdes/eintr (path length) "scsh_ftruncate")
(define-retrying-syscall %truncate-fdes %truncate-fdes/eintr)
(define (truncate-file thing length)
(generic-file-op thing
(lambda (fd) (%truncate-fdes fd length))
(lambda (fname) (%truncate-file fname length))))
(define-stubless-foreign delete-file/eintr (path) "scsh_unlink")
(define-retrying-syscall delete-file delete-file/eintr)
(define-stubless-foreign %sync-file/eintr (fd) "scsh_fsync")
(define-retrying-syscall %sync-file %sync-file/eintr)
(define (sync-file fd/port)
(if (output-port? fd/port) (force-output fd/port))
(sleazy-call/fdes fd/port %sync-file))
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
(define-stubless-foreign sync-file-system () "scsh_sync")
;;; I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-stubless-foreign %close-fdes/eintr (fd) "scsh_close")
(define-retrying-syscall %close-fdes %close-fdes/eintr)
(define-stubless-foreign %dup/eintr (fd) "scsh_dup")
(define-retrying-syscall %dup %dup/eintr)
(define-stubless-foreign %dup2/eintr (fd-from fd-to) "scsh_dup2")
(define-retrying-syscall %dup2 %dup2/eintr)
(define-stubless-foreign %fd-seek/eintr (fd offset whence) "scsh_lseek")
(define-retrying-syscall %fd-seek %fd-seek/eintr)
(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))
(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
(%fd-seek fd offset whence)))
(define (tell fd/port)
(let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
(%fd-seek fd 0 seek/delta)))
(define-stubless-foreign %char-ready-fdes?/eintr (fd) "char_ready_fdes")
(define-retrying-syscall %char-ready-fdes? %char-ready-fdes?/eintr)
(define-stubless-foreign %open/eintr (path flags mode) "scsh_open")
(define-retrying-syscall %open %open/eintr)
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
(with-cwd-aligned
(with-umask-aligned
(%open path flags (:optional maybe-mode #o666)))))
(define-stubless-foreign pipe-fdes/eintr () "scheme_pipe")
(define-retrying-syscall pipe-fdes pipe-fdes/eintr)
(define (pipe)
(apply (lambda (r-fd w-fd)
(let ((r (fdes->inport r-fd))
(w (fdes->outport w-fd)))
(release-port-handle r)
(release-port-handle w)
(values r w)))
(pipe-fdes)))
(define-foreign %read-fdes-char
(read_fdes_char (fixnum 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)))
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (fixnum fd))
(to-scheme fixnum errno_or_false))
(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read and write
(define-foreign read-fdes-substring!/errno
(read_fdes_substring (string-desc buf)
(size_t start)
(size_t end)
(fixnum fd))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
(define-foreign write-fdes-substring/errno
(write_fdes_substring (string-desc buf)
(size_t start)
(size_t end)
(fixnum fd))
(multi-rep (to-scheme ssize_t errno_or_false)
ssize_t))
;;; Signals (rather incomplete)
;;; ---------------------------
(define-stubless-foreign signal-pid/eintr (pid signal) "scsh_kill")
(define-retrying-syscall signal-pid signal-pid/eintr)
(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))
(define (itimer sec)
((structure-ref scsh-events schedule-timer-interrupt!) (* sec 1000)))
;;; SunOS, not POSIX:
;;; (define-foreign signal-process-group/errno
;;; (killpg (integer proc-group) (integer signal))
;;; (to-scheme integer errno_or_false))
;;;
;;; (define-errno-syscall (signal-process-group proc-group signal)
;;; signal-process-group/errno)
(define (pause-until-interrupt)
(next-sigevent (most-recent-sigevent) full-interrupt-set))
;;; 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))))
(import-lambda-definition
%uid->user-info
(uid user-info-record)
"user_info_uid")
(import-lambda-definition
%name->user-info
(name user-info-record)
"user_info_name")
(define (uid->user-info uid)
(let ((empty-user-info (make-user-info #f uid #f #f #f)))
(if (%uid->user-info uid empty-user-info)
empty-user-info
(error "Cannot get user's information" uid->user-info uid))))
(define (name->user-info name)
(let ((empty-user-info (make-user-info name #f #f #f #f)))
(if (%name->user-info name empty-user-info)
empty-user-info
(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))))
(import-lambda-definition
%gid->group-info
(gid group-info-record)
"group_info_gid")
(import-lambda-definition
%name->group-info
(name group-info-record)
"group_info_name")
(define (gid->group-info gid)
(let ((empty-group-info (make-group-info #f gid #f)))
(if (%gid->group-info gid empty-group-info)
empty-group-info
(error "Cannot get group's information for gid" gid))))
(define (name->group-info name)
(let ((empty-group-info (make-group-info name #f #f)))
(if (%name->group-info name empty-group-info)
empty-group-info
(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-stubless-foreign %open-dir/eintr (dir-name) "open_dir")
(define-retrying-syscall %open-dir %open-dir/eintr)
(define (directory-files . args)
(with-cwd-aligned
(let-optionals args ((dir ".")
(dotfiles? #f))
(check-arg string? dir directory-files)
(let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
(files-sorted ((structure-ref sort sort-list!) files filename<=)))
(if dotfiles? files-sorted
(filter (lambda (f) (not (dotfile? f)))
files-sorted))))))
(define (dotfile? f)
(char=? (string-ref f 0) #\.))
(define (filename<= f1 f2)
(if (dotfile? f1)
(if (dotfile? f2)
(string<= f1 f2)
#t)
(if (dotfile? f2)
#f
(string<= f1 f2))))
;;; 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 pattern) ((C "char const ** ~a") cvec))
; static-string ; error message -- #f if no error.
; 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 (err 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))))))
;;; Environment manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (var . val) / "var=val" rep conversion:
(define (split-env-string var=val)
(let ((i (string-index var=val #\=)))
(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) "="
(let ((val (cdr var.val)))
(if (string? val) val
(string-join val ":")))))
alist)))
;;; ENV->ALIST
(define-stubless-foreign %load-env () "scm_envvec")
(define (environ-env->alist)
(let ((env-list.envvec (%load-env)))
(cons (env-list->alist (car env-list.envvec))
(cdr env-list.envvec))))
;;; ALIST->ENV
;;; (%create-env ((vector 'X) -> address))
(define-stubless-foreign %create-env (envvec) "create_env")
;;; assumes aligned env
(define (envvec-alist->env alist)
(%create-env (alist->env-vec alist)))
(define-stubless-foreign %align-env (envvec) "align_env")
(define-stubless-foreign %free-env (envvec) "free_envvec")
;;; Fd-ports
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-stubless-foreign %set-cloexec/eintr (fd val) "set_cloexec")
(define-retrying-syscall %set-cloexec %set-cloexec/eintr)
;;; Some of fcntl()
;;;;;;;;;;;;;;;;;;;
(define-stubless-foreign %fcntl-read/eintr (fd command) "fcntl_read")
(define-retrying-syscall %fcntl-read %fcntl-read/eintr)
(define-stubless-foreign %fcntl-write/eintr (fd command val) "fcntl_write")
(define-retrying-syscall %fcntl-write %fcntl-write/eintr)
;;; 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))))
(define (set-fdes-status fd/port flags)
(sleazy-call/fdes fd/port
(lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))
;;; 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))))
(let lp ()
(or (%sleep-until when) (lp)))))
;;; JMG: I don't know whether time_t or long is correct...
(define-foreign %sleep-until (sleep_until (time_t secs))
desc)
(define-stubless-foreign %gethostname/eintr () "scm_gethostname")
(define-retrying-syscall %gethostname %gethostname/eintr)
(define system-name %gethostname)
(define-stubless-foreign errno-msg (i) "errno_msg")
(define-stubless-foreign %crypt (key salt) "scm_crypt")
(define (crypt key salt)
(let* ((allowed-char-set (rx (| alpha digit "." "/")))
(salt-regexp (rx (: ,allowed-char-set ,allowed-char-set))))
(if (not (= (string-length salt) 2)) (error "salt must have length 2"))
(if (not (regexp-search? salt-regexp salt))
(error "illegal char in salt " salt))
(if (> (string-length key) 8) (error "key too long " (string-length key)))
(%crypt key salt)))