Use import-os-error-syscall to convert from os-error to syscall-error.
This commit is contained in:
mainzelm
parent
41b90aab2f
commit
ebd33706cc
|
|
@ -8,13 +8,8 @@
|
|||
;;; C syscall interface
|
||||
;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-stubless-foreign %set-lock/eintr (fd cmd type whence start len)
|
||||
"set_lock")
|
||||
(define-retrying-syscall %set-lock %set-lock/eintr)
|
||||
|
||||
(define-stubless-foreign %get-lock/eintr (fd cmd type whence start len)
|
||||
"get_lock")
|
||||
(define-retrying-syscall %get-lock %get-lock/eintr)
|
||||
(import-os-error-syscall %set-lock (fd cmd type whence start len) "set_lock")
|
||||
(import-os-error-syscall %get-lock (fd cmd type whence start len) "get_lock")
|
||||
|
||||
;;; The LOCK record type
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -180,9 +180,7 @@
|
|||
(dup->outport port))))
|
||||
(make-socket pf in out)))
|
||||
|
||||
(define-stubless-foreign %socket/eintr (pf type protocol) "scsh_socket")
|
||||
|
||||
(define-retrying-syscall %socket %socket/eintr)
|
||||
(import-os-error-syscall %socket (pf type protocol) "scsh_socket")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; close syscall
|
||||
|
|
@ -260,9 +258,8 @@
|
|||
(error "listen-socket: integer expected ~s" backlog))
|
||||
(else
|
||||
(%listen (socket->fdes sock) backlog))))
|
||||
|
||||
(define-stubless-foreign %listen/eintr (sockfd backlog) "scsh_listen")
|
||||
(define-retrying-syscall %listen %listen/eintr)
|
||||
|
||||
(import-os-error-syscall %listen (sockfd backlog) "scsh_listen")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; accept syscall
|
||||
|
|
@ -329,8 +326,7 @@
|
|||
(else
|
||||
(%shutdown (socket->fdes sock) how))))
|
||||
|
||||
(define-stubless-foreign %shutdown/eintr (sockfd how) "scsh_shutdown")
|
||||
(define-retrying-syscall %shutdown %shutdown/eintr)
|
||||
(import-os-error-syscall %shutdown (sockfd how) "scsh_shutdown")
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; socketpair syscall
|
||||
|
|
|
|||
|
|
@ -7,28 +7,20 @@
|
|||
|
||||
(define syscall-error? (condition-predicate 'syscall-error))
|
||||
|
||||
(define (errno-error errno syscall . stuff)
|
||||
(let ((msg (errno-msg errno)))
|
||||
(apply (structure-ref exceptions signal-exception)
|
||||
(enum op call-external-value) (enum exception os-error)
|
||||
syscall errno msg stuff)))
|
||||
(define (errno-error errno msg syscall . stuff)
|
||||
(apply signal 'syscall-error errno msg syscall stuff))
|
||||
|
||||
|
||||
(define (with-errno-handler* handler thunk)
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(if (and (exception? condition) (eq? (exception-reason condition)
|
||||
'os-error))
|
||||
(let ((stuff (exception-arguments condition)))
|
||||
(handler (cadr stuff) ; errno
|
||||
(list (caddr stuff) ;msg
|
||||
(car stuff) ;syscall
|
||||
(cdddr stuff) ;packet
|
||||
)))) ; (msg syscall . packet)
|
||||
(if (syscall-error? condition)
|
||||
(let ((stuff (condition-stuff condition)))
|
||||
(handler (car stuff) ; errno
|
||||
(cdr stuff)))) ; (msg syscall . packet)
|
||||
(more))
|
||||
thunk))
|
||||
|
||||
|
||||
|
||||
;;; (with-errno-handler
|
||||
;;; ((errno data) ; These are vars bound in this scope.
|
||||
;;; ((errno/exist) . body1)
|
||||
|
|
|
|||
|
|
@ -874,7 +874,7 @@
|
|||
(let ((argv (list->vector (cons prog (map stringify arglist)))))
|
||||
(for-each (lambda (dir)
|
||||
(let ((binary (string-append dir "/" prog)))
|
||||
(%%exec/errno binary argv env)))
|
||||
(%%exec binary argv env)))
|
||||
(fluid exec-path-list)))))
|
||||
|
||||
(error "No executable found." prog arglist))))))))
|
||||
|
|
|
|||
|
|
@ -5,71 +5,56 @@
|
|||
|
||||
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
|
||||
|
||||
;;; 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.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Import a C function and convert the exception os-error to a syscall-error
|
||||
;;;
|
||||
;;; 1.) Import a C function
|
||||
;;; 2.) Turn os-error into syscall-error
|
||||
;;; 3.) Retry on EINTR
|
||||
;;; The call/cc and the record is due to S48's broken exception system:
|
||||
;;; You can't throw an error within a handler
|
||||
;;;
|
||||
;;; (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
|
||||
(define-record err
|
||||
errno
|
||||
msg
|
||||
stuff)
|
||||
|
||||
(define-syntax import-os-error-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)))))))
|
||||
|
||||
((import-os-error-syscall syscall (%arg ...) c-name)
|
||||
(begin
|
||||
(import-lambda-definition syscall/eintr (%arg ...) c-name)
|
||||
(define (syscall %arg ...)
|
||||
(let ((arg %arg) ...)
|
||||
(let ((res
|
||||
(call-with-current-continuation
|
||||
(lambda (k)
|
||||
(let loop ()
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(if (and (exception? condition) (eq? (exception-reason condition)
|
||||
'os-error))
|
||||
(let ((stuff (exception-arguments condition)))
|
||||
(if (= (cadr stuff) errno/intr)
|
||||
(loop)
|
||||
(k (make-err (cadr stuff) ; errno
|
||||
(caddr stuff) ;msg
|
||||
(cdddr stuff) ;packet
|
||||
)))) ; (msg syscall . packet)
|
||||
(more)))
|
||||
(lambda ()
|
||||
(syscall/eintr %arg ...)))))))) ;BOGUS
|
||||
(if (err? res)
|
||||
(apply errno-error (err:errno res) (err:msg res) syscall
|
||||
(err:stuff res))
|
||||
res))))))))
|
||||
|
||||
;;; 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.
|
||||
(import-os-error-syscall %%exec (prog argv env) "scheme_exec")
|
||||
|
||||
(define (%exec prog arg-list env)
|
||||
(let ((argv (mapv! stringify (list->vector arg-list)))
|
||||
|
|
@ -78,10 +63,10 @@
|
|||
(%%exec prog argv env)))
|
||||
|
||||
|
||||
(define-stubless-foreign exit/errno ; errno -- misnomer.
|
||||
(import-os-error-syscall exit/errno ; errno -- misnomer.
|
||||
(status) "scsh_exit")
|
||||
|
||||
(define-stubless-foreign %exit/errno ; errno -- misnomer
|
||||
(import-os-error-syscall %exit/errno ; errno -- misnomer
|
||||
(status) "scsh__exit")
|
||||
|
||||
(define (%exit . maybe-status)
|
||||
|
|
@ -89,21 +74,20 @@
|
|||
(error "Yikes! %exit returned."))
|
||||
|
||||
|
||||
(define-stubless-foreign %%fork () "scsh_fork")
|
||||
(import-os-error-syscall %%fork () "scsh_fork")
|
||||
|
||||
;;; Posix waitpid(2) call.
|
||||
(define-stubless-foreign %wait-pid/errno-list (pid options)
|
||||
"wait_pid")
|
||||
(import-os-error-syscall %wait-pid/list (pid options) "wait_pid")
|
||||
|
||||
(define (%wait-pid/errno pid options)
|
||||
(apply values (%wait-pid/errno-list pid options)))
|
||||
(apply values (%wait-pid/list pid options)))
|
||||
|
||||
;;; Miscellaneous process state
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Working directory
|
||||
|
||||
(define-stubless-foreign %chdir (directory) "scsh_chdir")
|
||||
(import-os-error-syscall %chdir (directory) "scsh_chdir")
|
||||
|
||||
;;; These calls change/reveal the process working directory
|
||||
;;;
|
||||
|
|
@ -113,30 +97,30 @@
|
|||
(%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")
|
||||
(import-os-error-syscall process-cwd () "scheme_cwd")
|
||||
|
||||
;;; GID
|
||||
|
||||
(define-stubless-foreign user-gid () "scsh_getgid")
|
||||
(import-os-error-syscall user-gid () "scsh_getgid")
|
||||
|
||||
(define-stubless-foreign user-effective-gid () "scsh_getegid")
|
||||
(import-os-error-syscall user-effective-gid () "scsh_getegid")
|
||||
|
||||
(define-stubless-foreign set-gid (gid) "scsh_setgid")
|
||||
(import-os-error-syscall set-gid (gid) "scsh_setgid")
|
||||
|
||||
(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")
|
||||
(import-os-error-syscall set-effective-gid (gid) "scsh_setegid")
|
||||
|
||||
(define-stubless-foreign user-supplementary-gids () "get_groups")
|
||||
(import-os-error-syscall user-supplementary-gids () "get_groups")
|
||||
|
||||
;;; UID
|
||||
(define-stubless-foreign user-uid () "scsh_getuid")
|
||||
(import-os-error-syscall user-uid () "scsh_getuid")
|
||||
|
||||
(define-stubless-foreign user-effective-uid () "scsh_geteuid")
|
||||
(import-os-error-syscall user-effective-uid () "scsh_geteuid")
|
||||
|
||||
(define-stubless-foreign set-uid (uid) "scsh_setuid")
|
||||
(import-os-error-syscall set-uid (uid) "scsh_setuid")
|
||||
|
||||
(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")
|
||||
(import-os-error-syscall set-effective-uid (uid) "scsh_seteuid")
|
||||
|
||||
(import-lambda-definition %user-login-name () "my_username")
|
||||
(import-os-error-syscall %user-login-name () "my_username")
|
||||
|
||||
(define (user-login-name)
|
||||
(or (%user-login-name)
|
||||
|
|
@ -144,17 +128,14 @@
|
|||
|
||||
;;; PID
|
||||
|
||||
(define-stubless-foreign pid () "scsh_getpid")
|
||||
(define-stubless-foreign parent-pid () "scsh_getppid")
|
||||
(import-os-error-syscall pid () "scsh_getpid")
|
||||
(import-os-error-syscall parent-pid () "scsh_getppid")
|
||||
;;; Process groups and session ids
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-stubless-foreign process-group () "scsh_getpgrp")
|
||||
(import-os-error-syscall process-group () "scsh_getpgrp")
|
||||
|
||||
(define-stubless-foreign %set-process-group/eintr
|
||||
(pid groupid) "setpgid")
|
||||
|
||||
(define-retrying-syscall %set-process-group %set-process-group/eintr)
|
||||
(import-os-error-syscall %set-process-group (pid groupid) "setpgid")
|
||||
|
||||
(define (set-process-group arg1 . maybe-arg2)
|
||||
(receive (pid pgrp) (if (null? maybe-arg2)
|
||||
|
|
@ -163,12 +144,11 @@
|
|||
(%set-process-group pid pgrp)))
|
||||
|
||||
|
||||
(define-stubless-foreign become-session-leader/eintr () "scsh_setsid")
|
||||
(define-retrying-syscall become-session-leader become-session-leader/eintr)
|
||||
(import-os-error-syscall become-session-leader () "scsh_setsid")
|
||||
|
||||
;;; UMASK
|
||||
|
||||
(define-stubless-foreign set-process-umask (mask) "scsh_umask")
|
||||
(import-os-error-syscall set-process-umask (mask) "scsh_umask")
|
||||
|
||||
(define (process-umask)
|
||||
(let ((m (set-process-umask 0)))
|
||||
|
|
@ -181,13 +161,12 @@
|
|||
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
||||
|
||||
|
||||
(define-stubless-foreign process-times/eintr-list () "process_times")
|
||||
(import-os-error-syscall process-times/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")
|
||||
(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec")
|
||||
|
||||
;;; File system
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -200,11 +179,9 @@
|
|||
(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)
|
||||
(import-os-error-syscall %set-file-mode (path mode) "scsh_chmod")
|
||||
|
||||
(define-stubless-foreign %set-fdes-mode/eintr (path mode) "scsh_fchmod")
|
||||
(define-retrying-syscall %set-fdes-mode %set-fdes-mode/eintr)
|
||||
(import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod")
|
||||
|
||||
(define (set-file-mode thing mode)
|
||||
(generic-file-op thing
|
||||
|
|
@ -212,11 +189,9 @@
|
|||
(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)
|
||||
(import-os-error-syscall set-file-uid&gid (path uid gid) "scsh_chown")
|
||||
|
||||
(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)
|
||||
(import-os-error-syscall set-fdes-uid&gid (fd uid gid) "scsh_fchown")
|
||||
|
||||
(define (set-file-owner thing uid)
|
||||
(generic-file-op thing
|
||||
|
|
@ -231,7 +206,7 @@
|
|||
|
||||
;;; Uses real uid and gid, not effective. I don't use this anywhere.
|
||||
|
||||
(define-stubless-foreign %file-ruid-access-not? (path perms) "scsh_access")
|
||||
(import-os-error-syscall %file-ruid-access-not? (path perms) "scsh_access")
|
||||
|
||||
;(define (file-access? path perms)
|
||||
; (not (%file-access-not? path perms)))
|
||||
|
|
@ -246,35 +221,27 @@
|
|||
; (file-access? fname 4))
|
||||
|
||||
|
||||
(define-stubless-foreign create-hard-link/eintr (original-name new-name)
|
||||
(import-os-error-syscall %create-hard-link (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)
|
||||
(import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo")
|
||||
|
||||
(define-stubless-foreign create-directory/eintr (path mode) "scsh_mkdir")
|
||||
(define-retrying-syscall %%create-directory create-directory/eintr)
|
||||
(import-os-error-syscall %%create-directory (path mode) "scsh_mkdir")
|
||||
|
||||
(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)
|
||||
(import-os-error-syscall read-symlink (path) "scsh_readlink")
|
||||
|
||||
(define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename")
|
||||
(define-retrying-syscall %rename-file %rename-file/eintr)
|
||||
(import-os-error-syscall %rename-file (old-name new-name) "scsh_rename")
|
||||
|
||||
(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir")
|
||||
(define-retrying-syscall delete-directory delete-directory/eintr)
|
||||
(import-os-error-syscall delete-directory (path) "scsh_rmdir")
|
||||
|
||||
(define-stubless-foreign %utime/eintr (path ac m) "scm_utime")
|
||||
(define-retrying-syscall %utime %utime/eintr)
|
||||
(import-os-error-syscall %utime (path ac m) "scm_utime")
|
||||
|
||||
(define-stubless-foreign %utime-now/eintr (path) "scm_utime_now")
|
||||
(define-retrying-syscall %utime-now %utime-now/eintr)
|
||||
(import-os-error-syscall %utime-now (path) "scm_utime_now")
|
||||
|
||||
;;; (SET-FILE-TIMES path [access-time mod-time])
|
||||
|
||||
|
|
@ -292,11 +259,9 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; STAT
|
||||
|
||||
(define-stubless-foreign stat-file/eintr (path data chase?) "scheme_stat")
|
||||
(define-retrying-syscall stat-file stat-file/eintr)
|
||||
(import-os-error-syscall stat-file (path data chase?) "scheme_stat")
|
||||
|
||||
(define-stubless-foreign stat-fdes/eintr (fd data) "scheme_fstat")
|
||||
(define-retrying-syscall stat-fdes stat-fdes/eintr)
|
||||
(import-os-error-syscall stat-fdes (fd data) "scheme_fstat")
|
||||
|
||||
(define-record file-info
|
||||
type
|
||||
|
|
@ -351,28 +316,23 @@
|
|||
;;; "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)
|
||||
(import-os-error-syscall %create-symlink (old-name new-name) "scsh_symlink")
|
||||
|
||||
;;; "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)
|
||||
(import-os-error-syscall %truncate-file (path length) "scsh_truncate")
|
||||
|
||||
(define-stubless-foreign %truncate-fdes/eintr (path length) "scsh_ftruncate")
|
||||
(define-retrying-syscall %truncate-fdes %truncate-fdes/eintr)
|
||||
(import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate")
|
||||
|
||||
(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)
|
||||
(import-os-error-syscall delete-file (path) "scsh_unlink")
|
||||
|
||||
(define-stubless-foreign %sync-file/eintr (fd) "scsh_fsync")
|
||||
(define-retrying-syscall %sync-file %sync-file/eintr)
|
||||
(import-os-error-syscall %sync-file (fd) "scsh_fsync")
|
||||
|
||||
(define (sync-file fd/port)
|
||||
(if (output-port? fd/port) (force-output fd/port))
|
||||
|
|
@ -380,23 +340,18 @@
|
|||
|
||||
|
||||
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
|
||||
(define-stubless-foreign sync-file-system () "scsh_sync")
|
||||
(import-os-error-syscall sync-file-system () "scsh_sync")
|
||||
|
||||
;;; I/O
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-stubless-foreign %close-fdes/eintr (fd) "scsh_close")
|
||||
(define-retrying-syscall %close-fdes %close-fdes/eintr)
|
||||
(import-os-error-syscall %close-fdes (fd) "scsh_close")
|
||||
|
||||
(define-stubless-foreign %dup/eintr (fd) "scsh_dup")
|
||||
(define-retrying-syscall %dup %dup/eintr)
|
||||
(import-os-error-syscall %dup (fd) "scsh_dup")
|
||||
|
||||
(define-stubless-foreign %dup2/eintr (fd-from fd-to) "scsh_dup2")
|
||||
(define-retrying-syscall %dup2 %dup2/eintr)
|
||||
(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2")
|
||||
|
||||
|
||||
(define-stubless-foreign %fd-seek/eintr (fd offset whence) "scsh_lseek")
|
||||
(define-retrying-syscall %fd-seek %fd-seek/eintr)
|
||||
(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek")
|
||||
|
||||
|
||||
(define seek/set 0) ;Unix codes for "whence"
|
||||
|
|
@ -412,11 +367,9 @@
|
|||
(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)
|
||||
(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes")
|
||||
|
||||
(define-stubless-foreign %open/eintr (path flags mode) "scsh_open")
|
||||
(define-retrying-syscall %open %open/eintr)
|
||||
(import-os-error-syscall %open (path flags mode) "scsh_open")
|
||||
|
||||
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
||||
(with-cwd-aligned
|
||||
|
|
@ -424,8 +377,7 @@
|
|||
(%open path flags (:optional maybe-mode #o666)))))
|
||||
|
||||
|
||||
(define-stubless-foreign pipe-fdes/eintr () "scheme_pipe")
|
||||
(define-retrying-syscall pipe-fdes pipe-fdes/eintr)
|
||||
(import-os-error-syscall pipe-fdes () "scheme_pipe")
|
||||
|
||||
(define (pipe)
|
||||
(apply (lambda (r-fd w-fd)
|
||||
|
|
@ -439,8 +391,7 @@
|
|||
;;; Signals (rather incomplete)
|
||||
;;; ---------------------------
|
||||
|
||||
(define-stubless-foreign signal-pid/eintr (pid signal) "scsh_kill")
|
||||
(define-retrying-syscall signal-pid signal-pid/eintr)
|
||||
(import-os-error-syscall signal-pid (pid signal) "scsh_kill")
|
||||
|
||||
(define (signal-process proc signal)
|
||||
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
||||
|
|
@ -479,12 +430,12 @@
|
|||
(list "user-info" (user-info:name ui))))
|
||||
|
||||
|
||||
(import-lambda-definition
|
||||
(import-os-error-syscall
|
||||
%uid->user-info
|
||||
(uid user-info-record)
|
||||
"user_info_uid")
|
||||
|
||||
(import-lambda-definition
|
||||
(import-os-error-syscall
|
||||
%name->user-info
|
||||
(name user-info-record)
|
||||
"user_info_name")
|
||||
|
|
@ -529,12 +480,12 @@
|
|||
;; Make group-info records print like #{group-info wheel}.
|
||||
((disclose gi) (list "group-info" (group-info:name gi))))
|
||||
|
||||
(import-lambda-definition
|
||||
(import-os-error-syscall
|
||||
%gid->group-info
|
||||
(gid group-info-record)
|
||||
"group_info_gid")
|
||||
|
||||
(import-lambda-definition
|
||||
(import-os-error-syscall
|
||||
%name->group-info
|
||||
(name group-info-record)
|
||||
"group_info_name")
|
||||
|
|
@ -568,8 +519,7 @@
|
|||
;;; Directory stuff
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-stubless-foreign %open-dir/eintr (dir-name) "open_dir")
|
||||
(define-retrying-syscall %open-dir %open-dir/eintr)
|
||||
(import-os-error-syscall %open-dir (dir-name) "open_dir")
|
||||
|
||||
(define (directory-files . args)
|
||||
(with-cwd-aligned
|
||||
|
|
@ -649,7 +599,7 @@
|
|||
|
||||
;;; ENV->ALIST
|
||||
|
||||
(define-stubless-foreign %load-env () "scm_envvec")
|
||||
(import-os-error-syscall %load-env () "scm_envvec")
|
||||
|
||||
(define (environ-env->alist)
|
||||
(let ((env-list.envvec (%load-env)))
|
||||
|
|
@ -660,30 +610,27 @@
|
|||
;;; ALIST->ENV
|
||||
|
||||
;;; (%create-env ((vector 'X) -> address))
|
||||
(define-stubless-foreign %create-env (envvec) "create_env")
|
||||
(import-os-error-syscall %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")
|
||||
(import-os-error-syscall %align-env (envvec) "align_env")
|
||||
|
||||
(define-stubless-foreign %free-env (envvec) "free_envvec")
|
||||
(import-os-error-syscall %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)
|
||||
(import-os-error-syscall %set-cloexec (fd val) "set_cloexec")
|
||||
|
||||
;;; 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)
|
||||
(import-os-error-syscall %fcntl-read (fd command) "fcntl_read")
|
||||
(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write")
|
||||
|
||||
;;; 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
|
||||
|
|
@ -728,16 +675,15 @@
|
|||
(let lp ()
|
||||
(or (%sleep-until when) (lp)))))
|
||||
|
||||
(define-stubless-foreign %sleep-until (secs) "sleep_until")
|
||||
(import-os-error-syscall %sleep-until (secs) "sleep_until")
|
||||
|
||||
(define-stubless-foreign %gethostname/eintr () "scm_gethostname")
|
||||
(define-retrying-syscall %gethostname %gethostname/eintr)
|
||||
(import-os-error-syscall %gethostname () "scm_gethostname")
|
||||
|
||||
(define system-name %gethostname)
|
||||
|
||||
(define-stubless-foreign errno-msg (i) "errno_msg")
|
||||
(import-os-error-syscall errno-msg (i) "errno_msg")
|
||||
|
||||
(define-stubless-foreign %crypt (key salt) "scm_crypt")
|
||||
(import-os-error-syscall %crypt (key salt) "scm_crypt")
|
||||
|
||||
(define (crypt key salt)
|
||||
(let* ((allowed-char-set (rx (| alpha digit "." "/")))
|
||||
|
|
|
|||
|
|
@ -93,8 +93,7 @@
|
|||
; C fun is OS-dependent
|
||||
; TODO: all C files are identical, so move it to time1.c
|
||||
; returns (list secs ticks)
|
||||
(define-stubless-foreign %time+ticks/eintr () "time_plus_ticks")
|
||||
(define-retrying-syscall %time+ticks %time+ticks/eintr)
|
||||
(import-os-error-syscall %time+ticks () "time_plus_ticks")
|
||||
|
||||
(define (time+ticks)
|
||||
(apply values (%time+ticks)))
|
||||
|
|
@ -102,15 +101,13 @@
|
|||
(define (time+ticks->time secs ticks)
|
||||
(+ secs (/ ticks (ticks/sec))))
|
||||
|
||||
(define-stubless-foreign %time/eintr () "scheme_time")
|
||||
(define-retrying-syscall %time %time/eintr)
|
||||
(import-os-error-syscall %time () "scheme_time")
|
||||
|
||||
(define-stubless-foreign %date->time/eintr
|
||||
(import-os-error-syscall %date->time
|
||||
(sec min hour month-day month year
|
||||
tz-name ; #f or string
|
||||
tz-secs ; #f or int
|
||||
summer?) "date2time")
|
||||
(define-retrying-syscall %date->time %date->time/eintr)
|
||||
|
||||
(define (time . args) ; optional arg [date]
|
||||
(if (pair? args)
|
||||
|
|
@ -131,8 +128,7 @@
|
|||
|
||||
;;; Date
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-stubless-foreign %time->date/eintr (time zone) "time2date")
|
||||
(define-retrying-syscall %time->date %time->date/eintr)
|
||||
(import-os-error-syscall %time->date (time zone) "time2date")
|
||||
|
||||
(define (date . args) ; Optional args [time zone]
|
||||
(let ((time (if (pair? args)
|
||||
|
|
@ -176,12 +172,10 @@
|
|||
(cond ((not result) (error "~ without argument in format-date" fmt))
|
||||
(else result))))
|
||||
|
||||
(define-stubless-foreign %format-date/eintr
|
||||
(import-os-error-syscall %format-date
|
||||
(fmt seconds minute hour month-day month year tz-name summer? week-day
|
||||
year-day)
|
||||
"format_date")
|
||||
(define-retrying-syscall %format-date %format-date/eintr)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
36
scsh/tty.scm
36
scsh/tty.scm
|
|
@ -122,9 +122,8 @@
|
|||
(char->ascii (string-ref control-chars ttychar/time))))
|
||||
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars))))))
|
||||
|
||||
(define-stubless-foreign %tty-info/eintr (fdes control-chars)
|
||||
(import-os-error-syscall %tty-info (fdes control-chars)
|
||||
"scheme_tcgetattr")
|
||||
(define-retrying-syscall %tty-info %tty-info/eintr)
|
||||
|
||||
|
||||
;;; JMG: I don't know what the purpose of this code is...
|
||||
|
|
@ -182,11 +181,10 @@
|
|||
(tty-info:time info))))))
|
||||
|
||||
|
||||
(define-stubless-foreign %set-tty-info/eintr
|
||||
(import-os-error-syscall %set-tty-info
|
||||
(fdes option control-chars iflag oflag cflag lflag ispeed-code ospeed-code
|
||||
min time)
|
||||
"scheme_tcsetattr")
|
||||
(define-retrying-syscall %set-tty-info %set-tty-info/eintr)
|
||||
|
||||
;;; Exported procs
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -209,9 +207,8 @@
|
|||
(lambda (fdes)
|
||||
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
|
||||
|
||||
(define-stubless-foreign %send-tty-break-fdes/eintr (fdes duration)
|
||||
(import-os-error-syscall %send-tty-break-fdes (fdes duration)
|
||||
"sch_tcsendbreak")
|
||||
(define-retrying-syscall %send-tty-break-fdes %send-tty-break-fdes/eintr)
|
||||
|
||||
;;; Drain the main vein.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -223,8 +220,7 @@
|
|||
(sleazy-call/fdes fdport %tcdrain))
|
||||
(else (error "Illegal argument to DRAIN-TTY" fdport))))
|
||||
|
||||
(define-stubless-foreign %tcdrain/eintr (fdes) "sch_tcdrain")
|
||||
(define-retrying-syscall %tcdrain %tcdrain/eintr)
|
||||
(import-os-error-syscall %tcdrain (fdes) "sch_tcdrain")
|
||||
|
||||
;;; Flushing the device queues. (tcflush)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -239,8 +235,7 @@
|
|||
(define flush-tty/output (make-tty-flusher %flush-tty/output))
|
||||
(define flush-tty/both (make-tty-flusher %flush-tty/both))
|
||||
|
||||
(define-stubless-foreign %tcflush/eintr (fdes flag) "sch_tcflush")
|
||||
(define-retrying-syscall %tcflush %tcflush/eintr)
|
||||
(import-os-error-syscall %tcflush (fdes flag) "sch_tcflush")
|
||||
|
||||
;;; Stopping and starting I/O (tcflow)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -256,8 +251,7 @@
|
|||
(define start-tty-input (make-flow-controller %tcflow/start-in))
|
||||
(define stop-tty-input (make-flow-controller %tcflow/stop-in))
|
||||
|
||||
(define-stubless-foreign %tcflow/eintr (fdes action) "sch_tcflow")
|
||||
(define-retrying-syscall %tcflow %tcflow/eintr)
|
||||
(import-os-error-syscall %tcflow (fdes action) "sch_tcflow")
|
||||
|
||||
;;; Baud rate translation
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -287,14 +281,12 @@
|
|||
proc-group
|
||||
(proc:pid proc-group))))))
|
||||
|
||||
(define-stubless-foreign %set-tty-process-group/eintr (fdes pid) "sch_tcsetpgrp")
|
||||
(define-retrying-syscall %set-tty-process-group %set-tty-process-group/eintr)
|
||||
(import-os-error-syscall %set-tty-process-group (fdes pid) "sch_tcsetpgrp")
|
||||
|
||||
(define (tty-process-group port/fd)
|
||||
(sleazy-call/fdes port/fd %tty-process-group))
|
||||
|
||||
(define-stubless-foreign %tty-process-group/eintr (fdes) "sch_tcgetpgrp")
|
||||
(define-retrying-syscall %tty-process-group %tty-process-group/eintr)
|
||||
(import-os-error-syscall %tty-process-group (fdes) "sch_tcgetpgrp")
|
||||
|
||||
;;; (open-control-tty fname [flags])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -314,8 +306,7 @@
|
|||
make-output-fdport)
|
||||
fd 1))))
|
||||
|
||||
(define-stubless-foreign %open-control-tty/eintr (ttyname flags) "open_ctty")
|
||||
(define-retrying-syscall %open-control-tty %open-control-tty/eintr)
|
||||
(import-os-error-syscall %open-control-tty (ttyname flags) "open_ctty")
|
||||
|
||||
;;; Random bits & pieces: isatty ttyname ctermid
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -323,14 +314,11 @@
|
|||
;;; (tty-file-name fd/port) -> string
|
||||
;;; (control-tty-file-name) -> string
|
||||
|
||||
(define-stubless-foreign %tty?/eintr (fd) "sch_isatty")
|
||||
(define-retrying-syscall %tty? %tty?/eintr)
|
||||
(import-os-error-syscall %tty? (fd) "sch_isatty")
|
||||
(define (tty? fd/port) (sleazy-call/fdes fd/port %tty?))
|
||||
|
||||
(define-stubless-foreign %tty-file-name/eintr (fd) "sch_ttyname")
|
||||
(define-retrying-syscall %tty-file-name %tty-file-name/eintr)
|
||||
(import-os-error-syscall %tty-file-name (fd) "sch_ttyname")
|
||||
|
||||
(define (tty-file-name fd/port) (sleazy-call/fdes fd/port %tty-file-name))
|
||||
|
||||
(define-stubless-foreign %ctermid/eintr () "scm_ctermid")
|
||||
(define-retrying-syscall control-tty-file-name %ctermid/eintr)
|
||||
(import-os-error-syscall control-tty-file-name () "scm_ctermid")
|
||||
|
|
|
|||
|
|
@ -182,7 +182,7 @@ s48_value open_ctty(s48_value sch_ttyname, s48_value sch_flags)
|
|||
{
|
||||
int fd = open(s48_extract_string (sch_ttyname),
|
||||
s48_extract_integer (sch_flags));
|
||||
|
||||
|
||||
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
|
||||
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS.
|
||||
** This code stolen from Steven's *Advanced Prog. in the Unix Env.*
|
||||
|
|
|
|||
Loading…
Reference in New Issue