~ chicken-core (chicken-5) f4e53ffec0dc8c83ed89eadea2ae20f149e0d4a8
commit f4e53ffec0dc8c83ed89eadea2ae20f149e0d4a8
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat May 13 13:06:36 2017 +0200
Commit: Kooda <kooda@upyum.com>
CommitDate: Tue Jun 6 13:00:42 2017 +0200
Improve consistency of posix interface between Windows and Unix
Firstly, the export lists of the posix module didn't match up between
the two platforms, which meant any program using process-spawn, the
spawn flags or the open/noinherit flag for create-pipe (and for all
the low-level "open" procedures in general, in fact), would have to
cond-expand on platform. Now we define them as no-ops for UNIX and
export them, so you can import them with impunity. These extra flags
have also been added to types.db
Secondly, the types of create-pipe, process, process* and
process-execute didn't match up: the extra "exact-flag" argument for
the process procedures and the extra "mode" argument for create-pipe
were accepted only on Windows, and it would result in compilation
warnings due to types.db not knowing about this. On UNIX, passing the
extra "mode" argument to create-pipe would result in an error, but due
to the specifics of how optional arguments are handled by CHICKEN,
passing the extra exact-flag argument to the process procedures on
UNIX wouldn't be a problem in practice. Nevertheless, you'd still get
a compilation warning. This has now been fixed by explicitly adding
the (unused) extra arguments to the procedures and the types.db
entries.
Finally, process-spawn was only defined on Windows, so any program
that used it couldn't even be compiled on UNIX. Now we move
define-unimplemented to posix-common and define process-spawn as
unimplemented on UNIX. An entry for process-spawn has also been added
to types.db. Its runtime type check has been improved from checking
for any exact number (which is incorrect) to checking for a fixnum.
Signed-off-by: Kooda <kooda@upyum.com>
diff --git a/posix-common.scm b/posix-common.scm
index 23fce65f..9d9afd1b 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -142,6 +142,12 @@ EOF
(include "common-declarations.scm")
+(define-syntax define-unimplemented
+ (syntax-rules ()
+ [(_ ?name)
+ (define (?name . _)
+ (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
+
;;; Error codes:
diff --git a/posix.scm b/posix.scm
index 2e881a65..c19fe02c 100644
--- a/posix.scm
+++ b/posix.scm
@@ -98,12 +98,13 @@
fileno/stderr fileno/stdin fileno/stdout
open-input-file* open-output-file*
open/append open/binary open/creat open/excl open/fsync open/noctty
- open/nonblock open/rdonly open/rdwr open/read open/sync open/text
- open/trunc open/write open/wronly perm/irgrp perm/iroth perm/irusr
- perm/irwxg perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx
- perm/iwgrp perm/iwoth perm/iwusr perm/ixgrp perm/ixoth perm/ixusr
- port->fileno seek/cur seek/end seek/set set-file-group!
- set-file-owner! set-file-permissions! set-file-position! set-file-times!)
+ open/noinherit open/nonblock open/rdonly open/rdwr open/read
+ open/sync open/text open/trunc open/write open/wronly
+ perm/irgrp perm/iroth perm/irusr perm/irwxg perm/irwxo perm/irwxu
+ perm/isgid perm/isuid perm/isvtx perm/iwgrp perm/iwoth perm/iwusr
+ perm/ixgrp perm/ixoth perm/ixusr
+ port->fileno seek/cur seek/end seek/set set-file-group! set-file-owner!
+ set-file-permissions! set-file-position! set-file-times!)
(import chicken chicken.posix))
(module chicken.time.posix
@@ -114,11 +115,12 @@
(module chicken.process
(qs system system* process-execute process-fork process-run
- process-signal process-wait call-with-input-pipe
+ process-signal process-spawn process-wait call-with-input-pipe
call-with-output-pipe close-input-pipe close-output-pipe create-pipe
open-input-pipe open-output-pipe with-input-from-pipe
with-output-to-pipe process process* pipe/buf process-group-id
- create-session)
+ create-session spawn/overlay spawn/wait spawn/nowait spawn/nowaito
+ spawn/detach)
(import chicken scheme chicken.posix chicken.platform)
diff --git a/posixunix.scm b/posixunix.scm
index 82cbe742..54bfe7e4 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -52,24 +52,25 @@
local-time->seconds local-timezone-abbreviation
open-input-file* open-input-pipe open-output-file* open-output-pipe
open/append open/binary open/creat open/excl open/fsync
- open/noctty open/nonblock open/rdonly open/rdwr
+ open/noctty open/noinherit open/nonblock open/rdonly open/rdwr
open/read open/sync open/text open/trunc open/write open/wronly
parent-process-id perm/irgrp perm/iroth perm/irusr perm/irwxg
perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx perm/iwgrp
perm/iwoth perm/iwusr perm/ixgrp perm/ixoth perm/ixusr pipe/buf
port->fileno process process* process-execute process-fork
- process-group-id process-run process-signal process-sleep process-wait
- read-symbolic-link regular-file? seconds->local-time seconds->string
- seconds->utc-time seek/cur seek/end seek/set set-alarm!
- set-buffering-mode! set-file-times! set-root-directory!
- set-signal-handler! set-signal-mask! signal-handler
+ process-group-id process-run process-signal process-sleep
+ process-spawn process-wait read-symbolic-link regular-file?
+ seconds->local-time seconds->string seconds->utc-time seek/cur
+ seek/end seek/set set-alarm! set-buffering-mode! set-file-times!
+ set-root-directory! set-signal-handler! set-signal-mask! signal-handler
signal-mask signal-mask! signal-masked? signal-unmask! signal/abrt
signal/alrm signal/break signal/chld signal/cont signal/fpe
signal/bus signal/hup signal/ill signal/int signal/io signal/kill
signal/pipe signal/prof signal/quit signal/segv signal/stop
signal/term signal/trap signal/tstp signal/urg signal/usr1
signal/usr2 signal/vtalrm signal/winch signal/xcpu signal/xfsz
- signals-list block-device? character-device? fifo? socket?
+ signals-list spawn/overlay spawn/wait spawn/nowait spawn/nowaito
+ spawn/detach block-device? character-device? fifo? socket?
string->time symbolic-link? system-information terminal-name
terminal-port? terminal-size time->string user-information
set-environment-variable! unset-environment-variable!
@@ -459,6 +460,14 @@ EOF
(define open/binary _o_binary)
(define open/text _o_text)
+;; Windows-only definitions
+(define open/noinherit 0)
+(define spawn/overlay 0)
+(define spawn/wait 0)
+(define spawn/nowait 0)
+(define spawn/nowaito 0)
+(define spawn/detach 0)
+
(define-foreign-variable _s_irusr int "S_IRUSR")
(define-foreign-variable _s_iwusr int "S_IWUSR")
(define-foreign-variable _s_ixusr int "S_IXUSR")
@@ -723,11 +732,10 @@ EOF
(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
-(define create-pipe
- (lambda ()
- (when (fx< (##core#inline "C_pipe" #f) 0)
- (posix-error #:file-error 'create-pipe "cannot create pipe") )
- (values _pipefd0 _pipefd1) ) )
+(define (create-pipe #!optional mode)
+ (when (fx< (##core#inline "C_pipe" #f) 0)
+ (posix-error #:file-error 'create-pipe "cannot create pipe") )
+ (values _pipefd0 _pipefd1) )
;;; Signal processing:
@@ -1421,7 +1429,7 @@ EOF
(exit 0)))
pid)))))
-(define (process-execute filename #!optional (arglist '()) envlist)
+(define (process-execute filename #!optional (arglist '()) envlist exactf)
(call-with-exec-args
'process-execute filename (lambda (x) x) arglist envlist
(lambda (prg argbuf envbuf)
@@ -1589,12 +1597,12 @@ EOF
(lambda () (##sys#process loc cmd args env #t #t err?))
k)))))
(set! process
- (lambda (cmd #!optional args env)
+ (lambda (cmd #!optional args env exactf)
(%process
'process #f cmd args env
(lambda (i o p e) (values i o p)))))
(set! process*
- (lambda (cmd #!optional args env)
+ (lambda (cmd #!optional args env exactf)
(%process
'process* #t cmd args env
values))))
@@ -1609,4 +1617,8 @@ EOF
(when (fx< (chroot dir) 0)
(posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )
+;;; unimplemented stuff:
+
+(define-unimplemented process-spawn)
+
) ; chicken.posix
diff --git a/posixwin.scm b/posixwin.scm
index c6002a15..735504c5 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -685,7 +685,7 @@ EOF
local-time->seconds local-timezone-abbreviation
open-input-file* open-input-pipe open-output-file* open-output-pipe
open/append open/binary open/creat open/excl open/fsync
- open/noctty open/nonblock open/rdonly open/rdwr
+ open/noctty open/noinherit open/nonblock open/rdonly open/rdwr
open/read open/sync open/text open/trunc open/write open/wronly
parent-process-id perm/irgrp perm/iroth perm/irusr perm/irwxg
perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx perm/iwgrp
@@ -975,12 +975,11 @@ EOF
(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
-(define create-pipe
- (lambda (#!optional (mode (fxior open/binary open/noinherit)))
- (when (fx< (##core#inline "C_pipe" #f mode) 0)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
- (values _pipefd0 _pipefd1) ) )
+(define (create-pipe #!optional (mode (fxior open/binary open/noinherit)))
+ (when (fx< (##core#inline "C_pipe" #f mode) 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
+ (values _pipefd0 _pipefd1) )
;;; Signal processing:
@@ -1175,7 +1174,7 @@ EOF
(define (process-spawn mode filename #!optional (arglist '()) envlist exactf)
(let ((argconv (if exactf (lambda (x) x) quote-arg-string)))
- (##sys#check-exact mode 'process-spawn)
+ (##sys#check-fixnum mode 'process-spawn)
(call-with-exec-args
'process-spawn filename argconv arglist envlist
(lambda (prg argbuf envbuf)
@@ -1325,15 +1324,6 @@ EOF
;;; unimplemented stuff:
-(define-syntax define-unimplemented
- (syntax-rules ()
- [(_ ?name)
- (define (?name . _)
- (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
-
-(define (chown loc . _)
- (error loc (##core#immutable '"this function is not available on this platform")))
-
(define-unimplemented change-directory*)
(define-unimplemented create-fifo)
(define-unimplemented create-session)
diff --git a/types.db b/types.db
index 2095b9c7..07258c46 100644
--- a/types.db
+++ b/types.db
@@ -1929,7 +1929,7 @@
(chicken.posix#close-output-pipe (#(procedure #:clean #:enforce) chicken.posix#close-output-pipe (output-port) fixnum))
(chicken.posix#create-directory (#(procedure #:clean #:enforce) chicken.posix#create-directory (string #!optional *) string))
(chicken.posix#create-fifo (#(procedure #:clean #:enforce) chicken.posix#create-fifo (string #!optional fixnum) undefined))
-(chicken.posix#create-pipe (procedure chicken.posix#create-pipe () fixnum fixnum))
+(chicken.posix#create-pipe (procedure chicken.posix#create-pipe (#!optional fixnum) fixnum fixnum))
(chicken.posix#create-session (#(procedure #:clean) chicken.posix#create-session () fixnum))
(chicken.posix#create-symbolic-link (#(procedure #:clean #:enforce) chicken.posix#create-symbolic-link (string string) undefined))
@@ -1998,6 +1998,7 @@
(chicken.posix#open/excl fixnum)
(chicken.posix#open/fsync fixnum)
(chicken.posix#open/noctty fixnum)
+(chicken.posix#open/noinherit fixnum)
(chicken.posix#open/nonblock fixnum)
(chicken.posix#open/rdonly fixnum)
(chicken.posix#open/rdwr fixnum)
@@ -2025,17 +2026,19 @@
(chicken.posix#perm/ixusr fixnum)
(chicken.posix#pipe/buf fixnum)
(chicken.posix#port->fileno (#(procedure #:clean #:enforce) chicken.posix#port->fileno (port) fixnum))
-(chicken.posix#process (#(procedure #:clean #:enforce) chicken.posix#process (string #!optional (list-of string) (list-of (pair string string))) input-port output-port fixnum))
-(chicken.posix#process* (#(procedure #:clean #:enforce) chicken.posix#process* (string #!optional (list-of string) (list-of (pair string string))) input-port output-port fixnum *))
+(chicken.posix#process (#(procedure #:clean #:enforce) chicken.posix#process (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum))
+(chicken.posix#process* (#(procedure #:clean #:enforce) chicken.posix#process* (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum *))
(chicken.posix#process-execute
- (#(procedure #:clean #:enforce) chicken.posix#process-execute (string #!optional (list-of string) (list-of (pair string string))) noreturn))
+ (#(procedure #:clean #:enforce) chicken.posix#process-execute (string #!optional (list-of string) (list-of (pair string string)) fixnum) noreturn))
(chicken.posix#process-fork (#(procedure #:enforce) chicken.posix#process-fork (#!optional (or (procedure () . *) false) *) fixnum))
(chicken.posix#process-group-id (#(procedure #:clean #:enforce) chicken.posix#process-group-id () fixnum))
(chicken.posix#process-run (#(procedure #:clean #:enforce) chicken.posix#process-run (string #!optional (list-of string)) fixnum))
(chicken.posix#process-signal (#(procedure #:clean #:enforce) chicken.posix#process-signal (fixnum #!optional fixnum) undefined))
+(chicken.posix#process-spawn
+ (#(procedure #:clean #:enforce) chicken.posix#process-spawn (fixnum string #!optional (list-of string) (list-of (pair string string)) boolean) fixnum))
(chicken.posix#process-wait (#(procedure #:clean #:enforce) chicken.posix#process-wait (#!optional fixnum *) fixnum fixnum fixnum))
(chicken.posix#read-symbolic-link (#(procedure #:clean #:enforce) chicken.posix#read-symbolic-link (string #!optional boolean) string))
(chicken.posix#regular-file? (#(procedure #:clean #:enforce) chicken.posix#regular-file? ((or string fixnum)) boolean))
@@ -2088,6 +2091,11 @@
(chicken.posix#signal/xcpu fixnum)
(chicken.posix#signal/xfsz fixnum)
(chicken.posix#signals-list list)
+(chicken.posix#spawn/overlay fixnum)
+(chicken.posix#spawn/wait fixnum)
+(chicken.posix#spawn/nowait fixnum)
+(chicken.posix#spawn/nowaito fixnum)
+(chicken.posix#spawn/detach fixnum)
(chicken.posix#process-sleep (#(procedure #:clean #:enforce) chicken.posix#process-sleep (fixnum) fixnum))
(chicken.posix#block-device? (#(procedure #:clean #:enforce) chicken.posix#block-device? ((or string fixnum)) boolean))
(chicken.posix#character-device? (#(procedure #:clean #:enforce) chicken.posix#character-device? ((or string fixnum)) boolean))
Trap