From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 15 Jan 2011 04:36:39 +0000 (+0000)
Subject: Check URI record arguments more carefully in ->MUMBLE-URI.
X-Git-Tag: 20110426-Gtk~15
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=562020fdf80823b5825ad901e208b10a4d3b058b;p=mit-scheme.git

Check URI record arguments more carefully in ->MUMBLE-URI.

->ABSOLUTE-URI would formerly accept URI records representing
relative references, even though it would reject their string
representations.  Now it rejects both.
---

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index 667907a0d..a5d1f79c9 100644
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -317,15 +317,15 @@ USA.
 ;;;; Parser
 
 (define (->uri object #!optional caller)
-  (%->uri object parse-uri caller))
+  (%->uri object parse-uri (lambda (uri) uri #t) caller))
 
 (define (->absolute-uri object #!optional caller)
-  (%->uri object parse-absolute-uri caller))
+  (%->uri object parse-absolute-uri uri-absolute? caller))
 
 (define (->relative-uri object #!optional caller)
-  (%->uri object parse-relative-uri caller))
+  (%->uri object parse-relative-uri uri-relative? caller))
 
-(define (%->uri object parser caller)
+(define (%->uri object parser predicate caller)
   ;; Kludge: take advantage of fact that (NOT (NOT #!DEFAULT)).
   (let* ((do-parse
 	  (lambda (string)
@@ -340,7 +340,11 @@ USA.
 	    (or (hash-table/get interned-uris string #f)
 		(do-parse (utf8-string->wide-string string))))))
     (cond ((uri? object)
-	   object)
+	   (if (predicate object)
+	       object
+	       (begin
+		 (if caller (error:bad-range-argument object caller))
+		 #f)))
 	  ((string? object)
 	   (do-string object))
 	  ((symbol? object)
@@ -352,7 +356,7 @@ USA.
 	  (else
 	   (if caller (error:not-uri object caller))
 	   #f))))
-
+
 (define (string->uri string #!optional start end)
   (%string->uri parse-uri string start end 'STRING->URI))