Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv8319/scsh
Modified Files:
flock.scm network.scm scsh-condition.scm scsh.scm syscalls.scm
time.scm tty.scm tty1.c
Log Message:
Use import-os-error-syscall to convert from os-error to syscall-error.
Index: flock.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/flock.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** flock.scm 2001/08/08 12:52:37 1.4
--- flock.scm 2001/09/12 14:08:24 1.5
***************
*** 9,19 ****
;;;;;;;;;;;;;;;;;;;;;;;
! (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)
;;; The LOCK record type
--- 9,14 ----
;;;;;;;;;;;;;;;;;;;;;;;
! (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
Index: network.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/network.scm,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -r1.21 -r1.22
*** network.scm 2001/08/08 12:53:24 1.21
--- network.scm 2001/09/12 14:08:24 1.22
***************
*** 181,188 ****
(make-socket pf in out)))
! (define-stubless-foreign %socket/eintr (pf type protocol) "scsh_socket")
- (define-retrying-syscall %socket %socket/eintr)
-
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; close syscall
--- 181,186 ----
(make-socket pf in out)))
! (import-os-error-syscall %socket (pf type protocol) "scsh_socket")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; close syscall
***************
*** 261,267 ****
(else
(%listen (socket->fdes sock) backlog))))
!
! (define-stubless-foreign %listen/eintr (sockfd backlog) "scsh_listen")
! (define-retrying-syscall %listen %listen/eintr)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
--- 259,264 ----
(else
(%listen (socket->fdes sock) backlog))))
!
! (import-os-error-syscall %listen (sockfd backlog) "scsh_listen")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
***************
*** 330,335 ****
(%shutdown (socket->fdes sock) how))))
! (define-stubless-foreign %shutdown/eintr (sockfd how) "scsh_shutdown")
! (define-retrying-syscall %shutdown %shutdown/eintr)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
--- 327,331 ----
(%shutdown (socket->fdes sock) how))))
! (import-os-error-syscall %shutdown (sockfd how) "scsh_shutdown")
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Index: scsh-condition.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh-condition.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** scsh-condition.scm 2000/07/17 13:15:45 1.2
--- scsh-condition.scm 2001/09/12 14:08:24 1.3
***************
*** 8,32 ****
(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 (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)
(more))
thunk))
-
-
;;; (with-errno-handler
--- 8,24 ----
(define syscall-error? (condition-predicate 'syscall-error))
! (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 (syscall-error? condition)
! (let ((stuff (condition-stuff condition)))
! (handler (car stuff) ; errno
! (cdr stuff)))) ; (msg syscall . packet)
(more))
thunk))
;;; (with-errno-handler
Index: scsh.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh.scm,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -r1.19 -r1.20
*** scsh.scm 2001/08/06 09:24:24 1.19
--- scsh.scm 2001/09/12 14:08:24 1.20
***************
*** 875,879 ****
(for-each (lambda (dir)
(let ((binary (string-append dir "/" prog)))
! (%%exec/errno binary argv env)))
(fluid exec-path-list)))))
--- 875,879 ----
(for-each (lambda (dir)
(let ((binary (string-append dir "/" prog)))
! (%%exec binary argv env)))
(fluid exec-path-list)))))
Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.27
retrieving revision 1.28
diff -C2 -r1.27 -r1.28
*** syscalls.scm 2001/09/07 16:05:31 1.27
--- syscalls.scm 2001/09/12 14:08:24 1.28
***************
*** 6,74 ****
;;; 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.
;;;
! ;;; (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)
--- 6,59 ----
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;;; 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-record err
+ errno
+ msg
+ stuff)
! (define-syntax import-os-error-syscall
(syntax-rules ()
! ((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
! (import-os-error-syscall %%exec (prog argv env) "scheme_exec")
(define (%exec prog arg-list env)
***************
*** 79,86 ****
! (define-stubless-foreign exit/errno ; errno -- misnomer.
(status) "scsh_exit")
! (define-stubless-foreign %exit/errno ; errno -- misnomer
(status) "scsh__exit")
--- 64,71 ----
! (import-os-error-syscall exit/errno ; errno -- misnomer.
(status) "scsh_exit")
! (import-os-error-syscall %exit/errno ; errno -- misnomer
(status) "scsh__exit")
***************
*** 90,101 ****
! (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
--- 75,85 ----
! (import-os-error-syscall %%fork () "scsh_fork")
;;; Posix waitpid(2) call.
! (import-os-error-syscall %wait-pid/list (pid options) "wait_pid")
(define (%wait-pid/errno pid options)
! (apply values (%wait-pid/list pid options)))
;;; Miscellaneous process state
***************
*** 104,108 ****
;;; Working directory
! (define-stubless-foreign %chdir (directory) "scsh_chdir")
;;; These calls change/reveal the process working directory
--- 88,92 ----
;;; Working directory
! (import-os-error-syscall %chdir (directory) "scsh_chdir")
;;; These calls change/reveal the process working directory
***************
*** 114,141 ****
;; 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)
--- 98,125 ----
;; TODO: we get an error if cwd does not exist on startup
! (import-os-error-syscall process-cwd () "scheme_cwd")
;;; GID
! (import-os-error-syscall user-gid () "scsh_getgid")
! (import-os-error-syscall user-effective-gid () "scsh_getegid")
! (import-os-error-syscall set-gid (gid) "scsh_setgid")
! (import-os-error-syscall set-effective-gid (gid) "scsh_setegid")
! (import-os-error-syscall user-supplementary-gids () "get_groups")
;;; UID
! (import-os-error-syscall user-uid () "scsh_getuid")
! (import-os-error-syscall user-effective-uid () "scsh_geteuid")
! (import-os-error-syscall set-uid (uid) "scsh_setuid")
! (import-os-error-syscall set-effective-uid (uid) "scsh_seteuid")
! (import-os-error-syscall %user-login-name () "my_username")
(define (user-login-name)
***************
*** 145,160 ****
;;; 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)
--- 129,141 ----
;;; PID
! (import-os-error-syscall pid () "scsh_getpid")
! (import-os-error-syscall parent-pid () "scsh_getppid")
;;; Process groups and session ids
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (import-os-error-syscall process-group () "scsh_getpgrp")
! (import-os-error-syscall %set-process-group (pid groupid) "setpgid")
(define (set-process-group arg1 . maybe-arg2)
(receive (pid pgrp) (if (null? maybe-arg2)
***************
*** 164,173 ****
! (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)
--- 145,153 ----
! (import-os-error-syscall become-session-leader () "scsh_setsid")
;;; UMASK
! (import-os-error-syscall set-process-umask (mask) "scsh_umask")
(define (process-umask)
***************
*** 182,192 ****
! (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
--- 162,171 ----
! (import-os-error-syscall process-times/list () "process_times")
(define (process-times)
(apply values (process-times/list)))
! (import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec")
;;; File system
***************
*** 201,209 ****
! (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)
--- 180,186 ----
! (import-os-error-syscall %set-file-mode (path mode) "scsh_chmod")
! (import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod")
(define (set-file-mode thing mode)
***************
*** 213,221 ****
! (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)
--- 190,196 ----
! (import-os-error-syscall set-file-uid&gid (path uid gid) "scsh_chown")
! (import-os-error-syscall set-fdes-uid&gid (fd uid gid) "scsh_fchown")
(define (set-file-owner thing uid)
***************
*** 232,236 ****
;;; 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)
--- 207,211 ----
;;; Uses real uid and gid, not effective. I don't use this anywhere.
! (import-os-error-syscall %file-ruid-access-not? (path perms) "scsh_access")
;(define (file-access? path perms)
***************
*** 247,259 ****
! (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)
--- 222,231 ----
! (import-os-error-syscall %create-hard-link (original-name new-name)
"scsh_link")
! (import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo")
! (import-os-error-syscall %%create-directory (path mode) "scsh_mkdir")
(define (%create-directory path . maybe-mode)
***************
*** 262,279 ****
(%%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])
--- 234,246 ----
(%%create-directory fname mode)))
! (import-os-error-syscall read-symlink (path) "scsh_readlink")
! (import-os-error-syscall %rename-file (old-name new-name) "scsh_rename")
! (import-os-error-syscall delete-directory (path) "scsh_rmdir")
! (import-os-error-syscall %utime (path ac m) "scm_utime")
! (import-os-error-syscall %utime-now (path) "scm_utime_now")
;;; (SET-FILE-TIMES path [access-time mod-time])
***************
*** 293,301 ****
;;; 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
--- 260,266 ----
;;; STAT
! (import-os-error-syscall stat-file (path data chase?) "scheme_stat")
! (import-os-error-syscall stat-fdes (fd data) "scheme_fstat")
(define-record file-info
***************
*** 352,366 ****
;;; 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)
--- 317,328 ----
;;; the OLD-NAME arg is "const". It *should* be const.
! (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.
! (import-os-error-syscall %truncate-file (path length) "scsh_truncate")
! (import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate")
(define (truncate-file thing length)
***************
*** 369,377 ****
(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)
--- 331,337 ----
(lambda (fname) (%truncate-file fname length))))
! (import-os-error-syscall delete-file (path) "scsh_unlink")
! (import-os-error-syscall %sync-file (fd) "scsh_fsync")
(define (sync-file fd/port)
***************
*** 381,401 ****
;;; 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)
--- 341,356 ----
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
! (import-os-error-syscall sync-file-system () "scsh_sync")
;;; I/O
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (import-os-error-syscall %close-fdes (fd) "scsh_close")
! (import-os-error-syscall %dup (fd) "scsh_dup")
+ (import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2")
! (import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek")
***************
*** 413,421 ****
(%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
--- 368,374 ----
(%fd-seek fd 0 seek/delta)))
! (import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes")
! (import-os-error-syscall %open (path flags mode) "scsh_open")
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
***************
*** 425,430 ****
! (define-stubless-foreign pipe-fdes/eintr () "scheme_pipe")
! (define-retrying-syscall pipe-fdes pipe-fdes/eintr)
(define (pipe)
--- 378,382 ----
! (import-os-error-syscall pipe-fdes () "scheme_pipe")
(define (pipe)
***************
*** 440,445 ****
;;; ---------------------------
! (define-stubless-foreign signal-pid/eintr (pid signal) "scsh_kill")
! (define-retrying-syscall signal-pid signal-pid/eintr)
(define (signal-process proc signal)
--- 392,396 ----
;;; ---------------------------
! (import-os-error-syscall signal-pid (pid signal) "scsh_kill")
(define (signal-process proc signal)
***************
*** 480,489 ****
! (import-lambda-definition
%uid->user-info
(uid user-info-record)
"user_info_uid")
! (import-lambda-definition
%name->user-info
(name user-info-record)
--- 431,440 ----
! (import-os-error-syscall
%uid->user-info
(uid user-info-record)
"user_info_uid")
! (import-os-error-syscall
%name->user-info
(name user-info-record)
***************
*** 530,539 ****
((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)
--- 481,490 ----
((disclose gi) (list "group-info" (group-info:name gi))))
! (import-os-error-syscall
%gid->group-info
(gid group-info-record)
"group_info_gid")
! (import-os-error-syscall
%name->group-info
(name group-info-record)
***************
*** 569,574 ****
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (define-stubless-foreign %open-dir/eintr (dir-name) "open_dir")
! (define-retrying-syscall %open-dir %open-dir/eintr)
(define (directory-files . args)
--- 520,524 ----
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (import-os-error-syscall %open-dir (dir-name) "open_dir")
(define (directory-files . args)
***************
*** 650,654 ****
;;; ENV->ALIST
! (define-stubless-foreign %load-env () "scm_envvec")
(define (environ-env->alist)
--- 600,604 ----
;;; ENV->ALIST
! (import-os-error-syscall %load-env () "scm_envvec")
(define (environ-env->alist)
***************
*** 661,665 ****
;;; (%create-env ((vector 'X) -> address))
! (define-stubless-foreign %create-env (envvec) "create_env")
;;; assumes aligned env
--- 611,615 ----
;;; (%create-env ((vector 'X) -> address))
! (import-os-error-syscall %create-env (envvec) "create_env")
;;; assumes aligned env
***************
*** 667,673 ****
(%create-env (alist->env-vec alist)))
! (define-stubless-foreign %align-env (envvec) "align_env")
! (define-stubless-foreign %free-env (envvec) "free_envvec")
--- 617,623 ----
(%create-env (alist->env-vec alist)))
! (import-os-error-syscall %align-env (envvec) "align_env")
! (import-os-error-syscall %free-env (envvec) "free_envvec")
***************
*** 675,688 ****
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (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
--- 625,635 ----
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (import-os-error-syscall %set-cloexec (fd val) "set_cloexec")
;;; Some of fcntl()
;;;;;;;;;;;;;;;;;;;
! (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
***************
*** 729,742 ****
(or (%sleep-until when) (lp)))))
! (define-stubless-foreign %sleep-until (secs) "sleep_until")
! (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)
--- 676,688 ----
(or (%sleep-until when) (lp)))))
! (import-os-error-syscall %sleep-until (secs) "sleep_until")
! (import-os-error-syscall %gethostname () "scm_gethostname")
(define system-name %gethostname)
! (import-os-error-syscall errno-msg (i) "errno_msg")
! (import-os-error-syscall %crypt (key salt) "scm_crypt")
(define (crypt key salt)
Index: time.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/time.scm,v
retrieving revision 1.8
retrieving revision 1.9
diff -C2 -r1.8 -r1.9
*** time.scm 2001/09/07 12:36:30 1.8
--- time.scm 2001/09/12 14:08:24 1.9
***************
*** 94,99 ****
; 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)
(define (time+ticks)
--- 94,98 ----
; TODO: all C files are identical, so move it to time1.c
; returns (list secs ticks)
! (import-os-error-syscall %time+ticks () "time_plus_ticks")
(define (time+ticks)
***************
*** 103,115 ****
(+ secs (/ ticks (ticks/sec))))
! (define-stubless-foreign %time/eintr () "scheme_time")
! (define-retrying-syscall %time %time/eintr)
! (define-stubless-foreign %date->time/eintr
(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]
--- 102,112 ----
(+ secs (/ ticks (ticks/sec))))
! (import-os-error-syscall %time () "scheme_time")
! (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 (time . args) ; optional arg [date]
***************
*** 132,137 ****
;;; Date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (define-stubless-foreign %time->date/eintr (time zone) "time2date")
! (define-retrying-syscall %time->date %time->date/eintr)
(define (date . args) ; Optional args [time zone]
--- 129,133 ----
;;; Date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! (import-os-error-syscall %time->date (time zone) "time2date")
(define (date . args) ; Optional args [time zone]
***************
*** 177,186 ****
(else result))))
! (define-stubless-foreign %format-date/eintr
(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)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 173,180 ----
(else result))))
! (import-os-error-syscall %format-date
(fmt seconds minute hour month-day month year tz-name summer? week-day
year-day)
"format_date")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Index: tty.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/tty.scm,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -r1.6 -r1.7
*** tty.scm 2001/09/07 15:17:54 1.6
--- tty.scm 2001/09/12 14:08:24 1.7
***************
*** 123,129 ****
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars))))))
! (define-stubless-foreign %tty-info/eintr (fdes control-chars)
"scheme_tcgetattr")
- (define-retrying-syscall %tty-info %tty-info/eintr)
--- 123,128 ----
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars))))))
! (import-os-error-syscall %tty-info (fdes control-chars)
"scheme_tcgetattr")
***************
*** 183,191 ****
! (define-stubless-foreign %set-tty-info/eintr
(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
--- 182,189 ----
! (import-os-error-syscall %set-tty-info
(fdes option control-chars iflag oflag cflag lflag ispeed-code ospeed-code
min time)
"scheme_tcsetattr")
;;; Exported procs
***************
*** 210,216 ****
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
! (define-stubless-foreign %send-tty-break-fdes/eintr (fdes duration)
"sch_tcsendbreak")
- (define-retrying-syscall %send-tty-break-fdes %send-tty-break-fdes/eintr)
;;; Drain the main vein.
--- 208,213 ----
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
! (import-os-error-syscall %send-tty-break-fdes (fdes duration)
"sch_tcsendbreak")
;;; Drain the main vein.
***************
*** 224,229 ****
(else (error "Illegal argument to DRAIN-TTY" fdport))))
! (define-stubless-foreign %tcdrain/eintr (fdes) "sch_tcdrain")
! (define-retrying-syscall %tcdrain %tcdrain/eintr)
;;; Flushing the device queues. (tcflush)
--- 221,225 ----
(else (error "Illegal argument to DRAIN-TTY" fdport))))
! (import-os-error-syscall %tcdrain (fdes) "sch_tcdrain")
;;; Flushing the device queues. (tcflush)
***************
*** 240,245 ****
(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)
;;; Stopping and starting I/O (tcflow)
--- 236,240 ----
(define flush-tty/both (make-tty-flusher %flush-tty/both))
! (import-os-error-syscall %tcflush (fdes flag) "sch_tcflush")
;;; Stopping and starting I/O (tcflow)
***************
*** 257,262 ****
(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)
;;; Baud rate translation
--- 252,256 ----
(define stop-tty-input (make-flow-controller %tcflow/stop-in))
! (import-os-error-syscall %tcflow (fdes action) "sch_tcflow")
;;; Baud rate translation
***************
*** 288,299 ****
(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)
(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)
;;; (open-control-tty fname [flags])
--- 282,291 ----
(proc:pid proc-group))))))
! (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))
! (import-os-error-syscall %tty-process-group (fdes) "sch_tcgetpgrp")
;;; (open-control-tty fname [flags])
***************
*** 315,320 ****
fd 1))))
! (define-stubless-foreign %open-control-tty/eintr (ttyname flags) "open_ctty")
! (define-retrying-syscall %open-control-tty %open-control-tty/eintr)
;;; Random bits & pieces: isatty ttyname ctermid
--- 307,311 ----
fd 1))))
! (import-os-error-syscall %open-control-tty (ttyname flags) "open_ctty")
;;; Random bits & pieces: isatty ttyname ctermid
***************
*** 324,336 ****
;;; (control-tty-file-name) -> string
! (define-stubless-foreign %tty?/eintr (fd) "sch_isatty")
! (define-retrying-syscall %tty? %tty?/eintr)
(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)
(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)
--- 315,324 ----
;;; (control-tty-file-name) -> string
! (import-os-error-syscall %tty? (fd) "sch_isatty")
(define (tty? fd/port) (sleazy-call/fdes fd/port %tty?))
! (import-os-error-syscall %tty-file-name (fd) "sch_ttyname")
(define (tty-file-name fd/port) (sleazy-call/fdes fd/port %tty-file-name))
! (import-os-error-syscall control-tty-file-name () "scm_ctermid")
Index: tty1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/tty1.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** tty1.c 2001/09/07 15:17:54 1.5
--- tty1.c 2001/09/12 14:08:24 1.6
***************
*** 183,187 ****
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.
--- 183,187 ----
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.
|