From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 11 Nov 1997 12:47:40 +0000 (+0000)
Subject: Reverse earlier decision: ignore errors that occur with "$" and "~"
X-Git-Tag: 20090517-FFI~4938
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a8414c098a59081ed041fd764ea02a6d4620b08;p=mit-scheme.git

Reverse earlier decision: ignore errors that occur with "$" and "~"
syntax in pathnames.
---

diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index e71d6bfe1..95cf9f32a 100644
--- a/v7/src/runtime/dospth.scm
+++ b/v7/src/runtime/dospth.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dospth.scm,v 1.36 1996/03/01 08:53:41 cph Exp $
+$Id: dospth.scm,v 1.37 1997/11/11 12:47:40 cph Exp $
 
-Copyright (c) 1992-96 Massachusetts Institute of Technology
+Copyright (c) 1992-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -117,24 +117,30 @@ MIT in each case. |#
 			 (except-last-pair head)
 			 head)
 		     (cdr components))))))
-    (if (or (string-null? string)
-	    (not *expand-directory-prefixes?*))
-	components
-	(case (string-ref string 0)
-	  ((#\$)
-	   (let ((name (string-tail string 1)))
-	     (let ((value (get-environment-variable name)))
-	       (if (not value)
-		   (error "Unbound environment variable:" name))
-	       (replace-head value))))
-	  ((#\~)
-	   (replace-head
-	    (->namestring
-	     (let ((user-name (string-tail string 1)))
-	       (if (string-null? user-name)
-		   (current-home-directory)
-		   (user-home-directory user-name))))))
-	  (else components)))))
+    (let ((end (string-length string)))
+      (if (or (= 0 end)
+	      (not *expand-directory-prefixes?*))
+	  components
+	  (case (string-ref string 0)
+	    ((#\$)
+	     (if (= 1 end)
+		 components
+		 (let ((value
+			(get-environment-variable (substring string 1 end))))
+		   (if (not value)
+		       components
+		       (replace-head value)))))
+	    ((#\~)
+	     (let ((expansion
+		    (ignore-errors
+		     (lambda ()
+		       (if (= 1 end)
+			   (current-home-directory)
+			   (user-home-directory (substring string 1 end)))))))
+	       (if (condition? expansion)
+		   components
+		   (replace-head (->namestring expansion)))))
+	    (else components))))))
 
 (define (parse-device-and-path components)
   (let ((string (car components)))
diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index 26c7132e3..2d2f00cfd 100644
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: unxpth.scm,v 14.23 1996/02/29 22:12:07 cph Exp $
+$Id: unxpth.scm,v 14.24 1997/11/11 12:45:49 cph Exp $
 
-Copyright (c) 1988-96 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -93,24 +93,30 @@ MIT in each case. |#
 			 (except-last-pair head)
 			 head)
 		     (cdr components))))))
-    (if (or (string-null? string)
-	    (not *expand-directory-prefixes?*))
-	components
-	(case (string-ref string 0)
-	  ((#\$)
-	   (let ((name (string-tail string 1)))
-	     (let ((value (get-environment-variable name)))
-	       (if (not value)
-		   (error "Unbound environment variable:" name))
-	       (replace-head value))))
-	  ((#\~)
-	   (replace-head
-	    (->namestring
-	     (let ((user-name (substring string 1 (string-length string))))
-	       (if (string-null? user-name)
-		   (current-home-directory)
-		   (user-home-directory user-name))))))
-	  (else components)))))
+    (let ((end (string-length string)))
+      (if (or (= 0 end)
+	      (not *expand-directory-prefixes?*))
+	  components
+	  (case (string-ref string 0)
+	    ((#\$)
+	     (if (= 1 end)
+		 components
+		 (let ((value
+			(get-environment-variable (substring string 1 end))))
+		   (if (not value)
+		       components
+		       (replace-head value)))))
+	    ((#\~)
+	     (let ((expansion
+		    (ignore-errors
+		     (lambda ()
+		       (if (= 1 end)
+			   (current-home-directory)
+			   (user-home-directory (substring string 1 end)))))))
+	       (if (condition? expansion)
+		   components
+		   (replace-head (->namestring expansion)))))
+	    (else components))))))
 
 (define (simplify-directory directory)
   (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory)))