From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 29 Oct 2006 06:18:03 +0000 (+0000)
Subject: Rename PORT/BNODE-REGISTRY and PORT/DROP-BNODE-REGISTRY and export
X-Git-Tag: 20090517-FFI~860
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bf72edeb5d7c12680f769762f55fe7cbc3cdf0b6;p=mit-scheme.git

Rename PORT/BNODE-REGISTRY and PORT/DROP-BNODE-REGISTRY and export
them to global environment.  Make analogous procedures for prefix
registries.  Add new procedure to merge one prefix registry into
another.
---

diff --git a/v7/src/xml/rdf-nt.scm b/v7/src/xml/rdf-nt.scm
index b9b4c2f5e..3b0a13371 100644
--- a/v7/src/xml/rdf-nt.scm
+++ b/v7/src/xml/rdf-nt.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rdf-nt.scm,v 1.9 2006/10/19 17:48:21 cph Exp $
+$Id: rdf-nt.scm,v 1.10 2006/10/29 06:17:49 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -51,10 +51,10 @@ USA.
 	    triple)))))
 
 (define (read-rdf/nt port)
-  (fluid-let ((*rdf-bnode-registry* (port/bnode-registry port)))
+  (fluid-let ((*rdf-bnode-registry* (port/rdf-bnode-registry port)))
     (let ((triple (%read-rdf/nt port)))
       (if (eof-object? triple)
-	  (port/drop-bnode-registry port))
+	  (port/drop-rdf-bnode-registry port))
       triple)))
 
 (define (%read-rdf/nt port)
diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index bd7bc0dfd..0b24af9b4 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.19 2006/10/29 05:23:59 cph Exp $
+$Id: rdf-struct.scm,v 1.20 2006/10/29 06:17:56 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -141,14 +141,14 @@ USA.
 (define *rdf-bnode-registry*
   (make-rdf-bnode-registry))
 
-(define (port/bnode-registry port)
-  (or (port/get-property port 'PORT/BNODE-REGISTRY #f)
-      (let ((table (make-string-hash-table)))
-	(port/set-property! port 'PORT/BNODE-REGISTRY table)
+(define (port/rdf-bnode-registry port)
+  (or (port/get-property port 'RDF-BNODE-REGISTRY #f)
+      (let ((table (make-rdf-bnode-registry)))
+	(port/set-property! port 'RDF-BNODE-REGISTRY table)
 	table)))
 
-(define (port/drop-bnode-registry port)
-  (port/remove-property! port 'PORT/DROP-BNODE-REGISTRY))
+(define (port/drop-rdf-bnode-registry port)
+  (port/remove-property! port 'RDF-BNODE-REGISTRY))
 
 (define (rdf-bnode->handle bnode)
   (string-append bnode-handle-prefix (number->string (hash bnode))))
@@ -261,21 +261,30 @@ USA.
 
 (define (register-rdf-prefix prefix expansion #!optional registry)
   (guarantee-rdf-prefix prefix 'REGISTER-RDF-PREFIX)
-  (let ((registry (check-registry registry 'REGISTER-RDF-PREFIX)))
-    (let ((p (assq prefix (registry-bindings registry)))
-	  (new
-	   (uri->string
-	    (->absolute-uri expansion 'REGISTER-RDF-PREFIX))))
-      (if p
-	  (if (not (string=? (cdr p) new))
-	      (begin
-		(warn "RDF prefix override:" prefix (cdr p) new)
-		(set-cdr! p new)))
-	  (set-registry-bindings! registry
-				  (cons (cons prefix new)
-					(registry-bindings registry))))))
+  (%register-rdf-prefix prefix
+			(uri->string
+			 (->absolute-uri expansion 'REGISTER-RDF-PREFIX))
+			(check-registry registry 'REGISTER-RDF-PREFIX))
   prefix)
 
+(define (merge-rdf-prefix-registry! from-registry #!optional to-registry)
+  (guarantee-rdf-prefix-registry from-registry 'MERGE-RDF-PREFIX-REGISTRY!)
+  (let ((to-registry (check-registry to-registry 'MERGE-RDF-PREFIX-REGISTRY!)))
+    (for-each (lambda (p1)
+		(%register-rdf-prefix (car p1) (cdr p1) to-registry))
+	      (registry-bindings from-registry))))
+
+(define (%register-rdf-prefix prefix expansion registry)
+  (let ((p (assq prefix (registry-bindings registry))))
+    (if p
+	(if (not (string=? (cdr p) expansion))
+	    (begin
+	      (warn "RDF prefix override:" prefix (cdr p) expansion)
+	      (set-cdr! p expansion)))
+	(set-registry-bindings! registry
+				(cons (cons prefix expansion)
+				      (registry-bindings registry))))))
+
 (define (rdf-prefix-expansion prefix #!optional registry)
   (guarantee-rdf-prefix prefix 'RDF-PREFIX-EXPANSION)
   (let ((p
@@ -402,4 +411,15 @@ USA.
     (xsd: . "http://www.w3.org/2001/XMLSchema#")))
 
 (define *default-rdf-prefix-registry*
-  (new-rdf-prefix-registry))
\ No newline at end of file
+  (new-rdf-prefix-registry))
+
+(define (port/set-rdf-prefix-registry port registry)
+  (if registry
+      (begin
+	(guarantee-rdf-prefix-registry registry 'PORT/SET-RDF-PREFIX-REGISTRY!)
+	(port/set-property! port 'RDF-PREFIX-REGISTRY registry))
+      (port/remove-property! port 'RDF-PREFIX-REGISTRY)))
+
+(define (port/rdf-prefix-registry port)
+  (or (port/get-property port 'RDF-PREFIX-REGISTRY #f)
+      *default-rdf-prefix-registry*))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 0fc0ee5f9..e0bed396f 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.84 2006/10/29 05:35:07 cph Exp $
+$Id: xml.pkg,v 1.85 2006/10/29 06:18:03 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -560,7 +560,12 @@ USA.
 	  make-rdf-literal
 	  make-rdf-qname
 	  make-rdf-triple
+	  merge-rdf-prefix-registry!
 	  new-rdf-prefix-registry
+	  port/drop-rdf-bnode-registry
+	  port/rdf-bnode-registry
+	  port/rdf-prefix-registry
+	  port/set-rdf-prefix-registry
 	  rdf-bnode->handle
 	  rdf-bnode-name
 	  rdf-bnode?
@@ -592,9 +597,7 @@ USA.
   (export (runtime rdf)
 	  %make-rdf-literal
 	  match-bnode-name
-	  match-language
-	  port/bnode-registry
-	  port/drop-bnode-registry))
+	  match-language))
 
 (define-package (runtime rdf nt)
   (files "rdf-nt")