Allow RDF prefix procedures to take an optional registry, and export a

data abstraction for registries.

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index d767884e4b0e6c2f1b7a792494e507214382dd96..e45abc96ef4d1b12173fb422b7547970a3c813e4 100644 (file)
--- 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.10 2006/06/23 18:49:28 cph Exp $
+$Id: rdf-struct.scm,v 1.11 2006/07/27 20:14:06 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -186,33 +186,38 @@ USA.
 \f
 ;;;; Qnames
 
-(define (register-rdf-qname-prefix name expansion)
-  (guarantee-interned-symbol name 'REGISTER-RDF-QNAME-PREFIX)
+(define (register-rdf-prefix name expansion #!optional registry)
+  (guarantee-interned-symbol name 'REGISTER-RDF-PREFIX)
   (if (not (complete-match match-prefix (symbol-name name)))
-      (error:bad-range-argument name 'REGISTER-RDF-QNAME-PREFIX))
-  (let ((p (assq name registered-prefixes))
-       (new
-        (uri->string (->absolute-uri expansion 'REGISTER-RDF-QNAME-PREFIX))))
-    (if p
-       (if (not (string=? (cdr p) new))
-           (begin
-             (warn "RDF prefix override:" name (cdr p) new)
-             (set-cdr! p new)))
-       (set! registered-prefixes
-             (cons (cons name new) registered-prefixes))))
+      (error:bad-range-argument name 'REGISTER-RDF-PREFIX))
+  (let ((registry (check-registry registry 'REGISTER-RDF-PREFIX)))
+    (let ((p (assq name (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:" name (cdr p) new)
+               (set-cdr! p new)))
+         (set-registry-bindings! registry
+                                 (cons (cons name new)
+                                       (registry-bindings registry))))))
   name)
 
-(define (uri->rdf-qname uri)
+(define (uri->rdf-qname uri #!optional registry)
   (let ((s (uri->string (->absolute-uri uri 'URI->RDF-QNAME))))
     (let ((p
-          (find-matching-item registered-prefixes
+          (find-matching-item
+              (registry-bindings
+               (check-registry registry 'URI->RDF-QNAME))
             (lambda (p)
               (string-prefix? (cdr p) s)))))
       (and p
           (symbol (car p)
                   (string-tail s (string-length (cdr p))))))))
 
-(define (rdf-qname->uri qname #!optional error?)
+(define (rdf-qname->uri qname #!optional error? registry)
   (let ((maybe-lose
         (lambda ()
           (if error? (error:not-rdf-qname qname 'RDF-QNAME->URI))
@@ -220,14 +225,14 @@ USA.
     (if (and (interned-symbol? qname)
             (complete-match match-qname (symbol-name qname)))
        (receive (prefix local) (split-qname qname)
-         (let ((p (assq prefix registered-prefixes)))
+         (let ((p (assq prefix (check-registry registry 'RDF-QNAME->URI))))
            (if p
                (->absolute-uri (string-append (cdr p) local))
                (maybe-lose))))
        (maybe-lose))))
 
-(define (rdf-qname? object)
-  (if (rdf-qname->uri object #f) #t #f))
+(define (rdf-qname? object #!optional registry)
+  (if (rdf-qname->uri object #f registry) #t #f))
 
 (define-guarantee rdf-qname "RDF qname")
 
@@ -242,18 +247,32 @@ USA.
 
 (define match-prefix
   (*matcher (seq match:prefix-name ":")))
+\f
+(define-record-type <rdf-prefix-registry>
+    (make-rdf-prefix-registry bindings)
+    rdf-prefix-registry?
+  (bindings registry-bindings set-registry-bindings!))
 
-(define (reset-rdf-qname-prefixes)
-  (set! registered-prefixes (default-rdf-prefixes))
-  unspecific)
+(define-guarantee rdf-prefix-registry "RDF QName prefix registry")
+
+(define (copy-rdf-prefix-registry #!optional registry)
+  (make-rdf-prefix-registry
+   (registry-bindings (check-registry registry 'COPY-RDF-PREFIX-REGISTRY))))
 
-(define (registered-rdf-prefixes)
-  (alist-copy registered-prefixes))
+(define (check-registry registry caller)
+  (if (default-object? registry)
+      current-registry
+      (begin
+       (guarantee-rdf-prefix-registry registry caller)
+       registry)))
 
-(define (default-rdf-prefixes)
-  (alist-copy default-prefixes))
+(define (current-rdf-prefix-registry)
+  current-registry)
 
-(define registered-prefixes)
+(define current-registry)
+
+(define (new-rdf-prefix-registry)
+  (make-rdf-prefix-registry (alist-copy default-prefixes)))
 
 (define default-prefixes
   '((rdf: . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
@@ -261,4 +280,8 @@ USA.
     (owl: . "http://www.w3.org/2002/07/owl#")
     (xsd: . "http://www.w3.org/2001/XMLSchema#")))
 
-(reset-rdf-qname-prefixes)
\ No newline at end of file
+(define (reset-rdf-prefixes)
+  (set! current-registry (new-rdf-prefix-registry))
+  unspecific)
+
+(reset-rdf-prefixes)
\ No newline at end of file

diff --git a/v7/src/xml/turtle.scm b/v7/src/xml/turtle.scm
index ea194c040480ec1ab573b2149ba74d940b75032a..0bb68ca9025aba0a14dffc9d7761294300b4d63c 100644 (file)
--- a/v7/src/xml/turtle.scm
+++ b/v7/src/xml/turtle.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: turtle.scm,v 1.4 2006/07/08 00:24:09 cph Exp $
+$Id: turtle.scm,v 1.5 2006/07/27 20:14:08 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -468,7 +468,7 @@ USA.
                (let ((prefix (cadr p))
                      (v (uri->string (merge-uris (caddr p) base-uri))))
                  (if prefix
-                     (register-rdf-qname-prefix (symbol prefix ':) v))
+                     (register-rdf-prefix (symbol prefix ':) v))
                  (cons prefix v)))
              (keep-matching-items stmts
                (lambda (stmt)

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 4e235648ee52987aac66335e40419c42d2a732f3..cc0399964f79b813da9ccb66e78e2d9d22dd4002 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.74 2006/06/23 19:35:26 cph Exp $
+$Id: xml.pkg,v 1.75 2006/07/27 20:14:09 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -528,27 +528,32 @@ USA.
          <rdf-bnode>
          <rdf-index>
          <rdf-literal>
+         <rdf-prefix-registry>
          <rdf-triple>
          add-to-rdf-index
          canonicalize-rdf-object
          canonicalize-rdf-predicate
          canonicalize-rdf-subject
          canonicalize-rdf-uri
-         default-rdf-prefixes
+         copy-rdf-prefix-registry
+         current-rdf-prefix-registry
          error:not-rdf-bnode
          error:not-rdf-index
          error:not-rdf-literal
+         error:not-rdf-prefix-registry
          error:not-rdf-qname
          error:not-rdf-triple
          guarantee-rdf-bnode
          guarantee-rdf-index
          guarantee-rdf-literal
+         guarantee-rdf-prefix-registry
          guarantee-rdf-qname
          guarantee-rdf-triple
          make-rdf-bnode
          make-rdf-index
          make-rdf-literal
          make-rdf-triple
+         new-rdf-prefix-registry
          rdf-bnode-name
          rdf-bnode?
          rdf-index-objects
@@ -560,14 +565,14 @@ USA.
          rdf-literal-type
          rdf-literal=?
          rdf-literal?
+         rdf-prefix-registry?
          rdf-qname->uri
          rdf-qname?
          rdf-triple-object
          rdf-triple-predicate
          rdf-triple-subject
          rdf-triple?
-         register-rdf-qname-prefix
-         registered-rdf-prefixes
+         register-rdf-prefix
          uri->rdf-qname
          write-rdf-uri)
   (export (runtime rdf)