From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Mar 2006 20:29:34 +0000 (+0000)
Subject: Add optional ERROR? argument to URI->PATHNAME.
X-Git-Tag: 20090517-FFI~1072
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2068127e162d500777169865244234d4b93113fe;p=mit-scheme.git

Add optional ERROR? argument to URI->PATHNAME.
---

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index aabd723b3..271ccfe35 100644
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.45 2006/03/07 20:22:45 cph Exp $
+$Id: pathnm.scm,v 14.46 2006/03/07 20:29:34 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
@@ -326,10 +326,9 @@ these rules:
 	      #f
 	      #f)))
 
-(define (uri->pathname uri)
-  (let ((uri (->uri uri 'URI->PATHNAME))
+(define (uri->pathname uri #!optional error?)
+  (let ((uri (->uri uri (and error? 'URI->PATHNAME)))
 	(defaults *default-pathname-defaults*)
-	(lose (lambda () (error:bad-range-argument uri 'URI->PATHNAME)))
 	(finish
 	 (lambda (device path keyword)
 	   (receive (directory name type)
@@ -343,36 +342,35 @@ these rules:
 				   (pathname-name pn)
 				   (pathname-type pn)))))
 		   (values (list keyword) #f #f))
-	     (make-pathname #f
-			    device
-			    directory
-			    name
-			    type
-			    #f)))))
+	     (make-pathname #f device directory name type #f)))))
     (let ((scheme (uri-scheme uri))
 	  (path
 	   (map (lambda (x)
 		  (if (string=? x "*")
 		      'WILD
 		      (utf8-string->string x)))
-		(uri-path uri))))
+		(uri-path uri)))
+	  (lose
+	   (lambda ()
+	     (if error? (error:bad-range-argument uri 'URI->PATHNAME))
+	     #f)))
       (case scheme
 	((file)
-	 (if (not (and (pair? path)
-		       (string-null? (car path))))
-	     (lose))
-	 (let ((path (cdr path)))
-	   (receive (device path)
-	       (let ((device (pathname-device defaults)))
-		 (if (and (pair? path)
-			  (not (missing-component? device)))
-		     (values (car path) (cdr path))
-		     (values device path)))
-	     (if (not (pair? path))
-		 (lose))
-	     (finish device path 'ABSOLUTE))))
+	 (if (and (pair? path)
+		  (string-null? (car path)))
+	     (let ((path (cdr path)))
+	       (receive (device path)
+		   (let ((device (pathname-device defaults)))
+		     (if (and (pair? path)
+			      (not (missing-component? device)))
+			 (values (car path) (cdr path))
+			 (values device path)))
+		 (if (pair? path)
+		     (finish device path 'ABSOLUTE)
+		     (lose))))
+	     (lose)))
 	((#f) (finish #f path 'RELATIVE))
-	(else (error:bad-range-argument uri 'URI->PATHNAME))))))
+	(else (lose))))))
 
 (define (missing-component? x)
   (or (not x)