#| -*- 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
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)
#| -*-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
(channel-descriptor-for-select (tty-input-channel)))
unspecific)
\f
+;;;; Subprocess/Shell Support
+
(define nt/hide-subprocess-windows?)
(define nt/subprocess-argument-quote-char)
(define nt/subprocess-argument-escape-char)
(loop (do-arg index (car strings) (car analyses))
(cdr strings)
(cdr analyses))))
- result)))
\ No newline at end of file
+ result)))
+\f
+(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))
+\f
+(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
#| -*-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
(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")
))
#| -*-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
(define os2/select-result-values
'#(INPUT-AVAILABLE #F INTERRUPT PROCESS-STATUS-CHANGE))
\f
+;;;; Subprocess/Shell Support
+
(define (os/make-subprocess filename arguments environment working-directory
ctty stdin stdout stderr)
(if ctty
(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))
+\f
+(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
#| -*-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
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 ())
#| -*-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
(else
(set-car! rv v))))
(set-interrupt-enables! interrupt-mask)))
+\f
+;;;; 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
#| -*-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
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 ())
projects / mit-scheme.git / commitdiff