Changes to get Win32 system working again.

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index ca1ffc8080205cd90066fa17e88846aa4800b1be..d894f4cf64196ecb6740f45f0ef157a72269c64f 100644 (file)
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: dos.scm,v 1.27 1995/09/13 23:00:53 cph Exp $
+;;;    $Id: dos.scm,v 1.28 1995/10/24 05:37:48 cph Exp $
 ;;;
 ;;;    Copyright (c) 1992-95 Massachusetts Institute of Technology
 ;;;
@@ -435,9 +435,93 @@ Includes the new backup.  Must be > 0."
 (define (os/hostname)
   (error "OS/HOSTNAME procedure unimplemented."))
 
-(define (os/interprogram-cut string)
+(define (os/interprogram-cut string push?)
   string push?
   unspecific)
 
 (define (os/interprogram-paste)
-  #f)
\ No newline at end of file
+  #f)
+
+(define (os/comint-filename-region start point end)
+  (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---"))
+    (let ((start (skip-chars-backward chars point start)))
+      (make-region start (skip-chars-forward chars start end)))))
+\f
+;;;; Subprocess/Shell Support
+
+(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/find-program program default-directory)
+  (or (dos/find-program program (ref-variable exec-path) default-directory)
+      (error "Can't find program:" (->namestring program))))
+
+(define (dos/find-program program exec-path default-directory)
+  (let* ((types dos/executable-suffixes)
+        (try
+         (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)))))))))))
+    (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 (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
+                             (merge-pathnames (car path)
+                                              default-directory)))
+                       (loop (cdr path))))))))))
+
+(define (os/shell-file-name)
+  (or (get-environment-variable "SHELL")
+      ;; Not sure if this is right for WinNT and/or Win95.
+      "command.com"))
+
+(define dos/executable-suffixes
+  ;; Not sure if there are other possibilities under WinNT and/or Win95.
+  '("exe" "com" "bat"))
+
+(define (os/form-shell-command command)
+  (list "/c" command))
+
+(define (os/shell-name pathname)
+  (if (member (pathname-type pathname) dos/executable-suffixes)
+      (pathname-name pathname)
+      (file-namestring pathname)))
+
+(define (os/default-shell-prompt-pattern)
+  "^\\[[^]]*] *")
+
+(define (os/default-shell-args)
+  '())
\ No newline at end of file

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 91a12acc99269398f30ccce506664e2651810a46..d15abc820eac61736799a59db8b72a75c2f2979f 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.179 1995/09/27 16:24:28 cph Exp $
+$Id: edwin.pkg,v 1.180 1995/10/24 05:38:04 cph Exp $
 
 Copyright (c) 1989-95 Massachusetts Institute of Technology
 
@@ -946,7 +946,7 @@ MIT in each case. |#
          run-synchronous-process))
 \f
 (os-type-case
- ((dos)
+ ((dos nt)
   (define-package (edwin dosjob)
     (files "doscom" "dosshell")
     (parent (edwin)))))

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index 672dc2cadd66176c6fc935c60354812e9c176d70..080eb1a8df5080fb68b2169945ba71a6a438ab5b 100644 (file)
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.31 1995/10/23 06:39:32 cph Exp $
+$Id: dosprm.scm,v 1.32 1995/10/24 05:39:49 cph Exp $
 
 Copyright (c) 1992-95 Massachusetts Institute of Technology
 
@@ -248,22 +248,25 @@ MIT in each case. |#
 
   unspecific)                          ; End LET
 \f
-(define (user-home-directory user-name)
-  (or (and user-name
-          (let ((directory (get-environment-variable "USERDIR")))
-            (and directory
-                 (pathname-new-name
-                  (pathname-as-directory (merge-pathnames directory))
-                  user-name))))
-      "\\"))
+(define (current-home-directory)
+  (let ((home (get-environment-variable "HOME")))
+    (if home
+       (pathname-as-directory (merge-pathnames home))
+       (user-home-directory (current-user-name)))))
 
 (define (current-user-name)
   (or (get-environment-variable "USER")
       "nouser"))
 
-(define (current-home-directory)
-  (or (get-environment-variable "HOME")
-      (user-home-directory (current-user-name))))
+(define (user-home-directory user-name)
+  (or (and user-name
+          (let ((directory (get-environment-variable "USERDIR")))
+            (and directory
+                 (pathname-as-directory
+                  (pathname-new-name
+                   (pathname-as-directory (merge-pathnames directory))
+                   user-name)))))
+      (merge-pathnames "\\")))
 
 (define file-time->string
   (ucode-primitive file-time->string 1))

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 3acee5c6b9d6f648258a770d32c019f0b6b2ca95..851ef03e9b3af84143f9c0fd1f53880ddb0174e9 100644 (file)
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.20 1995/10/23 06:52:09 cph Exp $
+$Id: os2prm.scm,v 1.21 1995/10/24 05:40:10 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -249,7 +249,7 @@ MIT in each case. |#
                   (pathname-new-name
                    (pathname-as-directory (merge-pathnames directory))
                    user-name)))))
-      "\\"))
+      (merge-pathnames "\\")))
 \f
 (define (os2/fs-drive-type pathname)
   (let ((type