From: Chris Hanson Date: Thu, 27 Jul 2006 20:14:09 +0000 (+0000) Subject: Allow RDF prefix procedures to take an optional registry, and export a X-Git-Tag: 20090517-FFI~974 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c40ea3d93a998f87014a74192783bc6e290a8022;p=mit-scheme.git 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 d767884e4..e45abc96e 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.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. ;;;; 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 ":"))) + +(define-record-type + (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 ea194c040..0bb68ca90 100644 --- 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 4e235648e..cc0399964 100644 --- 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. + 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)