diff --git a/scsh/flock.scm b/scsh/flock.scm index 77e4041..ebedd67 100644 --- a/scsh/flock.scm +++ b/scsh/flock.scm @@ -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 ;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scsh/network.scm b/scsh/network.scm index 5417632..99148f7 100644 --- a/scsh/network.scm +++ b/scsh/network.scm @@ -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 diff --git a/scsh/scsh-condition.scm b/scsh/scsh-condition.scm index 038ab84..87347e9 100644 --- a/scsh/scsh-condition.scm +++ b/scsh/scsh-condition.scm @@ -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) diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 315170f..770240c 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -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)))))))) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index 3968ae1..4913ca7 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -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 "." "/"))) diff --git a/scsh/time.scm b/scsh/time.scm index f0c7935..4a76bae 100644 --- a/scsh/time.scm +++ b/scsh/time.scm @@ -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) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scsh/tty.scm b/scsh/tty.scm index 2d7e559..f3008f3 100644 --- a/scsh/tty.scm +++ b/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") diff --git a/scsh/tty1.c b/scsh/tty1.c index 3ef5b33..50e27df 100644 --- a/scsh/tty1.c +++ b/scsh/tty1.c @@ -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.*