From 1389f239fe4dd23d11f66c19c73db6c71721d14b Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Wed, 30 Apr 2008 22:55:59 -0400 Subject: [PATCH] Added process-nonblocking which is like process but returns nonblocking ports. --- scheme/ikarus.io.ss | 34 ++++++++++++++++++++++++++++++++-- scheme/last-revision | 2 +- scheme/makefile.ss | 1 + 3 files changed, 34 insertions(+), 3 deletions(-) diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index f03f1e8..014f3b7 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -63,7 +63,7 @@ reset-output-port! port-id input-port-byte-position - process + process process-nonblocking tcp-connect tcp-connect-nonblocking udp-connect udp-connect-nonblocking @@ -125,7 +125,7 @@ reset-output-port! port-id input-port-byte-position - process + process process-nonblocking tcp-connect tcp-connect-nonblocking udp-connect udp-connect-nonblocking tcp-server-socket tcp-server-socket-nonblocking @@ -2127,6 +2127,36 @@ cmd input-file-buffer-size #f #t 'process))))) + + (define (process-nonblocking cmd . args) + (define who 'process-nonblocking) + (unless (string? cmd) + (die who "command is not a string" cmd)) + (unless (andmap string? args) + (die who "all arguments must be strings")) + (let ([r (foreign-call "ikrt_process" + (make-vector 4) + (string->utf8 cmd) + (map string->utf8 (cons cmd args)))]) + (if (fixnum? r) + (io-error who cmd r) + (begin + (set-fd-nonblocking (vector-ref r 1) who cmd) + (set-fd-nonblocking (vector-ref r 2) who cmd) + (set-fd-nonblocking (vector-ref r 3) who cmd) + (values + (vector-ref r 0) ; pid + (fh->output-port (vector-ref r 1) + cmd output-file-buffer-size #f #t + 'process) + (fh->input-port (vector-ref r 2) + cmd input-file-buffer-size #f #t + 'process) + (fh->input-port (vector-ref r 3) + cmd input-file-buffer-size #f #t + 'process)))))) + + (define (set-fd-nonblocking fd who id) (let ([rv (foreign-call "ikrt_make_fd_nonblocking" fd)]) (unless (eq? rv 0) diff --git a/scheme/last-revision b/scheme/last-revision index 471d548..107359c 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1456 +1457 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 0a7d346..7749a59 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -403,6 +403,7 @@ [pointer-value i] [system i] [process i] + [process-nonblocking i] [waitpid i] [installed-libraries i] [library-path i]