From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 1 Aug 2006 02:50:50 +0000 (+0000)
Subject: Round out the RDF QName abstraction a bit.  Change RDF-QNAME? to be a
X-Git-Tag: 20090517-FFI~967
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=abe83e4a1dd08a76f70f092412c3ba0fbc9dda8d;p=mit-scheme.git

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 634451931..038671009 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.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.
 
 ;;;; 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))
+
+(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) ":")))
-
+
 (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 ce33aa781..71f348da9 100644
--- 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)