Hacked I/O system so that ports set/clear their
fd's CLOEXEC bit when they become unrevealed/revealed.
This commit is contained in:
parent
aed6c163b8
commit
70a1342cef
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o100) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; AIX version by Chipsy Sperber
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -2,12 +2,7 @@
|
|||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; AIX version by Chipsy Sperber
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
@ -26,19 +21,28 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-record-lock 5) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 6) ; F_SETLK
|
||||
(define fcntl/set-record-lock 7) ; F_SETLKW
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ' F_UNLCK
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
;;; AIX version by Chipsy Sperber
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here.
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
|
||||
;;; These are the correct values for a Harris NightHawk running CX/UX
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
(perm 1)
|
||||
(noent 2)
|
||||
(srch 3)
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here.
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
|
@ -25,7 +25,7 @@
|
|||
target)
|
||||
|
||||
((fdport? fd/port)
|
||||
(call/fdes fd/port doit)
|
||||
(sleazy-call/fdes fd/port doit)
|
||||
(if (%move-fdport target fd/port 1)
|
||||
(error "fdport shift failed."))
|
||||
fd/port)
|
||||
|
@ -37,7 +37,7 @@
|
|||
(check-arg fd/port? fd/port input-source?)
|
||||
(or (input-port? fd/port)
|
||||
(and (integer? fd/port)
|
||||
(let ((access (bitwise-and open/access-mask (i/o-flags fd/port))))
|
||||
(let ((access (bitwise-and open/access-mask (fdes-status fd/port))))
|
||||
(or (= access open/read)
|
||||
(= access open/read+write))))))
|
||||
|
||||
|
@ -45,7 +45,7 @@
|
|||
(check-arg fd/port? fd/port output-source?)
|
||||
(or (output-port? fd/port)
|
||||
(and (integer? fd/port)
|
||||
(let ((access (bitwise-and open/access-mask (i/o-flags fd/port))))
|
||||
(let ((access (bitwise-and open/access-mask (fdes-status fd/port))))
|
||||
(or (= access open/write)
|
||||
(= access open/read+write))))))
|
||||
|
||||
|
@ -61,24 +61,22 @@
|
|||
fd/port maybe-target))
|
||||
|
||||
(define (dup->fdes fd/port . maybe-target)
|
||||
(check-arg fd/port? fd/port dup)
|
||||
(check-arg fd/port? fd/port dup->fdes)
|
||||
(if (pair? maybe-target)
|
||||
(let ((target (car maybe-target)))
|
||||
(close-fdes target) ; Thus evicting any port there.
|
||||
(call/fdes fd/port (lambda (fd) (%dup2 fd target))))
|
||||
(call/fdes fd/port %dup)))
|
||||
(sleazy-call/fdes fd/port (lambda (fd) (%dup2 fd target))))
|
||||
(sleazy-call/fdes fd/port %dup)))
|
||||
|
||||
(define (dup->inport fd/port . maybe-target)
|
||||
(apply really-dup->port fdes->inport fd/port maybe-target))
|
||||
(apply really-dup->port make-input-fdport fd/port maybe-target))
|
||||
|
||||
(define (dup->outport fd/port . maybe-target)
|
||||
(apply really-dup->port fdes->outport fd/port maybe-target))
|
||||
(apply really-dup->port make-output-fdport fd/port maybe-target))
|
||||
|
||||
(define (really-dup->port port-maker fd/port . maybe-target)
|
||||
(let ((new-port (port-maker (apply dup->fdes fd/port maybe-target))))
|
||||
(if (null? maybe-target) (release-port-handle new-port))
|
||||
new-port))
|
||||
|
||||
(let ((fd (apply dup->fdes fd/port maybe-target)))
|
||||
(port-maker fd (if (null? maybe-target) 0 1))))
|
||||
|
||||
|
||||
;;; Not exported.
|
||||
|
|
|
@ -224,7 +224,7 @@ scheme_value cloexec_unrevealed(void)
|
|||
}
|
||||
|
||||
|
||||
int install_port(int fd, scheme_value port)
|
||||
int install_port(int fd, scheme_value port, int revealed)
|
||||
{
|
||||
FILE *stream;
|
||||
const char *modestr;
|
||||
|
@ -236,6 +236,9 @@ int install_port(int fd, scheme_value port)
|
|||
|
||||
fdports[fd] = port;
|
||||
|
||||
if( !revealed )
|
||||
if( set_cloexec(fd, 1) ) return errno;
|
||||
|
||||
if( fstar_cache[fd] ) return 0; /* A hack mainly for stdio. */
|
||||
|
||||
fstar_cache[fd] = stream = fdopen(fd, modestr);
|
||||
|
@ -296,6 +299,7 @@ int move_fdport(int fd, scheme_value port, int new_revealed)
|
|||
*PortData_OldRev(port_data) = ENTER_FIXNUM(EXTRACT_FIXNUM(*PortData_OldRev(port_data))+
|
||||
EXTRACT_FIXNUM(*PortData_Rev(port_data)));
|
||||
*PortData_Rev(port_data) = ENTER_FIXNUM(new_revealed);
|
||||
if( !new_revealed ) return set_cloexec(fd, 1);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
|
@ -22,9 +22,7 @@ int set_fdbuf( scheme_value data, int policy, int bufsize );
|
|||
|
||||
int close_fdport(scheme_value port_data);
|
||||
|
||||
scheme_value cloexec_unrevealed(void);
|
||||
|
||||
int install_port(int fd, scheme_value port);
|
||||
int install_port(int fd, scheme_value port, int revealed);
|
||||
|
||||
FILE *fdes2fstar(int fd);
|
||||
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
|
||||
;;; These are the correct values for my SparcStation.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
@ -24,3 +19,29 @@
|
|||
(define open/access-mask
|
||||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here.
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -4,14 +4,9 @@
|
|||
;;; NOTE: When the hp9000s500 symbol is set, errno.h defines ENOMSG to be 250
|
||||
;;; instead of 35. What to do? We go with 35 in this file.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
(perm 1) ; Not super-user
|
||||
(noent 2) ; No such file or directory
|
||||
(srch 3) ; No such process
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-opens form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
;; POSIX
|
||||
(read 0)
|
||||
(write 1)
|
||||
|
@ -19,25 +14,34 @@
|
|||
(exclusive #o2000)
|
||||
|
||||
;; NextStep
|
||||
(sync #o100000)) ; Synchronous writes
|
||||
(sync #o100000)) ; Synchronous writes
|
||||
|
||||
(define open/access-mask
|
||||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-record-lock 5) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 6) ; F_SETLK
|
||||
(define fcntl/set-record-lock 7) ; F_SETLKW
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ' F_UNLCK
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -2,12 +2,7 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
(hup 1) ; floating point exception
|
||||
(int 2) ; Interrupt
|
||||
(quit 3) ; quit
|
||||
|
|
|
@ -7,12 +7,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o100) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
|
||||
;;; These are the correct values for my SparcStation.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
@ -25,16 +20,28 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-record-lock 5)
|
||||
(define fcntl/set-record-lock-noblock 6)
|
||||
(define fcntl/set-record-lock 7)
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
(define lock/read 1)
|
||||
(define lock/write 2)
|
||||
(define lock/release 3)
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here.
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
|
@ -7,12 +7,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line 1) ; _IOLBF
|
||||
(none 2)) ; _IONBF
|
||||
|
|
|
@ -4,14 +4,9 @@
|
|||
|
||||
;;; These are the correct values for Linux systems.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
|
||||
(perm 1 ); Operation Not Permitted
|
||||
|
|
|
@ -2,12 +2,7 @@
|
|||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-opens form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
;; POSIX
|
||||
(read #x0000)
|
||||
(write #x0001)
|
||||
|
@ -16,8 +11,8 @@
|
|||
(append #x0400) ; set append mode
|
||||
|
||||
;; Linux
|
||||
(shlock #x0004) ; open with shared file lock
|
||||
(exlock #x0008) ; open with exclusive file lock
|
||||
(shared-lock #x0004) ; open with shared file lock
|
||||
(exclusive-lock #x0008) ; open with exclusive file lock
|
||||
(async #x2000) ; signal pgrep when data ready
|
||||
(fsync #x1000) ; synchronus writes
|
||||
|
||||
|
@ -33,55 +28,30 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;;; fcntl
|
||||
;;;; Rough sketch only. Will define a separate proc for each fcntl command.
|
||||
;
|
||||
;;;; fcntl commands
|
||||
;dup
|
||||
;
|
||||
;get-flags ; Only gives close-on-exec bit.
|
||||
;set-flags
|
||||
;
|
||||
;get-status ; Returns open flags + get-status flags (below)
|
||||
;set-status ; Can set: append, sync, async, nbio, nonblocking, no-delay
|
||||
;
|
||||
;get-lock
|
||||
;set-lock
|
||||
;nonblocking-set-lock
|
||||
;
|
||||
;get-record-lock
|
||||
;set-record-lock
|
||||
;set-record-lock-noblock
|
||||
;
|
||||
;get-owner ; Not POSIX
|
||||
;set-owner ; Not POSIX
|
||||
;remote-set-lock ; Not POSIX
|
||||
;nonblocking-remote-set-lock ; Not POSIX
|
||||
;remote-get-lock ; Not POSIX
|
||||
;
|
||||
;;;; Flags
|
||||
;
|
||||
;close-on-exec ; get-flags
|
||||
;
|
||||
;async ; get-status
|
||||
;no-delay ; get-status
|
||||
;nbio ; get-status
|
||||
;
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-owner 9) ; F_GETOWN (Not POSIX)
|
||||
(set-owner 8) ; F_SETOWN (Not POSIX)
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-owner 9) ; Not POSIX
|
||||
(define fcntl/set-owner 8) ; Not POSIX
|
||||
(define fcntl/get-record-lock 5) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 6) ; F_SETLK
|
||||
(define fcntl/set-record-lock 7) ; F_SETLKW
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
(define lock/read 0) ; F_RDLCK
|
||||
(define lock/release 2) ; F_UNLCK
|
||||
(define lock/write 1) ; F_WRLCK
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 0) ; F_RDLCK
|
||||
(release 2) ; F_UNLCK
|
||||
(write 1)) ; F_WRLCK
|
||||
|
|
|
@ -2,12 +2,7 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1)
|
||||
(int 2)
|
||||
|
|
|
@ -150,9 +150,8 @@
|
|||
(error "create-socket: integer arguments expected ~s ~s ~s"
|
||||
pf type protocol)
|
||||
(let* ((fd (%socket pf type protocol))
|
||||
(in (make-input-fdport fd))
|
||||
(in (make-input-fdport fd 0))
|
||||
(out (dup->outport in)))
|
||||
(%install-port fd in)
|
||||
(make-socket pf in out)))))
|
||||
|
||||
(define-foreign %socket/errno
|
||||
|
@ -252,9 +251,8 @@
|
|||
(let* ((family (socket:family sock))
|
||||
(name (make-addr family))
|
||||
(fd (%accept (socket->fdes sock) family name))
|
||||
(in (make-input-fdport fd))
|
||||
(in (make-input-fdport fd 0))
|
||||
(out (dup->outport in)))
|
||||
(%install-port fd in)
|
||||
(values (make-socket family in out)
|
||||
(make-socket-address family name)))))
|
||||
|
||||
|
@ -340,12 +338,10 @@
|
|||
(error "create-socket-pair: integer argument expected ~s" type)
|
||||
(receive (s1 s2)
|
||||
(%socket-pair type)
|
||||
(let* ((in1 (make-input-fdport s1))
|
||||
(let* ((in1 (make-input-fdport s1 0))
|
||||
(out1 (dup->outport in1))
|
||||
(in2 (make-input-fdport s2))
|
||||
(in2 (make-input-fdport s2 0))
|
||||
(out2 (dup->outport in2)))
|
||||
(%install-port s1 in1)
|
||||
(%install-port s2 in2)
|
||||
(values (make-socket protocol-family/unix in1 out1)
|
||||
(make-socket protocol-family/unix in2 out2))))))
|
||||
|
||||
|
|
|
@ -6,20 +6,31 @@
|
|||
fd ; Unix file descriptor - integer.
|
||||
(closed? #f) ; Is port closed.
|
||||
(peek-char #f)
|
||||
(revealed 0) ; REVEALED & OLD-REVEALED are for keeping
|
||||
revealed ; REVEALED & OLD-REVEALED are for keeping
|
||||
(old-revealed 0)) ; track of whether the FD value has escaped.
|
||||
|
||||
;;; We could flush the PEEK-CHAR field and use stdio ungetc(), but it
|
||||
;;; is only guaranteed for buffered streams. Too bad...
|
||||
|
||||
(define (make-input-fdport fd)
|
||||
(make-extensible-input-port (make-fdport-data fd)
|
||||
(define (alloc-input-fdport fd revealed)
|
||||
(make-extensible-input-port (make-fdport-data fd revealed)
|
||||
input-fdport-methods))
|
||||
|
||||
(define (make-output-fdport fd)
|
||||
(make-extensible-output-port (make-fdport-data fd)
|
||||
(define (alloc-output-fdport fd revealed)
|
||||
(make-extensible-output-port (make-fdport-data fd revealed)
|
||||
output-fdport-methods))
|
||||
|
||||
(define (make-input-fdport fd revealed)
|
||||
(let ((p (alloc-input-fdport fd revealed)))
|
||||
(%install-port fd p revealed)
|
||||
p))
|
||||
|
||||
(define (make-output-fdport fd revealed)
|
||||
(let ((p (alloc-output-fdport fd revealed)))
|
||||
(%install-port fd p revealed)
|
||||
p))
|
||||
|
||||
|
||||
(define (fdport? x)
|
||||
(cond ((or (and (extensible-input-port? x)
|
||||
(extensible-input-port-local-data x))
|
||||
|
@ -128,14 +139,12 @@
|
|||
;;; ------------
|
||||
|
||||
(define (open-file fname flags . maybe-mode)
|
||||
(let* ((fd (apply open-fdes fname flags maybe-mode))
|
||||
(access (bitwise-and flags open/access-mask))
|
||||
(port ((if (or (= access open/read) (= access open/read+write))
|
||||
make-input-fdport
|
||||
make-output-fdport)
|
||||
fd)))
|
||||
(%install-port fd port)
|
||||
port))
|
||||
(let ((fd (apply open-fdes fname flags maybe-mode))
|
||||
(access (bitwise-and flags open/access-mask)))
|
||||
((if (or (= access open/read) (= access open/read+write))
|
||||
make-input-fdport
|
||||
make-output-fdport)
|
||||
fd 0)))
|
||||
|
||||
(define (open-input-file fname . maybe-flags)
|
||||
(let ((flags (:optional maybe-flags 0)))
|
||||
|
@ -154,8 +163,11 @@
|
|||
|
||||
(define (increment-revealed-count port delta)
|
||||
(let* ((data (extensible-port-local-data port))
|
||||
(count (fdport-data:revealed data)))
|
||||
(set-fdport-data:revealed data (+ count delta))))
|
||||
(count (fdport-data:revealed data))
|
||||
(newcount (+ count delta)))
|
||||
(set-fdport-data:revealed data newcount)
|
||||
(if (and (zero? count) (> newcount 0)) ; We just became revealed,
|
||||
(%set-cloexec (fdport-data:fd data) #f)))) ; so don't close on exec().
|
||||
|
||||
(define (release-port-handle port)
|
||||
(check-arg fdport? port port->fdes)
|
||||
|
@ -164,7 +176,10 @@
|
|||
(if (zero? rev)
|
||||
(set-fdport-data:old-revealed data
|
||||
(- (fdport-data:old-revealed data) 1))
|
||||
(set-fdport-data:revealed data (- rev 1)))))
|
||||
(let ((new-rev (- rev 1)))
|
||||
(set-fdport-data:revealed data new-rev)
|
||||
(if (zero? new-rev) ; We just became unrevealed, so
|
||||
(%set-cloexec (fdport-data:fd data) #t)))))); the fd can be closed on exec.
|
||||
|
||||
(define (port-revealed port)
|
||||
(let ((count (fdport-data:revealed
|
||||
|
@ -173,12 +188,11 @@
|
|||
(and (not (zero? count)) count)))
|
||||
|
||||
(define (fdes->port fd port-maker) ; local proc.
|
||||
(let ((port (or (%maybe-fdes->port fd)
|
||||
(let ((port (port-maker fd)))
|
||||
(%install-port fd port)
|
||||
port))))
|
||||
(increment-revealed-count port 1)
|
||||
port))
|
||||
(cond ((%maybe-fdes->port fd) =>
|
||||
(lambda (p)
|
||||
(increment-revealed-count p 1)
|
||||
p))
|
||||
(else (port-maker fd 1))))
|
||||
|
||||
(define (fdes->inport fd) (fdes->port fd make-input-fdport))
|
||||
(define (fdes->outport fd) (fdes->port fd make-output-fdport))
|
||||
|
@ -205,6 +219,14 @@
|
|||
|
||||
(else (error "Not a file descriptor or fdport." fd/port))))
|
||||
|
||||
;;; Don't mess with the revealed count in the port case
|
||||
;;; -- just sneakily grab the fdes and run.
|
||||
|
||||
(define (sleazy-call/fdes fd/port proc)
|
||||
(proc (cond ((integer? fd/port) fd/port)
|
||||
((fdport? fd/port) (fdport-data:fd (fdport-data fd/port)))
|
||||
(else (error "Not a file descriptor or fdport." fd/port)))))
|
||||
|
||||
|
||||
;;; Random predicates and arg checkers
|
||||
;;; ----------------------------------
|
||||
|
@ -274,7 +296,7 @@
|
|||
|
||||
;;; If this fd has an associated input or output port,
|
||||
;;; move it to a new fd, freeing this one up.
|
||||
;;; Unitialized fdport in table is set to 0, does this mean
|
||||
|
||||
(define (evict-ports fd)
|
||||
(cond ((%maybe-fdes->port fd) => ; Shouldn't bump the revealed count.
|
||||
(lambda (port)
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
|
||||
;;; These are the correct values for NextStep systems.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-opens form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
;; POSIX
|
||||
(read 0)
|
||||
(write 1)
|
||||
|
@ -26,55 +21,31 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;;; fcntl
|
||||
;;;; Rough sketch only. Will define a separate proc for each fcntl command.
|
||||
;
|
||||
;;;; fcntl commands
|
||||
;dup
|
||||
;
|
||||
;get-flags ; Only gives close-on-exec bit.
|
||||
;set-flags
|
||||
;
|
||||
;get-status ; Returns open flags + get-status flags (below)
|
||||
;set-status ; Can set: append, sync, async, nbio, nonblocking, no-delay
|
||||
;
|
||||
;get-lock
|
||||
;set-lock
|
||||
;nonblocking-set-lock
|
||||
;
|
||||
;get-record-lock
|
||||
;set-record-lock
|
||||
;set-record-lock-noblock
|
||||
;
|
||||
;get-owner ; Not POSIX
|
||||
;set-owner ; Not POSIX
|
||||
;remote-set-lock ; Not POSIX
|
||||
;nonblocking-remote-set-lock ; Not POSIX
|
||||
;remote-get-lock ; Not POSIX
|
||||
;
|
||||
;;;; Flags
|
||||
;
|
||||
;close-on-exec ; get-flags
|
||||
;
|
||||
;async ; get-status
|
||||
;no-delay ; get-status
|
||||
;nbio ; get-status
|
||||
;
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-owner 5) ; F_GETOWN (Not POSIX)
|
||||
(set-owner 6) ; F_SETOWN (Not POSIX)
|
||||
(get-record-lock 7) ; F_GETLK
|
||||
(set-record-lock-noblock 8) ; F_SETLK
|
||||
(set-record-lock 9)) ; F_SETLKW
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-owner 5) ; Not POSIX
|
||||
(define fcntl/set-owner 6) ; Not POSIX
|
||||
(define fcntl/get-record-lock 7) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 8) ; F_SETLK
|
||||
(define fcntl/set-record-lock 9) ; F_SETLKW
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ' F_UNLCK
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Signal constant definitions for NextStep
|
||||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
|
@ -657,7 +657,6 @@
|
|||
|
||||
;; Try each directory in PATH-LIST.
|
||||
(let ((argv (list->vector (cons prog (map stringify arglist)))))
|
||||
(cloexec-unrevealed-ports)
|
||||
(for-each (lambda (dir)
|
||||
(let ((binary (string-append dir "/" prog)))
|
||||
(%%exec/errno binary argv env)))
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o100) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -4,14 +4,9 @@
|
|||
|
||||
;;; These are the correct values for my SparcStation.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Not Super-User
|
||||
(noent 2) ; No Such File Or Directory
|
||||
|
|
|
@ -1,12 +1,8 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; Modified for Solaris by tvb@math.ufl.edu
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
@ -25,58 +21,30 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;;; fcntl
|
||||
;;;; Rough sketch only. Will define a separate proc for each fcntl command.
|
||||
;
|
||||
;;;; fcntl commands
|
||||
;dup
|
||||
;
|
||||
;get-flags ; Only gives close-on-exec bit.
|
||||
;set-flags
|
||||
;
|
||||
;get-status ; Returns open flags + get-status flags (below)
|
||||
;set-status ; Can set: append, sync, async, nbio, nonblocking, no-delay
|
||||
;
|
||||
;get-lock
|
||||
;set-lock
|
||||
;nonblocking-set-lock
|
||||
;
|
||||
;get-record-lock
|
||||
;set-record-lock
|
||||
;
|
||||
;get-owner ; Not POSIX
|
||||
;set-owner ; Not POSIX
|
||||
;remote-set-lock ; Not POSIX
|
||||
;nonblocking-remote-set-lock ; Not POSIX
|
||||
;remote-get-lock ; Not POSIX
|
||||
;
|
||||
;;;; Flags
|
||||
;
|
||||
;close-on-exec ; get-flags
|
||||
;
|
||||
;async ; get-status
|
||||
;no-delay ; get-status
|
||||
;nbio ; get-status
|
||||
;
|
||||
;lock/read ; set-lock
|
||||
;lock/write ; set-lock
|
||||
;lock/release ; set-lock
|
||||
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-owner 23) ; F_GETOWN (Not Posix)
|
||||
(set-owner 24) ; F_SETOWN (Not Posix)
|
||||
(get-record-lock 5) ; F_GETLK
|
||||
(set-record-lock-noblock 6) ; F_SETLK
|
||||
(set-record-lock 7)) ; F_SETLKW
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-owner 23) ; F_GETOWN
|
||||
(define fcntl/set-owner 24) ; F_SETOWN
|
||||
(define fcntl/get-record-lock 5) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 6) ; F_SETLK
|
||||
(define fcntl/set-record-lock 7) ; F_SETLKW
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ; F_UNLCK
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Modified for Solaris by tvb@math.ufl.edu
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;; Adapted from signal.h - tvb
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; Hangup
|
||||
(int 2) ; Interrupt (Rubout)
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -3,14 +3,9 @@
|
|||
|
||||
;;; These are the correct values for my SparcStation.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -1,12 +1,7 @@
|
|||
;;; Flags for open(2) and fcntl(2).
|
||||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read 0)
|
||||
(write 1)
|
||||
(read+write 2)
|
||||
|
@ -25,59 +20,30 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
;;;; fcntl
|
||||
;;;; Rough sketch only. Will define a separate proc for each fcntl command.
|
||||
;
|
||||
;;;; fcntl commands
|
||||
;dup
|
||||
;
|
||||
;get-flags ; Only gives close-on-exec bit.
|
||||
;set-flags
|
||||
;
|
||||
;get-status ; Returns open flags + get-status flags (below)
|
||||
;set-status ; Can set: append, sync, async, nbio, nonblocking, no-delay
|
||||
;
|
||||
;get-lock
|
||||
;set-lock
|
||||
;nonblocking-set-lock
|
||||
;
|
||||
;get-record-lock
|
||||
;set-record-lock
|
||||
;set-record-lock-noblock
|
||||
;
|
||||
;get-owner ; Not POSIX
|
||||
;set-owner ; Not POSIX
|
||||
;remote-set-lock ; Not POSIX
|
||||
;nonblocking-remote-set-lock ; Not POSIX
|
||||
;remote-get-lock ; Not POSIX
|
||||
;
|
||||
;;;; Flags
|
||||
;
|
||||
;close-on-exec ; get-flags
|
||||
;
|
||||
;async ; get-status
|
||||
;no-delay ; get-status
|
||||
;nbio ; get-status
|
||||
;
|
||||
;lock/read ; set-lock
|
||||
;lock/write ; set-lock
|
||||
;lock/release ; set-lock
|
||||
;;; fcntl() commands
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-owner 5) ; F_GETOWN (Not Posix)
|
||||
(set-owner 6) ; F_SETOWN (Not Posix)
|
||||
(get-record-lock 7) ; F_GETLK
|
||||
(set-record-lock-noblock 8) ; F_SETLK
|
||||
(set-record-lock 9)) ; F_SETLKW
|
||||
|
||||
;;; These are internal; they are not part of the supported scsh interface.
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-owner 5) ; F_GETOWN
|
||||
(define fcntl/set-owner 6) ; F_SETOWN
|
||||
(define fcntl/get-record-lock 7) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 8) ; F_SETLK
|
||||
(define fcntl/set-record-lock 9) ; F_SETLKW
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ' F_UNLCK
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -1,14 +1,9 @@
|
|||
;;; Signal constant definitions for Sun4
|
||||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here, couldn't find signal.h for Sun4 -dalbertz
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
30
scsh/tty.scm
30
scsh/tty.scm
|
@ -109,7 +109,7 @@
|
|||
(receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
|
||||
cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
|
||||
ispeed-code ospeed-code)
|
||||
(call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
|
||||
(sleazy-call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
|
||||
(make-%tty-info control-chars
|
||||
(bitwise-ior (arithmetic-shift iflag-hi8 24) iflag-lo24)
|
||||
(bitwise-ior (arithmetic-shift oflag-hi8 24) oflag-lo24)
|
||||
|
@ -161,7 +161,7 @@
|
|||
(cflag-lo24 (bitwise-and cf #xffffff))
|
||||
(lflag-hi8 (arithmetic-shift lf -24))
|
||||
(lflag-lo24 (bitwise-and lf #xffffff)))
|
||||
(call/fdes fdport
|
||||
(sleazy-call/fdes fdport
|
||||
(lambda (fd)
|
||||
(%set-tty-info fd option
|
||||
cc
|
||||
|
@ -221,7 +221,7 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (send-tty-break fdport . maybe-duration)
|
||||
(call/fdes fdport
|
||||
(sleazy-call/fdes fdport
|
||||
(lambda (fdes)
|
||||
(%send-tty-break-fdes fdes (:optional maybe-duration 0)))))
|
||||
|
||||
|
@ -240,7 +240,7 @@
|
|||
(cond ((integer? fdport) (%tcdrain fdport)) ; File descriptor.
|
||||
((fdport? fdport) ; Scheme port -- flush first.
|
||||
(force-output fdport)
|
||||
(call/fdes fdport %tcdrain))
|
||||
(sleazy-call/fdes fdport %tcdrain))
|
||||
(else (error "Illegal argument to DRAIN-TTY" fdport))))
|
||||
|
||||
(define-errno-syscall (%tcdrain fdes) %tcdrain/errno)
|
||||
|
@ -255,7 +255,7 @@
|
|||
|
||||
(define (make-tty-flusher flag)
|
||||
(lambda (fdport)
|
||||
(call/fdes fdport (lambda (fdes) (%tcflush fdes flag)))))
|
||||
(sleazy-call/fdes fdport (lambda (fdes) (%tcflush fdes flag)))))
|
||||
|
||||
(define flush-tty/input (make-tty-flusher %flush-tty/input))
|
||||
(define flush-tty/output (make-tty-flusher %flush-tty/output))
|
||||
|
@ -274,7 +274,7 @@
|
|||
|
||||
(define (make-flow-controller action)
|
||||
(lambda (fdport)
|
||||
(call/fdes fdport (lambda (fdes) (%tcflow fdes action)))))
|
||||
(sleazy-call/fdes fdport (lambda (fdes) (%tcflow fdes action)))))
|
||||
|
||||
(define start-tty-output (make-flow-controller %tcflow/start-out))
|
||||
(define stop-tty-output (make-flow-controller %tcflow/stop-out))
|
||||
|
@ -310,7 +310,7 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (set-tty-process-group port/fd proc-group)
|
||||
(call/fdes port/fd
|
||||
(sleazy-call/fdes port/fd
|
||||
(lambda (fd)
|
||||
(%set-tty-process-group fd (if (integer? proc-group)
|
||||
proc-group
|
||||
|
@ -325,7 +325,7 @@
|
|||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define (tty-process-group port/fd)
|
||||
(call/fdes port/fd %tty-process-group))
|
||||
(sleazy-call/fdes port/fd %tty-process-group))
|
||||
|
||||
(define-errno-syscall (%tty-process-group fd) %tty-process-group/errno
|
||||
pid)
|
||||
|
@ -348,14 +348,12 @@
|
|||
(let lp ()
|
||||
(receive (errno fd) (open-control-tty/errno ttyname flags)
|
||||
(cond ((not errno)
|
||||
(let* ((access (bitwise-and flags open/access-mask))
|
||||
(port ((if (or (= access open/read)
|
||||
(= access open/read+write))
|
||||
make-input-fdport
|
||||
make-output-fdport)
|
||||
fd)))
|
||||
(%install-port fd port)
|
||||
port))
|
||||
(let ((access (bitwise-and flags open/access-mask)))
|
||||
((if (or (= access open/read)
|
||||
(= access open/read+write))
|
||||
make-input-fdport
|
||||
make-output-fdport)
|
||||
fd 1)))
|
||||
((= errno/intr errno) (lp))
|
||||
(else (errno-error errno open-control-tty ttyname flags)))))))
|
||||
|
||||
|
|
|
@ -6,12 +6,7 @@
|
|||
;;; These constants are not likely to change from stdio lib to stdio lib,
|
||||
;;; but you need to check when you do a port.
|
||||
|
||||
(define-syntax define-bufpols
|
||||
(syntax-rules ()
|
||||
((define-bufpols form ...)
|
||||
(begin (define-enum-constant "bufpol" . form) ...))))
|
||||
|
||||
(define-bufpols
|
||||
(define-enum-constants bufpol
|
||||
(block 0) ; _IOFBF
|
||||
(line #o200) ; _IOLBF
|
||||
(none 4)) ; _IONBF
|
||||
|
|
|
@ -4,14 +4,9 @@
|
|||
|
||||
;;; These are the correct values for Ultrix.
|
||||
|
||||
(define-syntax define-errnos
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "errno" . form) ...))))
|
||||
|
||||
(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose.
|
||||
|
||||
(define-errnos
|
||||
(define-enum-constants errno
|
||||
;; POSIX:
|
||||
(perm 1) ; Operation not permitted
|
||||
(noent 2) ; No such file or directory
|
||||
|
|
|
@ -2,12 +2,7 @@
|
|||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-open-flags
|
||||
(syntax-rules ()
|
||||
((define-errnos form ...)
|
||||
(begin (define-enum-constant "open" . form) ...))))
|
||||
|
||||
(define-open-flags
|
||||
(define-enum-constants open
|
||||
(read #o000)
|
||||
(write #o001)
|
||||
(read+write #o002)
|
||||
|
@ -29,16 +24,29 @@
|
|||
(bitwise-ior open/read
|
||||
(bitwise-ior open/write open/read+write)))
|
||||
|
||||
(define fcntl/close-on-exec 1)
|
||||
(define fcntl/dupfd 0)
|
||||
(define fcntl/get-fd-flags 1)
|
||||
(define fcntl/set-fd-flags 2)
|
||||
(define fcntl/get-file-flags 3)
|
||||
(define fcntl/set-file-flags 4)
|
||||
(define fcntl/get-record-lock 7) ; F_GETLK
|
||||
(define fcntl/set-record-lock-noblock 8) ; F_SETLK
|
||||
(define fcntl/set-record-lock 9) ; F_SETLKW
|
||||
;;; fcntl() commands
|
||||
|
||||
(define lock/read 1) ; F_RDLCK
|
||||
(define lock/write 2) ; F_WRLCK
|
||||
(define lock/release 3) ; F_UNLCK
|
||||
(define-enum-constants fcntl
|
||||
(dup-fdes 0) ; F_DUPFD
|
||||
(get-fdes-flags 1) ; F_GETFD
|
||||
(set-fdes-flags 2) ; F_SETFD
|
||||
(get-status-flags 3) ; F_GETFL
|
||||
(set-status-flags 4) ; F_SETFL
|
||||
(get-record-lock 7) ; F_GETLK
|
||||
(set-record-lock-noblock 8) ; F_SETLK
|
||||
(set-record-lock 9)) ; F_SETLKW
|
||||
|
||||
;;; fcntl fdes-flags (F_GETFD)
|
||||
|
||||
(define fdflags/close-on-exec 1)
|
||||
|
||||
;;; fcntl status-flags (F_GETFL)
|
||||
;;; Mostly, these are OPEN/... flags, like OPEN/APPEND.
|
||||
;;; (define fdstatus/... ...)
|
||||
|
||||
;;; fcntl lock values.
|
||||
|
||||
(define-enum-constants lock
|
||||
(read 1) ; F_RDLCK
|
||||
(write 2) ; F_WRLCK
|
||||
(release 3)) ; F_UNLCK
|
||||
|
|
|
@ -2,14 +2,9 @@
|
|||
;;; Copyright (c) 1994 by Olin Shivers.
|
||||
;;; Copyright (c) 1994 by Brian D. Carlstrom.
|
||||
|
||||
(define-syntax define-signals
|
||||
(syntax-rules ()
|
||||
((define-signals form ...)
|
||||
(begin (define-enum-constant "signal" . form) ...))))
|
||||
|
||||
;;POSIX only defined here.
|
||||
|
||||
(define-signals
|
||||
(define-enum-constants signal
|
||||
;; POSIX
|
||||
(hup 1) ; hangup
|
||||
(int 2) ; interrupt
|
||||
|
|
Loading…
Reference in New Issue