From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Jul 2006 02:54:27 +0000 (+0000)
Subject: Fix typo in previous change.  Tweak interface to export a variable
X-Git-Tag: 20090517-FFI~973
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=90cde49076eec4d782a0eb5a31a43d32f659467f;p=mit-scheme.git

Fix typo in previous change.  Tweak interface to export a variable
with the default prefix registry, so that it can be dynamically bound.
---

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index e45abc96e..37ce27656 100644
--- a/v7/src/xml/rdf-struct.scm
+++ b/v7/src/xml/rdf-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rdf-struct.scm,v 1.11 2006/07/27 20:14:06 cph Exp $
+$Id: rdf-struct.scm,v 1.12 2006/07/28 02:54:20 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -139,7 +139,7 @@ USA.
       (->absolute-uri uri caller)))
 
 (define (write-rdf-uri uri port)
-  (let ((qname (uri->rdf-qname uri)))
+  (let ((qname (uri->rdf-qname uri #f)))
     (if qname
 	(write-string (symbol-name qname) port)
 	(write-rdf-uri-ref uri port))))
@@ -205,7 +205,7 @@ USA.
 					(registry-bindings registry))))))
   name)
 
-(define (uri->rdf-qname uri #!optional registry)
+(define (uri->rdf-qname uri #!optional error? registry)
   (let ((s (uri->string (->absolute-uri uri 'URI->RDF-QNAME))))
     (let ((p
 	   (find-matching-item
@@ -213,6 +213,8 @@ USA.
 		(check-registry registry 'URI->RDF-QNAME))
 	     (lambda (p)
 	       (string-prefix? (cdr p) s)))))
+      (if (and error? (not p))
+	  (error:bad-range-argument uri 'URI->RDF-QNAME))
       (and p
 	   (symbol (car p)
 		   (string-tail s (string-length (cdr p))))))))
@@ -225,7 +227,10 @@ USA.
     (if (and (interned-symbol? qname)
 	     (complete-match match-qname (symbol-name qname)))
 	(receive (prefix local) (split-qname qname)
-	  (let ((p (assq prefix (check-registry registry 'RDF-QNAME->URI))))
+	  (let ((p
+		 (assq prefix
+		       (registry-bindings
+			(check-registry registry 'RDF-QNAME->URI)))))
 	    (if p
 		(->absolute-uri (string-append (cdr p) local))
 		(maybe-lose))))
@@ -243,10 +248,10 @@ USA.
 	      (string-tail s i)))))
 
 (define match-qname
-  (*matcher (seq match:prefix-name ":" match:name)))
+  (*matcher (seq match-prefix match:name)))
 
 (define match-prefix
-  (*matcher (seq match:prefix-name ":")))
+  (*matcher (seq (? match:prefix-name) ":")))
 
 (define-record-type <rdf-prefix-registry>
     (make-rdf-prefix-registry bindings)
@@ -255,22 +260,28 @@ USA.
 
 (define-guarantee rdf-prefix-registry "RDF QName prefix registry")
 
+(define (rdf-prefix-registry->alist #!optional registry)
+  (alist-copy
+   (registry-bindings
+    (check-registry registry 'RDF-PREFIX-REGISTRY->ALIST))))
+
 (define (copy-rdf-prefix-registry #!optional registry)
   (make-rdf-prefix-registry
-   (registry-bindings (check-registry registry 'COPY-RDF-PREFIX-REGISTRY))))
+   (alist-copy
+    (registry-bindings (check-registry registry 'COPY-RDF-PREFIX-REGISTRY)))))
 
 (define (check-registry registry caller)
   (if (default-object? registry)
-      current-registry
+      (let ((registry *default-rdf-prefix-registry*))
+	(if (rdf-prefix-registry? registry)
+	    registry
+	    (begin
+	      (warn "*default-rdf-prefix-registry* has illegal value.")
+	      (new-rdf-prefix-registry))))
       (begin
 	(guarantee-rdf-prefix-registry registry caller)
 	registry)))
 
-(define (current-rdf-prefix-registry)
-  current-registry)
-
-(define current-registry)
-
 (define (new-rdf-prefix-registry)
   (make-rdf-prefix-registry (alist-copy default-prefixes)))
 
@@ -280,8 +291,5 @@ USA.
     (owl: . "http://www.w3.org/2002/07/owl#")
     (xsd: . "http://www.w3.org/2001/XMLSchema#")))
 
-(define (reset-rdf-prefixes)
-  (set! current-registry (new-rdf-prefix-registry))
-  unspecific)
-
-(reset-rdf-prefixes)
\ No newline at end of file
+(define *default-rdf-prefix-registry*
+  (new-rdf-prefix-registry))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index cc0399964..ce33aa781 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.75 2006/07/27 20:14:09 cph Exp $
+$Id: xml.pkg,v 1.76 2006/07/28 02:54:27 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -525,6 +525,7 @@ USA.
   (files "rdf-struct")
   (parent (runtime rdf))
   (export ()
+	  *default-rdf-prefix-registry*
 	  <rdf-bnode>
 	  <rdf-index>
 	  <rdf-literal>
@@ -536,7 +537,6 @@ USA.
 	  canonicalize-rdf-subject
 	  canonicalize-rdf-uri
 	  copy-rdf-prefix-registry
-	  current-rdf-prefix-registry
 	  error:not-rdf-bnode
 	  error:not-rdf-index
 	  error:not-rdf-literal
@@ -565,6 +565,7 @@ USA.
 	  rdf-literal-type
 	  rdf-literal=?
 	  rdf-literal?
+	  rdf-prefix-registry->alist
 	  rdf-prefix-registry?
 	  rdf-qname->uri
 	  rdf-qname?