From d911a182fd90c26caafb715950a23fc8d64a7232 Mon Sep 17 00:00:00 2001
From: "Henry M. Wu" <edu/mit/csail/zurich/mhwu>
Date: Thu, 28 May 1992 20:01:34 +0000
Subject: [PATCH] Fixed dos filename parsing to handle environment variables.

---
 v7/src/runtime/dospth.scm | 72 ++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 38 deletions(-)

diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index e845ed168..b88e77e35 100644
--- a/v7/src/runtime/dospth.scm
+++ b/v7/src/runtime/dospth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dospth.scm,v 1.4 1992/05/26 00:08:03 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dospth.scm,v 1.5 1992/05/28 20:01:34 mhwu Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -72,44 +72,40 @@ MIT in each case. |#
 (define (dos/parse-namestring string host)
   ;; The DOS file system is case-insensitive, and the canonical case
   ;; is upper, but it is too inconvenient to type.
-  (with-namestring-device-and-path (string-downcase string)
-    (lambda (device string)
-      (let ((components
-	     (let ((components (string-components string 
-                                                  sub-directory-delimiters)))
-	       (append (expand-directory-prefixes (car components))
-		       (cdr components)))))
-	(parse-name (car (last-pair components))
-          (lambda (name type)
-	    (%make-pathname host
-			    device
-			    (let ((components (except-last-pair components)))
-			      (and (not (null? components))
-				   (simplify-directory
-				    (if (string=? "" (car components))
-					(cons 'ABSOLUTE
-					      (map parse-directory-component
-						   (cdr components)))
-					(cons 'RELATIVE
-					      (map parse-directory-component
-						   components))))))
-			    name
-			    type
-			    'UNSPECIFIC)))))))
-
-(define (with-namestring-device-and-path string receiver)
-  (let ((colon (string-find-next-char string #\:)))
-    (cond ((not colon)
-	   (receiver false string))
-	  #|
-	  ;; CON:,  PRN:, etc. are valid devices.
-	  ((not (= colon 1))
-	   (error "dos/parse-namestring: Invalid drive name" string))
-	  |#
-	  (else
-	   (receiver (substring string 0 (1+ colon))
+  (let* ((string (string-downcase string))
+	 (components (string-components string sub-directory-delimiters)))
+    (with-namestring-device-and-path
+      (expand-directory-prefixes (car components))
+      (lambda (device directory-components)
+	(let ((components (append directory-components (cdr components))))
+	  (parse-name (car (last-pair components))
+            (lambda (name type)
+	      (%make-pathname host
+			      device
+			      (let ((components (except-last-pair components)))
+				(and (not (null? components))
+				     (simplify-directory
+				      (if (string=? "" (car components))
+					  (cons 'ABSOLUTE
+						(map parse-directory-component
+						     (cdr components)))
+					  (cons 'RELATIVE
+						(map parse-directory-component
+						     components))))))
+			      name
+			      type
+			      'UNSPECIFIC))))))))
+
+(define (with-namestring-device-and-path components receiver)
+  (let ((string (car components)))
+    (let ((colon (string-find-next-char string #\:)))
+      (if (not colon)
+	  (receiver false components)
+	  (receiver (substring string 0 (1+ colon))
+		    (cons 
 		     (substring string (1+ colon)
-				(string-length string)))))))
+				(string-length string))
+		     (cdr components)))))))
 
 (define (simplify-directory directory)
   (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory)))
-- 
2.25.1