diff --git a/scsh/aix/bufpol.scm b/scsh/aix/bufpol.scm index f838e85..1829ecb 100644 --- a/scsh/aix/bufpol.scm +++ b/scsh/aix/bufpol.scm @@ -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 diff --git a/scsh/aix/errno.scm b/scsh/aix/errno.scm index 8260a91..4c976e2 100644 --- a/scsh/aix/errno.scm +++ b/scsh/aix/errno.scm @@ -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 diff --git a/scsh/aix/fdflags.scm b/scsh/aix/fdflags.scm index 7463aa8..5b9fb0a 100644 --- a/scsh/aix/fdflags.scm +++ b/scsh/aix/fdflags.scm @@ -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 diff --git a/scsh/aix/signals.scm b/scsh/aix/signals.scm index f92fae9..c10a295 100644 --- a/scsh/aix/signals.scm +++ b/scsh/aix/signals.scm @@ -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 diff --git a/scsh/cxux/bufpol.scm b/scsh/cxux/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/cxux/bufpol.scm +++ b/scsh/cxux/bufpol.scm @@ -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 diff --git a/scsh/cxux/errno.scm b/scsh/cxux/errno.scm index ea33874..d424d6d 100644 --- a/scsh/cxux/errno.scm +++ b/scsh/cxux/errno.scm @@ -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) diff --git a/scsh/cxux/fdflags.scm b/scsh/cxux/fdflags.scm index 36effbc..72f4d5c 100644 --- a/scsh/cxux/fdflags.scm +++ b/scsh/cxux/fdflags.scm @@ -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) diff --git a/scsh/cxux/signals.scm b/scsh/cxux/signals.scm index 6f3f9fc..a37faef 100644 --- a/scsh/cxux/signals.scm +++ b/scsh/cxux/signals.scm @@ -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 diff --git a/scsh/fdports.scm b/scsh/fdports.scm index e78a24d..7d66314 100644 --- a/scsh/fdports.scm +++ b/scsh/fdports.scm @@ -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. diff --git a/scsh/fdports1.c b/scsh/fdports1.c index b87e084..1230fda 100644 --- a/scsh/fdports1.c +++ b/scsh/fdports1.c @@ -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; } diff --git a/scsh/fdports1.h b/scsh/fdports1.h index 899ac0c..f533793 100644 --- a/scsh/fdports1.h +++ b/scsh/fdports1.h @@ -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); diff --git a/scsh/generic/bufpol.scm b/scsh/generic/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/generic/bufpol.scm +++ b/scsh/generic/bufpol.scm @@ -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 diff --git a/scsh/generic/errno.scm b/scsh/generic/errno.scm index 1111c63..6f64388 100644 --- a/scsh/generic/errno.scm +++ b/scsh/generic/errno.scm @@ -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 diff --git a/scsh/generic/fdflags.scm b/scsh/generic/fdflags.scm index 91d5178..8a17fa5 100644 --- a/scsh/generic/fdflags.scm +++ b/scsh/generic/fdflags.scm @@ -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 diff --git a/scsh/generic/signals.scm b/scsh/generic/signals.scm index 47458fc..11dac3d 100644 --- a/scsh/generic/signals.scm +++ b/scsh/generic/signals.scm @@ -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 diff --git a/scsh/hpux/bufpol.scm b/scsh/hpux/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/hpux/bufpol.scm +++ b/scsh/hpux/bufpol.scm @@ -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 diff --git a/scsh/hpux/errno.scm b/scsh/hpux/errno.scm index 2410011..1b25e73 100644 --- a/scsh/hpux/errno.scm +++ b/scsh/hpux/errno.scm @@ -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 diff --git a/scsh/hpux/fdflags.scm b/scsh/hpux/fdflags.scm index 612cfac..5c4a262 100644 --- a/scsh/hpux/fdflags.scm +++ b/scsh/hpux/fdflags.scm @@ -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 diff --git a/scsh/hpux/signals.scm b/scsh/hpux/signals.scm index 1ec1fb6..f93e2d7 100644 --- a/scsh/hpux/signals.scm +++ b/scsh/hpux/signals.scm @@ -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 diff --git a/scsh/irix/bufpol.scm b/scsh/irix/bufpol.scm index 9f5668c..f3667d9 100644 --- a/scsh/irix/bufpol.scm +++ b/scsh/irix/bufpol.scm @@ -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 diff --git a/scsh/irix/errno.scm b/scsh/irix/errno.scm index 409d18d..45e803b 100644 --- a/scsh/irix/errno.scm +++ b/scsh/irix/errno.scm @@ -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 diff --git a/scsh/irix/fdflags.scm b/scsh/irix/fdflags.scm index 3e32e3e..8cadcee 100644 --- a/scsh/irix/fdflags.scm +++ b/scsh/irix/fdflags.scm @@ -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 diff --git a/scsh/irix/signals.scm b/scsh/irix/signals.scm index 1319c49..0d0f2ad 100644 --- a/scsh/irix/signals.scm +++ b/scsh/irix/signals.scm @@ -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 diff --git a/scsh/linux/bufpol.scm b/scsh/linux/bufpol.scm index c6ee0e2..803bdf3 100644 --- a/scsh/linux/bufpol.scm +++ b/scsh/linux/bufpol.scm @@ -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 diff --git a/scsh/linux/errno.scm b/scsh/linux/errno.scm index 218b755..e6c86ec 100644 --- a/scsh/linux/errno.scm +++ b/scsh/linux/errno.scm @@ -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 diff --git a/scsh/linux/fdflags.scm b/scsh/linux/fdflags.scm index 85b16e3..af7ad0b 100644 --- a/scsh/linux/fdflags.scm +++ b/scsh/linux/fdflags.scm @@ -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 diff --git a/scsh/linux/signals.scm b/scsh/linux/signals.scm index 436c28b..dd945b8 100644 --- a/scsh/linux/signals.scm +++ b/scsh/linux/signals.scm @@ -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) diff --git a/scsh/network.scm b/scsh/network.scm index ccceb2e..e0ed90e 100644 --- a/scsh/network.scm +++ b/scsh/network.scm @@ -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)))))) diff --git a/scsh/newports.scm b/scsh/newports.scm index 68ecaa2..900ea09 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -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) diff --git a/scsh/next/bufpol.scm b/scsh/next/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/next/bufpol.scm +++ b/scsh/next/bufpol.scm @@ -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 diff --git a/scsh/next/errno.scm b/scsh/next/errno.scm index 11a02c8..66a935c 100644 --- a/scsh/next/errno.scm +++ b/scsh/next/errno.scm @@ -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 diff --git a/scsh/next/fdflags.scm b/scsh/next/fdflags.scm index 117cccc..4645bfe 100644 --- a/scsh/next/fdflags.scm +++ b/scsh/next/fdflags.scm @@ -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 diff --git a/scsh/next/signals.scm b/scsh/next/signals.scm index 3fac949..d8b47c2 100644 --- a/scsh/next/signals.scm +++ b/scsh/next/signals.scm @@ -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 diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 87498e5..79b845c 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -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))) diff --git a/scsh/solaris/bufpol.scm b/scsh/solaris/bufpol.scm index f838e85..1829ecb 100644 --- a/scsh/solaris/bufpol.scm +++ b/scsh/solaris/bufpol.scm @@ -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 diff --git a/scsh/solaris/errno.scm b/scsh/solaris/errno.scm index 28c8ff3..43c1230 100644 --- a/scsh/solaris/errno.scm +++ b/scsh/solaris/errno.scm @@ -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 diff --git a/scsh/solaris/fdflags.scm b/scsh/solaris/fdflags.scm index acebf5b..7993307 100644 --- a/scsh/solaris/fdflags.scm +++ b/scsh/solaris/fdflags.scm @@ -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 diff --git a/scsh/solaris/signals.scm b/scsh/solaris/signals.scm index 80753ef..1a0a09d 100644 --- a/scsh/solaris/signals.scm +++ b/scsh/solaris/signals.scm @@ -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) diff --git a/scsh/sunos/bufpol.scm b/scsh/sunos/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/sunos/bufpol.scm +++ b/scsh/sunos/bufpol.scm @@ -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 diff --git a/scsh/sunos/errno.scm b/scsh/sunos/errno.scm index 780ff02..5b72ee4 100644 --- a/scsh/sunos/errno.scm +++ b/scsh/sunos/errno.scm @@ -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 diff --git a/scsh/sunos/fdflags.scm b/scsh/sunos/fdflags.scm index c6ef546..9855e3b 100644 --- a/scsh/sunos/fdflags.scm +++ b/scsh/sunos/fdflags.scm @@ -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 diff --git a/scsh/sunos/signals.scm b/scsh/sunos/signals.scm index 595cf30..ba08aee 100644 --- a/scsh/sunos/signals.scm +++ b/scsh/sunos/signals.scm @@ -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 diff --git a/scsh/tty.scm b/scsh/tty.scm index 6b153af..8bc4402 100644 --- a/scsh/tty.scm +++ b/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))))))) diff --git a/scsh/ultrix/bufpol.scm b/scsh/ultrix/bufpol.scm index c7e8152..09e5ad9 100644 --- a/scsh/ultrix/bufpol.scm +++ b/scsh/ultrix/bufpol.scm @@ -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 diff --git a/scsh/ultrix/errno.scm b/scsh/ultrix/errno.scm index 3dac5c7..a0922f8 100644 --- a/scsh/ultrix/errno.scm +++ b/scsh/ultrix/errno.scm @@ -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 diff --git a/scsh/ultrix/fdflags.scm b/scsh/ultrix/fdflags.scm index ca8d95c..8e7b186 100644 --- a/scsh/ultrix/fdflags.scm +++ b/scsh/ultrix/fdflags.scm @@ -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 diff --git a/scsh/ultrix/signals.scm b/scsh/ultrix/signals.scm index 57eee6b..5e9f3fb 100644 --- a/scsh/ultrix/signals.scm +++ b/scsh/ultrix/signals.scm @@ -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