From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Oct 1995 05:40:10 +0000 (+0000)
Subject: Changes to get Win32 system working again.
X-Git-Tag: 20090517-FFI~5870
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9bd21059b114486b1872367c8ce557f6aa92f559;p=mit-scheme.git

Changes to get Win32 system working again.
---

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index ca1ffc808..d894f4cf6 100644
--- 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)))))
+
+;;;; 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 91a12acc9..d15abc820 100644
--- 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))
 
 (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 672dc2cad..080eb1a8d 100644
--- 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
 
-(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 3acee5c6b..851ef03e9 100644
--- 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 "\\")))
 
 (define (os2/fs-drive-type pathname)
   (let ((type