From: Chris Hanson Date: Fri, 29 Jan 1999 22:47:14 +0000 (+0000) Subject: Add support for running synchronous subprocesses outside of Edwin. X-Git-Tag: 20090517-FFI~4662 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=61058192a0bd146bfa66ce70baec074a8f58ade3;p=mit-scheme.git Add support for running synchronous subprocesses outside of Edwin. --- diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 2b8fcb6c3..9e2599919 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*- Scheme -*- -$Id: ed-ffi.scm,v 1.18 1999/01/02 06:11:34 cph Exp $ +$Id: ed-ffi.scm,v 1.19 1999/01/29 22:46:52 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -241,6 +241,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. syntax-table/system-internal) ("symbol" () syntax-table/system-internal) + ("syncproc" (runtime synchronous-subprocess) + syntax-table/system-internal) ("syntab" (runtime syntax-table) syntax-table/system-internal) ("syntax" (runtime syntaxer) diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index 7ed4c8c4f..d4c1b15b9 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.25 1999/01/02 06:11:34 cph Exp $ +$Id: ntprm.scm,v 1.26 1999/01/29 22:46:39 cph Exp $ Copyright (c) 1992-1999 Massachusetts Institute of Technology @@ -522,6 +522,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (channel-descriptor-for-select (tty-input-channel))) unspecific) +;;;; Subprocess/Shell Support + (define nt/hide-subprocess-windows?) (define nt/subprocess-argument-quote-char) (define nt/subprocess-argument-escape-char) @@ -651,4 +653,112 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (loop (do-arg index (car strings) (car analyses)) (cdr strings) (cdr analyses)))) - result))) \ No newline at end of file + result))) + +(define (os/find-program program default-directory #!optional error? exec-path) + (let ((namestring + (let* ((exec-path + (if (default-object? exec-path) + (os/exec-path) + exec-path)) + (try + (let ((types (os/executable-pathname-types))) + (lambda (pathname) + (let ((type (pathname-type pathname))) + (if type + (and (member type types) + (file-exists? pathname) + (->namestring pathname)) + (let loop ((types types)) + (and (not (null? types)) + (let ((p + (pathname-new-type pathname + (car types)))) + (if (file-exists? p) + (->namestring p) + (loop (cdr types))))))))))) + (try-dir + (lambda (directory) + (try (merge-pathnames program directory))))) + (if (pathname-absolute? program) + (try program) + (or (let ((ns (nt/scheme-executable-pathname))) + (and ns + (try-dir (directory-pathname ns)))) + (if (not default-directory) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (and (pathname-absolute? (car path)) + (try-dir (car path))) + (loop (cdr path))))) + (let ((default-directory + (merge-pathnames default-directory))) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (try-dir + (merge-pathnames (car path) + default-directory)) + (loop (cdr path)))))))))))) + (if (and (not namestring) + (if (default-object? error) #t error?)) + (error "Can't find program:" (->namestring program))) + namestring)) + +(define (os/exec-path) + (os/parse-path-string + (let ((path (get-environment-variable "PATH"))) + (if (not path) + (error "Can't find PATH environment variable.")) + path))) + +(define (os/parse-path-string string) + (let ((end (string-length string)) + (substring + (lambda (string start end) + (pathname-as-directory (substring string start end))))) + (let loop ((start 0)) + (if (< start end) + (let ((index (substring-find-next-char string start end #\;))) + (if index + (if (= index start) + (loop (+ index 1)) + (cons (substring string start index) + (loop (+ index 1)))) + (list (substring string start end)))) + '())))) + +(define (nt/scheme-executable-pathname) + (let ((env (->environment '(win32)))) + (let ((handle + ((access get-module-handle env) + (file-namestring + (pathname-default-type + ((make-primitive-procedure 'SCHEME-PROGRAM-NAME)) + "exe")))) + (buf (make-string 256))) + (substring buf 0 ((access get-module-file-name env) handle buf 256))))) + +(define (os/shell-file-name) + (or (get-environment-variable "SHELL") + (get-environment-variable "COMSPEC") + (if (eq? 'WINNT (nt/windows-type)) + "cmd.exe" + "command.com"))) + +(define (nt/windows-type) + (cond ((string-prefix? "Microsoft Windows NT" + microcode-id/operating-system-variant) + 'WINNT) + ((string-prefix? "Microsoft Windows 9" + microcode-id/operating-system-variant) + 'WIN9X) + ((string-prefix? "Microsoft Windows" + microcode-id/operating-system-variant) + 'WIN3X) + (else #f))) + +(define (os/form-shell-command command) + (list "/c" command)) + +(define (os/executable-pathname-types) + '("exe" "com" "bat" "btm")) \ No newline at end of file diff --git a/v7/src/runtime/optiondb.scm b/v7/src/runtime/optiondb.scm index ef464fc71..050385ee0 100644 --- a/v7/src/runtime/optiondb.scm +++ b/v7/src/runtime/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: optiondb.scm,v 1.5 1999/01/02 06:11:34 cph Exp $ +$Id: optiondb.scm,v 1.6 1999/01/29 22:47:08 cph Exp $ Copyright (c) 1994-1999 Massachusetts Institute of Technology @@ -66,6 +66,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (RB-TREE (RUNTIME RB-TREE) #F "rbtree") (STEPPER (RUNTIME STEPPER) #F "ystep") (SUBPROCESS (RUNTIME SUBPROCESS) (INITIALIZE-PACKAGE!) "process") + (SYNCHRONOUS-SUBPROCESS (RUNTIME SYNCHRONOUS-SUBPROCESS) #F "syncproc") (WT-TREE (RUNTIME WT-TREE) #F "wttree") )) diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm index eec061187..642f93172 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.38 1999/01/02 06:11:34 cph Exp $ +$Id: os2prm.scm,v 1.39 1999/01/29 22:46:46 cph Exp $ Copyright (c) 1994-1999 Massachusetts Institute of Technology @@ -464,6 +464,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define os2/select-result-values '#(INPUT-AVAILABLE #F INTERRUPT PROCESS-STATUS-CHANGE)) +;;;; Subprocess/Shell Support + (define (os/make-subprocess filename arguments environment working-directory ctty stdin stdout stderr) (if ctty @@ -513,4 +515,84 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (substring-move-left! (car strings) 0 n result index) (string-set! result (fix:+ index n) #\NUL) (loop (cdr strings) (fix:+ (fix:+ index n) 1))))) - result)) \ No newline at end of file + result)) + +(define (os/find-program program default-directory #!optional error? exec-path) + (let ((namestring + (let* ((exec-path + (if (default-object? exec-path) + (os/exec-path) + exec-path)) + (try + (let ((types (os/executable-pathname-types))) + (lambda (pathname) + (let ((type (pathname-type pathname))) + (if type + (and (member type types) + (file-exists? pathname) + (->namestring pathname)) + (let loop ((types types)) + (and (not (null? types)) + (let ((p + (pathname-new-type pathname + (car types)))) + (if (file-exists? p) + (->namestring p) + (loop (cdr types))))))))))) + (try-dir + (lambda (directory) + (try (merge-pathnames program directory))))) + (cond ((pathname-absolute? program) + (try program)) + ((not default-directory) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (and (pathname-absolute? (car path)) + (try-dir (car path))) + (loop (cdr path)))))) + (else + (let ((default-directory + (merge-pathnames default-directory))) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (try-dir + (merge-pathnames (car path) default-directory)) + (loop (cdr path))))))))))) + (if (and (not namestring) + (if (default-object? error) #t error?)) + (error "Can't find program:" (->namestring program))) + namestring)) + +(define (os/exec-path) + (os/parse-path-string + (let ((path (get-environment-variable "PATH"))) + (if (not path) + (error "Can't find PATH environment variable.")) + path))) + +(define (os/parse-path-string string) + (let ((end (string-length string)) + (substring + (lambda (string start end) + (pathname-as-directory (substring string start end))))) + (let loop ((start 0)) + (if (< start end) + (let ((index (substring-find-next-char string start end #\;))) + (if index + (if (= index start) + (loop (+ index 1)) + (cons (substring string start index) + (loop (+ index 1)))) + (list (substring string start end)))) + '())))) + +(define (os/shell-file-name) + (or (get-environment-variable "SHELL") + (get-environment-variable "COMSPEC") + "cmd.exe")) + +(define (os/form-shell-command command) + (list "/c" command)) + +(define (os/executable-pathname-types) + '("exe" "com" "bat" "btm")) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 8db411506..78f4789a0 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.300 1999/01/02 06:06:43 cph Exp $ +$Id: runtime.pkg,v 14.301 1999/01/29 22:46:34 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -2322,6 +2322,20 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. handle-subprocess-status-change) (initialization (initialize-package!))) +(define-package (runtime synchronous-subprocess) + (file-case options + ((load) "syncproc") + (else)) + (parent ()) + (export () + condition-type:subprocess-abnormal-termination + condition-type:subprocess-exited + condition-type:subprocess-signalled + condition-type:subprocess-stopped + make-subprocess-context + run-shell-command + run-synchronous-process)) + (define-package (runtime graphics) (files "graphics") (parent ()) diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index ee7e1ccca..c4ed54b5a 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unxprm.scm,v 1.51 1999/01/02 06:19:10 cph Exp $ +$Id: unxprm.scm,v 1.52 1999/01/29 22:47:14 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -453,9 +453,80 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (else (set-car! rv v)))) (set-interrupt-enables! interrupt-mask))) + +;;;; Subprocess/Shell Support (define (os/make-subprocess filename arguments environment working-directory ctty stdin stdout stderr) ((ucode-primitive ux-make-subprocess 8) filename arguments environment working-directory - ctty stdin stdout stderr)) \ No newline at end of file + ctty stdin stdout stderr)) + +(define (os/find-program program default-directory #!optional error? exec-path) + (let ((namestring + (let ((exec-path + (if (default-object? exec-path) + (os/exec-path) + exec-path))) + (let ((try + (lambda (pathname) + (and (file-access pathname 1) + (->namestring pathname))))) + (cond ((pathname-absolute? program) + (try program)) + ((not default-directory) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (and (car path) + (pathname-absolute? (car path)) + (try (merge-pathnames program (car path)))) + (loop (cdr path)))))) + (else + (let ((default-directory + (merge-pathnames default-directory))) + (let loop ((path exec-path)) + (and (not (null? path)) + (or (try (merge-pathnames + program + (if (car path) + (merge-pathnames (car path) + default-directory) + default-directory))) + (loop (cdr path)))))))))))) + (if (and (not namestring) + (if (default-object? error) #t error?)) + (error "Can't find program:" (->namestring program))) + namestring)) + +(define (os/exec-path) + (os/parse-path-string + (let ((path (get-environment-variable "PATH"))) + (if (not path) + (error "Can't find PATH environment variable.")) + path))) + +(define (os/parse-path-string string) + (let ((end (string-length string)) + (substring + (lambda (string start end) + (pathname-as-directory (substring string start end))))) + (let loop ((start 0)) + (if (< start end) + (let ((index (substring-find-next-char string start end #\:))) + (if index + (cons (if (= index start) + false + (substring string start index)) + (loop (+ index 1))) + (list (substring string start end)))) + '())))) + +(define (os/shell-file-name) + (or (get-environment-variable "SHELL") + "/bin/sh")) + +(define (os/form-shell-command command) + (list "-c" command)) + +(define (os/executable-pathname-types) + '()) \ No newline at end of file diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 406cc37ba..074f42059 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.306 1999/01/02 06:11:34 cph Exp $ +$Id: runtime.pkg,v 14.307 1999/01/29 22:46:26 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -2326,6 +2326,20 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. handle-subprocess-status-change) (initialization (initialize-package!))) +(define-package (runtime synchronous-subprocess) + (file-case options + ((load) "syncproc") + (else)) + (parent ()) + (export () + condition-type:subprocess-abnormal-termination + condition-type:subprocess-exited + condition-type:subprocess-signalled + condition-type:subprocess-stopped + make-subprocess-context + run-shell-command + run-synchronous-process)) + (define-package (runtime graphics) (files "graphics") (parent ())