Intern URIs so that equality can be tested using EQ?.

diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm
index b0797939b5c6e8bda6b5f538ee530dd9b3442f6e..00fab92122caf5d3e0159564eba6746d9963ff0c 100644 (file)
--- a/v7/src/runtime/url.scm
+++ b/v7/src/runtime/url.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: url.scm,v 1.38 2006/01/31 06:47:47 cph Exp $
+$Id: url.scm,v 1.39 2006/01/31 17:58:54 cph Exp $
 
 Copyright 2000,2001,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -31,19 +31,20 @@ USA.
 (declare (usual-integrations))
 \f
 (define-record-type <uri>
-    (%make-uri scheme authority path query fragment)
+    (%%make-uri scheme authority path query fragment string)
     uri?
-  (scheme uri-scheme set-uri-scheme!)
+  (scheme uri-scheme)
   (authority uri-authority)
   (path uri-path)
   (query uri-query)
-  (fragment uri-fragment set-uri-fragment!))
+  (fragment uri-fragment)
+  (string uri-string))
 
 (set-record-type-unparser-method! <uri>
   (standard-unparser-method 'URI
     (lambda (uri port)
       (write-char #\space port)
-      (write (uri->string uri) port))))
+      (write (uri-string uri) port))))
 
 (define (make-uri scheme authority path query fragment)
   (let ((path (if (equal? path '("")) '() path)))
@@ -62,6 +63,17 @@ USA.
               query
               fragment)))
 
+(define (%make-uri scheme authority path query fragment)
+  (let ((string
+        (call-with-output-string
+          (lambda (port)
+            (%write-uri scheme authority path query fragment port)))))
+    (hash-table/intern! interned-uris string
+      (lambda ()
+       (%%make-uri scheme authority path query fragment string)))))
+
+(define interned-uris)
+
 (define (absolute-uri? object)
   (and (uri? object)
        (uri-absolute? object)))
