Round out the RDF QName abstraction a bit. Change RDF-QNAME? to be a

syntactic test that doesn't check any registry.

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index 634451931da5d285799f71bce0a2d38ab811d27d..0386710097ee46918669be479af75e0efce07562 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.13 2006/07/28 04:01:11 cph Exp $
+$Id: rdf-struct.scm,v 1.14 2006/08/01 02:50:45 cph Exp $
 
 Copyright 2006 Massachusetts Institute of Technology
 
@@ -186,24 +186,31 @@ USA.
 \f
 ;;;; Qnames
 
-(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-PREFIX))
+(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 name (registry-bindings registry)))
+    (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:" name (cdr p) new)
+               (warn "RDF prefix override:" prefix (cdr p) new)
                (set-cdr! p new)))
          (set-registry-bindings! registry
-                                 (cons (cons name new)
+                                 (cons (cons prefix new)
                                        (registry-bindings registry))))))
-  name)
+  prefix)
+
+(define (rdf-prefix-expansion prefix #!optional registry)
+  (guarantee-rdf-prefix prefix 'RDF-PREFIX-EXPANSION)
+  (let ((p
+        (assq prefix
+              (registry-bindings
+               (check-registry registry 'RDF-PREFIX-EXPANSION)))))
+    (and p
+        (cdr p))))
 
 (define (uri->rdf-qname uri #!optional error? registry)
   (let ((s (uri->string (->absolute-uri uri 'URI->RDF-QNAME))))
@@ -224,39 +231,46 @@ USA.
                   (string-tail s (string-length (cdr p))))))))
 
 (define (rdf-qname->uri qname #!optional error? registry)
-  (let ((maybe-lose
-        (lambda ()
-          (if error? (error:not-rdf-qname qname 'RDF-QNAME->URI))
-          #f)))
-    (if (and (interned-symbol? qname)
-            (complete-match match-qname (symbol-name qname)))
-       (receive (prefix local) (split-qname qname)
-         (let ((p
-                (assq prefix
-                      (registry-bindings
-                       (check-registry registry 'RDF-QNAME->URI)))))
-           (if p
-               (->absolute-uri (string-append (cdr p) local) 'RDF-QNAME->URI)
-               (maybe-lose))))
-       (maybe-lose))))
-
-(define (rdf-qname? object #!optional registry)
-  (if (rdf-qname->uri object #f registry) #t #f))
-
-(define-guarantee rdf-qname "RDF qname")
-
-(define (split-qname qname)
+  (receive (prefix local) (split-rdf-qname qname)
+    (let ((expansion (rdf-prefix-expansion prefix registry)))
+      (if expansion
+         (->absolute-uri (string-append expansion local) 'RDF-QNAME->URI)
+         (begin
+           (if error? (error:bad-range-argument qname 'RDF-QNAME->URI))
+           #f)))))
+
+(define (split-rdf-qname qname)
+  (guarantee-rdf-qname qname 'SPLIT-RDF-QNAME)
   (let ((s (symbol-name qname)))
     (let ((i (fix:+ (string-find-next-char s #\:) 1)))
       (values (symbol (string-head s i))
              (string-tail s i)))))
 
+(define (join-rdf-qname prefix local)
+  (guarantee-rdf-prefix prefix 'JOIN-RDF-QNAME)
+  (guarantee-string local 'JOIN-RDF-QNAME)
+  (if (not (complete-match match:name local))
+      (error:bad-range-argument local 'JOIN-RDF-QNAME))
+  (symbol prefix local))
+\f
+(define (rdf-qname? object)
+  (and (interned-symbol? object)
+       (complete-match match-qname (symbol-name object))))
+
+(define-guarantee rdf-qname "RDF QName")
+
+(define (rdf-prefix? object)
+  (and (interned-symbol? object)
+       (complete-match match-prefix (symbol-name object))))
+
+(define-guarantee rdf-prefix "RDF prefix")
+
 (define match-qname
   (*matcher (seq match-prefix match:name)))
 
 (define match-prefix
   (*matcher (seq (? match:prefix-name) ":")))
-\f
+
 (define-record-type <rdf-prefix-registry>
     (make-rdf-prefix-registry bindings)
     rdf-prefix-registry?

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index ce33aa7814550bc2def54703ef3f86091d7a9366..71f348da97d264b8d4aa90d917b5f7ec44328e17 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.76 2006/07/28 02:54:27 cph Exp $
+$Id: xml.pkg,v 1.77 2006/08/01 02:50:50 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -540,15 +540,18 @@ USA.
          error:not-rdf-bnode
          error:not-rdf-index
          error:not-rdf-literal
+         error:not-rdf-prefix
          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
          guarantee-rdf-prefix-registry
          guarantee-rdf-qname
          guarantee-rdf-triple
+         join-rdf-qname
          make-rdf-bnode
          make-rdf-index
          make-rdf-literal
@@ -565,8 +568,10 @@ USA.
          rdf-literal-type
          rdf-literal=?
          rdf-literal?
+         rdf-prefix-expansion
          rdf-prefix-registry->alist
          rdf-prefix-registry?
+         rdf-prefix?
          rdf-qname->uri
          rdf-qname?
          rdf-triple-object
@@ -574,6 +579,7 @@ USA.
          rdf-triple-subject
          rdf-triple?
          register-rdf-prefix
+         split-rdf-qname
          uri->rdf-qname
          write-rdf-uri)
   (export (runtime rdf)