From: Chris Hanson Date: Sat, 9 Mar 1991 21:33:43 +0000 (+0000) Subject: Subprocess support in this version requires microcode version 11.66 or X-Git-Tag: 20090517-FFI~10868 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=737683a305ed4b0b824b7f790e5856c8cb7316df;p=mit-scheme.git Subprocess support in this version requires microcode version 11.66 or later. * Subprocess abstraction changed to use microcode's new process status synchronization. The procedure `subprocess-status' causes the status information to be synchronized; subsequently `subprocess-exit-reason' returns the reason corresponding to that status. Likewise, the new procedure `subprocess-status-tick' returns an object representing the time-stamp associated with this status; when the status changes, the tick is changed to a new value. Ticks are unique objects that are comparable using `eq?'; they are not ordered. * New procedure `subprocess-remove!' removes a property from a subprocess (maybe this is a bad name?). --- diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index edfc5eb45..609294b91 100644 --- a/v7/src/runtime/process.scm +++ b/v7/src/runtime/process.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.8 1991/03/08 03:13:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.9 1991/03/09 21:33:31 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -53,17 +53,22 @@ MIT in each case. |# (list-copy subprocesses)) (define-structure (subprocess - (constructor %make-subprocess) + (constructor %make-subprocess + (filename arguments index pty-master + input-channel output-channel)) (conc-name subprocess-)) (filename false read-only true) (arguments false read-only true) index pty-master - (id false read-only true) input-channel output-channel - %input-port - %output-port + (id ((ucode-primitive process-id 1) index) read-only true) + (%input-port false) + (%output-port false) + (%status false) + (exit-reason false) + (%status-tick false) (properties (make-1d-table) read-only true)) (define (subprocess-get process key) @@ -72,6 +77,9 @@ MIT in each case. |# (define (subprocess-put! process key datum) (1d-table/put! (subprocess-properties process) key datum)) +(define (subprocess-remove! process key) + (1d-table/remove! (subprocess-properties process) key)) + (define (subprocess-input-port process) (without-interrupts (lambda () @@ -102,7 +110,7 @@ MIT in each case. |# (define (make-subprocess filename arguments environment ctty stdin stdout stderr pty-master input-channel output-channel) - (let ((index + (let ((process (let ((ctty-allowed? (string? ctty))) (define-integrable (convert-stdio-arg stdio) (cond ((not stdio) false) @@ -112,41 +120,45 @@ MIT in each case. |# (else (error:wrong-type-argument stdio "process I/O channel" 'MAKE-SUBPROCESS)))) - ((ucode-primitive make-subprocess 7) - filename arguments environment - (cond ((eq? ctty 'BACKGROUND) -1) - ((eq? ctty 'FOREGROUND) -2) - ((or (not ctty) (string? ctty)) ctty) - (else - (error:wrong-type-argument ctty - "process controlling terminal" - 'MAKE-SUBPROCESS))) - (convert-stdio-arg stdin) - (convert-stdio-arg stdout) - (convert-stdio-arg stderr))))) - (let ((process - (%make-subprocess index - pty-master - ((ucode-primitive process-id 1) index) - input-channel - output-channel - false - false))) - (set! subprocesses (cons process subprocesses)) - (if (eq? ctty 'FOREGROUND) - (do ((status - ((ucode-primitive process-status 1) index) - ((ucode-primitive process-continue-foreground 1) index))) - ((not (fix:= status 0))))) - process))) + (let ((ctty + (cond ((eq? ctty 'BACKGROUND) -1) + ((eq? ctty 'FOREGROUND) -2) + ((or (not ctty) (string? ctty)) ctty) + (else + (error:wrong-type-argument + ctty + "process controlling terminal" + 'MAKE-SUBPROCESS)))) + (stdin (convert-stdio-arg stdin)) + (stdout (convert-stdio-arg stdout)) + (stderr (convert-stdio-arg stderr))) + (without-interrupts + (lambda () + (let ((index + ((ucode-primitive make-subprocess 7) + filename arguments environment + ctty stdin stdout stderr))) + (let ((process + (%make-subprocess filename arguments index pty-master + input-channel output-channel))) + (set-subprocess-%status! + process + ((ucode-primitive process-status 1) index)) + (set-subprocess-exit-reason! + process + ((ucode-primitive process-reason 1) index)) + (set! subprocesses (cons process subprocesses)) + process)))))))) + (if (and (eq? ctty 'FOREGROUND) + (eqv? (%subprocess-status process) 0)) + (subprocess-continue-foreground process)) + process)) (define (subprocess-delete process) (without-interrupts (lambda () (if (subprocess-index process) (begin - ;; `process-delete' will signal an error if the process is - ;; running or stopped. ((ucode-primitive process-delete 1) (subprocess-index process)) (set! subprocesses (delq! process subprocesses)) (set-subprocess-index! process false) @@ -174,27 +186,47 @@ MIT in each case. |# (channel-close pty-master))))))))) (define (subprocess-status process) - (convert-subprocess-status - process - ((ucode-primitive process-status 1) (subprocess-index process)))) + (convert-subprocess-status (%subprocess-status process))) (define (subprocess-wait process) - (let ((index (subprocess-index process))) - (let loop () - (let ((status ((ucode-primitive process-wait 1) index))) - (case status - ((0) (loop)) - (else (convert-subprocess-status process status))))))) + (let loop () + ((ucode-primitive process-wait 1) (subprocess-index process)) + (let ((status (%subprocess-status process))) + (if (eqv? status 0) + (loop) + (convert-subprocess-status status))))) (define (subprocess-continue-foreground process) - (let ((index (subprocess-index process))) - (let loop () - (let ((status ((ucode-primitive process-continue-foreground 1) index))) - (case status - ((0) (loop)) - (else (convert-subprocess-status process status))))))) - -(define (convert-subprocess-status process status) + (let loop () + ((ucode-primitive process-continue-foreground 1) + (subprocess-index process)) + (let ((status (%subprocess-status process))) + (if (eqv? status 0) + (loop) + (convert-subprocess-status status))))) + +(define (%subprocess-status process) + (without-interrupts + (lambda () + (let ((index (subprocess-index process))) + (if ((ucode-primitive process-status-sync 1) index) + (begin + (set-subprocess-%status! + process + ((ucode-primitive process-status 1) index)) + (set-subprocess-exit-reason! + process + ((ucode-primitive process-reason 1) index)) + (set-subprocess-%status-tick! process false)))))) + (subprocess-%status process)) + +(define (subprocess-status-tick process) + (or (subprocess-%status-tick process) + (let ((tick (cons false false))) + (set-subprocess-%status-tick! process tick) + tick))) + +(define (convert-subprocess-status status) (case status ((0) 'RUNNING) ((1) 'STOPPED) @@ -202,9 +234,6 @@ MIT in each case. |# ((3) 'SIGNALLED) (else (error "Illegal process status:" status)))) -(define (subprocess-exit-reason process) - ((ucode-primitive process-reason 1) (subprocess-index process))) - (define (subprocess-job-control-status process) (let ((n ((ucode-primitive process-job-control-status 1) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index ebb85e330..cf1323ee1 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.95 1991/03/08 03:13:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.96 1991/03/09 21:33:36 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -1955,8 +1955,10 @@ MIT in each case. |# subprocess-pty-master subprocess-put! subprocess-quit + subprocess-remove! subprocess-signal subprocess-status + subprocess-status-tick subprocess-stop subprocess-wait subprocess?) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 84210e203..cbcef9adf 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.109 1991/03/06 05:14:50 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.110 1991/03/09 21:33:43 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 109)) + (add-identification! "Runtime" 14 110)) (define microcode-system) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 5c52436ec..db67c06d5 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.95 1991/03/08 03:13:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.96 1991/03/09 21:33:36 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -1955,8 +1955,10 @@ MIT in each case. |# subprocess-pty-master subprocess-put! subprocess-quit + subprocess-remove! subprocess-signal subprocess-status + subprocess-status-tick subprocess-stop subprocess-wait subprocess?)