@@ -110,7 +122,7 @@ USA.
   (not (path-absolute? path)))
 
 (define-record-type <uri-authority>
-    (%make-uri-authority userinfo host port)
+    (%%make-uri-authority userinfo host port)
     uri-authority?
   (userinfo uri-authority-userinfo)
   (host uri-authority-host)
@@ -120,7 +132,10 @@ USA.
   (standard-unparser-method 'URI-AUTHORITY
     (lambda (authority port)
       (write-char #\space port)
-      (write-authority authority port))))
+      (write (call-with-output-string
+              (lambda (port)
+                (write-authority authority port)))
+            port))))
 
 (define (make-uri-authority userinfo host port)
   (if userinfo (guarantee-uri-userinfo userinfo 'MAKE-URI-AUTHORITY))
@@ -128,6 +143,16 @@ USA.
   (if port (guarantee-uri-port port 'MAKE-URI-AUTHORITY))
   (%make-uri-authority userinfo host port))
 
+(define (%make-uri-authority userinfo host port)
+  (hash-table/intern! interned-uri-authorities
+      (call-with-output-string
+       (lambda (output)
+         (%write-authority userinfo host port output)))
+    (lambda ()
+      (%%make-uri-authority userinfo host port))))
+
+(define interned-uri-authorities)
+\f
 (define (uri-userinfo? object)
   (and (string? object)
        (complete-match parser:userinfo object)))
@@ -150,37 +175,15 @@ USA.
   (let ((buffer (string->parser-buffer string start end)))
     (and (matcher buffer)
         (not (peek-parser-buffer-char buffer)))))
-\f
+
 (define (uri=? u1 u2)
-  (let ((u1 (->uri u1 'URI=?))
-       (u2 (->uri u2 'URI=?)))
-    (and (eq? (uri-scheme u1) (uri-scheme u2))
-        (%component=? %uri-authority=? (uri-authority u1) (uri-authority u2))
-        (let loop ((p1 (uri-path u1)) (p2 (uri-path u2)))
-          (if (pair? p1)
-              (and (pair? p2)
-                   (string=? (car p1) (car p2))
-                   (loop (cdr p1) (cdr p2)))
-              (null? p2)))
-        (%component=? string=? (uri-query u1) (uri-query u2))
-        (%component=? string=? (uri-fragment u1) (uri-fragment u2)))))
+  (eq? (->uri u1 'URI=?)
+       (->uri u2 'URI=?)))
 
 (define (uri-authority=? a1 a2)
   (guarantee-uri-authority a1 'URI-AUTHORITY=?)
   (guarantee-uri-authority a2 'URI-AUTHORITY=?)
-  (%uri-authority=? a1 a2))
-
-(define (%uri-authority=? a1 a2)
-  (and (%component=? string=?
-                    (uri-authority-userinfo a1)
-                    (uri-authority-userinfo a2))
-       (string=? (uri-authority-host a1) (uri-authority-host a2))
-       (%component=? = (uri-authority-port a1) (uri-authority-port a2))))
-
-(define (%component=? predicate x1 x2)
-  (if x1
-      (and x2 (predicate x1 x2))
-      (not x2)))
+  (eq? a1 a2))
 
 (define (uri->alist uri)
   `(,@(if (uri-scheme uri)
@@ -297,15 +300,19 @@ USA.
    (lambda (form environment)
      environment
      (if (syntax-match? '(SYMBOL) (cdr form))
-        (let* ((root (cadr form)))
+        (let* ((root (cadr form))
+               (parser (symbol 'PARSE- root)))
           `(DEFINE (,(symbol '-> root) OBJECT #!OPTIONAL CALLER)
-             (IF (,(symbol root '?) OBJECT)
-                 OBJECT
-                 (OR (COMPLETE-PARSE
-                      ,(symbol 'PARSE- root)
-                      (OR (->PARSER-BUFFER OBJECT)
-                          (,(symbol 'ERROR:NOT- root) OBJECT CALLER)))
-                     (ERROR:BAD-RANGE-ARGUMENT OBJECT CALLER)))))
+             (COND ((,(symbol root '?) OBJECT)
+                    OBJECT)
+                   ((STRING? OBJECT)
+                    (%STRING->URI ,parser OBJECT #!DEFAULT #!DEFAULT CALLER))
+                   (ELSE
+                    (OR (COMPLETE-PARSE
+                         ,parser
+                         (OR (->PARSER-BUFFER OBJECT)
+                             (,(symbol 'ERROR:NOT- root) OBJECT CALLER)))
+                        (ERROR:BAD-RANGE-ARGUMENT OBJECT CALLER))))))
         (ill-formed-syntax form)))))
 
 (define-uri-coercion uri)
@@ -329,7 +336,11 @@ USA.
   (%string->uri parse-relative-uri string start end 'STRING->RELATIVE-URI))
 
 (define (%string->uri parser string start end caller)
-  (or (complete-parse parser (string->parser-buffer string start end))
+  (or (and (string? string)
+          (default-object? start)
+          (default-object? end)
+          (hash-table/get interned-uris string #f))
+      (complete-parse parser (string->parser-buffer string start end))
       (error:bad-range-argument string caller)))
 
 (define (complete-parse parser buffer)
@@ -541,61 +552,58 @@ USA.
 ;;;; Output
 
 (define (uri->string uri)
-  (guarantee-uri uri 'URI->STRING)
-  (call-with-output-string
-    (lambda (port)
-      (%write-uri uri port))))
+  (uri-string (->uri uri 'URI->STRING)))
 
 (define (uri->symbol uri)
   (utf8-string->symbol (uri->string uri)))
 
 (define (write-uri uri port)
-  (guarantee-uri uri 'WRITE-URI)
   (guarantee-port port 'WRITE-URI)
-  (%write-uri uri port))
+  (write-string (uri-string (->uri uri 'WRITE-URI)) port))
 
-(define (%write-uri uri port)
-  (if (uri-scheme uri)
+(define (%write-uri scheme authority path query fragment port)
+  (if scheme
       (begin
-       (write (uri-scheme uri) port)
+       (write scheme port)
        (write-char #\: port)))
-  (if (uri-authority uri)
-      (write-authority (uri-authority uri) port))
-  (let ((path (uri-path uri)))
-    (if (pair? path)
-       (begin
-         (if (uri-scheme uri)
-             (write-segment (car path) port)
-             (write-encoded (car path) char-set:uri-segment-nc port))
-         (for-each (lambda (segment)
-                     (write-char #\/ port)
-                     (write-segment segment port))
-                   (cdr path)))))
-  (if (uri-query uri)
+  (if authority
+      (write-authority authority port))
+  (if (pair? path)
+      (begin
+       (if scheme
+           (write-segment (car path) port)
+           (write-encoded (car path) char-set:uri-segment-nc port))
+       (for-each (lambda (segment)
+                   (write-char #\/ port)
+                   (write-segment segment port))
+                 (cdr path))))
+  (if query
       (begin
        (write-char #\? port)
-       (write-encoded (uri-query uri) char-set:uri-query port)))
-  (if (uri-fragment uri)
+       (write-encoded query char-set:uri-query port)))
+  (if fragment
       (begin
        (write-char #\# port)
-       (write-encoded (uri-fragment uri) char-set:uri-fragment port))))
+       (write-encoded fragment char-set:uri-fragment port))))
 
 (define (write-authority authority port)
-  (write-string "//" port)
-  (if (uri-authority-userinfo authority)
+  (%write-authority (uri-authority-userinfo authority)
+                   (uri-authority-host authority)
+                   (uri-authority-port authority)
+                   port))
+
+(define (%write-authority userinfo host port output)
+  (write-string "//" output)
+  (if userinfo
       (begin
-       (write-encoded (uri-authority-userinfo authority)
-                      char-set:uri-userinfo
-                      port)
-       (write-char #\@ port)))
-  (if (uri-authority-host authority)
-      (write-encoded (uri-authority-host authority)
-                    char-set:uri-opaque-auth
-                    port))
-  (if (uri-authority-port authority)
+       (write-encoded userinfo char-set:uri-userinfo output)
+       (write-char #\@ output)))
+  (if host
+      (write-encoded host char-set:uri-opaque-auth output))
+  (if port
       (begin
-       (write-char #\: port)
-       (write (uri-authority-port authority) port))))
+       (write-char #\: output)
+       (write port output))))
 
 (define (write-segment segment port)
   (write-encoded segment char-set:uri-segment port))
@@ -901,6 +909,9 @@ USA.
   (set! parser:query           (component-parser-* char-set:uri-query))
   (set! parser:fragment                (component-parser-* char-set:uri-fragment))
 
+  (set! interned-uris (make-string-hash-table))
+  (set! interned-uri-authorities (make-string-hash-table))
+
   ;; backwards compatibility:
   (set! url:char-set:unreserved
        (char-set-union char-set:uri-alpha