Implement RDF graph type. Hash cons all structures, including triples

and literals.  Add event distributor EVENT:NEW-RDF-TRIPLE that is
called whenever a new triple is allocated; this is a hook for
indexing.

diff --git a/v7/src/xml/rdf-struct.scm b/v7/src/xml/rdf-struct.scm
index a89d9b4a321242955c1f1af6fc88bd111ea09486..aac68d5e4b0290de41f1cefd06747660443d2dde 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.29 2007/08/01 00:15:42 cph Exp $
+$Id: rdf-struct.scm,v 1.30 2007/08/02 04:40:16 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -27,24 +27,50 @@ USA.
 
 ;;;; RDF data structures
 
+;;; Interning mechanisms used here hold onto the interned objects
+;;; strongly.  They should be changed to hold them weakly.
+
 (declare (usual-integrations))
 \f
+;;;; Triples
+
 (define-record-type <rdf-triple>
-    (%make-rdf-triple subject predicate object)
+    (%make-rdf-triple subject predicate object index)
     rdf-triple?
   (subject rdf-triple-subject)
   (predicate rdf-triple-predicate)
-  (object rdf-triple-object))
+  (object rdf-triple-object)
+  (index rdf-triple-index))
 
 (define-guarantee rdf-triple "RDF triple")
 
 (define (make-rdf-triple subject predicate object)
-  (%make-rdf-triple (canonicalize-rdf-subject subject 'MAKE-RDF-TRIPLE)
-                   (canonicalize-rdf-predicate predicate 'MAKE-RDF-TRIPLE)
-                   (canonicalize-rdf-object object 'MAKE-RDF-TRIPLE)))
+  (let ((subject (canonicalize-rdf-subject subject 'MAKE-RDF-TRIPLE))
+       (predicate (canonicalize-rdf-predicate predicate 'MAKE-RDF-TRIPLE))
+       (object (canonicalize-rdf-object object 'MAKE-RDF-TRIPLE)))
+    (hash-table/intern! rdf-triples (vector subject predicate object)
+      (lambda ()
+       (let ((triple
+              (%make-rdf-triple subject predicate object (next-index))))
+         (event-distributor/invoke! event:new-rdf-triple triple)
+         triple)))))
+
+(define (for-each-rdf-triple procedure)
+  (for-each procedure
+           (hash-table/datum-list rdf-triples)))
+
+(define next-index
+  (let ((counter 0))
+    (lambda ()
+      (let ((index counter))
+       (set! counter (+ counter 1))
+       index))))
+
+(define rdf-triples (make-equal-hash-table))
+(define event:new-rdf-triple (make-event-distributor))
 
 (define (canonicalize-rdf-subject subject #!optional caller)
-  (cond ((rdf-bnode? subject) subject)
+  (cond ((or (rdf-bnode? subject) (rdf-graph? subject)) subject)
        ((%decode-bnode-uri subject))
        (else (canonicalize-rdf-uri subject caller))))
 
@@ -61,6 +87,43 @@ USA.
       (rdf-qname->uri uri)
       (->absolute-uri uri caller)))
 \f
+;;;; Graphs
+
+(define-record-type <rdf-graph>
+    (%make-rdf-graph triples)
+    rdf-graph?
+  (triples rdf-graph-triples))
+
+(define-guarantee rdf-graph "RDF graph")
+
+(define (make-rdf-graph triples)
+  (guarantee-list-of-type triples rdf-triple? "list of RDF triples"
+                         'MAKE-RDF-GRAPH)
+  (let ((triples
+        (if (pair? triples)
+            (let ((head
+                   (cons 'DUMMY
+                         (sort triples
+                           (lambda (t1 t2)
+                             (< (rdf-triple-index t1)
+                                (rdf-triple-index t2)))))))
+              (let loop ((this (cdr head)) (prev head))
+                (let ((next (cdr this)))
+                  (if (pair? next)
+                      (if (eq? (car this) (car next))
+                          (begin
+                            (set-cdr! prev next)
+                            (loop next prev))
+                          (loop next this)))))
+              (cdr head))
+            '())))
+    (hash-table/intern! rdf-graphs triples
+      (lambda ()
+       (%make-rdf-graph triples)))))
+
+(define rdf-graphs
+  (make-equal-hash-table))
+\f
 ;;;; Blank nodes
 
 (define-record-type <rdf-bnode>
@@ -121,20 +184,42 @@ USA.
 
 (define-guarantee rdf-literal "RDF literal")
 
+(define (make-rdf-literal text type)
+  (guarantee-utf8-string text 'MAKE-RDF-LITERAL)
+  (let ((type
+        (if (or (not type)
+                (language? type))
+            type
+            (->absolute-uri type 'MAKE-RDF-LITERAL))))
+    (hash-table/intern! rdf-literals (cons text type)
+      (lambda ()
+       (%make-rdf-literal text type)))))
+
+(define rdf-literals
+  (make-equal-hash-table))
+
+(define (rdf-literal-type literal)
+  (let ((type (%rdf-literal-type literal)))
+    (and (absolute-uri? type)
+        type)))
+
+(define (rdf-literal-language literal)
+  (let ((type (%rdf-literal-type literal)))
+    (and (not (absolute-uri? type))
+        type)))
+
 (set-record-type-unparser-method! <rdf-literal>
   (standard-unparser-method 'RDF-LITERAL
     (lambda (literal port)
       (write-char #\space port)
       (write-rdf/nt-literal literal port))))
 
-(define (make-rdf-literal text type)
-  (guarantee-utf8-string text 'RDF-LITERAL)
-  (%make-rdf-literal text
-                    (if (or (not type)
-                            (and (interned-symbol? type)
-                                 (*match-symbol match-language type)))
-                        type
-                        (->absolute-uri type 'RDF-LITERAL))))
+(define (rdf-literal=? l1 l2)
+  (eq? l1 l2))
+
+(define (language? object)
+  (and (interned-symbol? object)
+       (*match-symbol match-language object)))
 
 (define match-language
   (let* ((language-head (ascii-range->char-set #x61 #x7B))
@@ -144,20 +229,6 @@ USA.
     (*matcher
      (seq (+ (char-set language-head))
          (* (seq #\- (+ (char-set language-tail))))))))
-
-(define (rdf-literal-type literal)
-  (let ((type (%rdf-literal-type literal)))
-    (and (absolute-uri? type)
-        type)))
-
-(define (rdf-literal-language literal)
-  (let ((type (%rdf-literal-type literal)))
-    (and (not (absolute-uri? type))
-        type)))
-
-(define (rdf-literal=? l1 l2)
-  (and (string=? (rdf-literal-text l1) (rdf-literal-text l2))
-       (eq? (%rdf-literal-type l1) (%rdf-literal-type l2))))
 \f
 ;;;; Qnames
 

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 1503d267eefb6e52edd6d2d40e0e0250432a9f86..f34d6bcfd7b39fe377e17206cba8a2b122a39a83 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.95 2007/08/01 00:15:44 cph Exp $
+$Id: xml.pkg,v 1.96 2007/08/02 04:40:41 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -536,6 +536,7 @@ USA.
   (export ()
          *default-rdf-prefix-registry*
          <rdf-bnode>
+         <rdf-graph>
          <rdf-literal>
          <rdf-prefix-registry>
          <rdf-triple>
@@ -545,18 +546,23 @@ USA.
          canonicalize-rdf-uri
          copy-rdf-prefix-registry
          error:not-rdf-bnode
+         error:not-rdf-graph
          error:not-rdf-literal
          error:not-rdf-prefix
          error:not-rdf-prefix-registry
          error:not-rdf-qname
          error:not-rdf-triple
+         event:new-rdf-triple
+         for-each-rdf-triple
          guarantee-rdf-bnode
+         guarantee-rdf-graph
          guarantee-rdf-literal
          guarantee-rdf-prefix
          guarantee-rdf-prefix-registry
          guarantee-rdf-qname
          guarantee-rdf-triple
          make-rdf-bnode
+         make-rdf-graph
          make-rdf-literal
          make-rdf-qname
          make-rdf-triple
@@ -566,10 +572,11 @@ USA.
          port/set-rdf-prefix-registry
          rdf-bnode-name
          rdf-bnode?
+         rdf-graph-triples
+         rdf-graph?
          rdf-literal-language
          rdf-literal-text
          rdf-literal-type
-         rdf-literal=?
          rdf-literal?
          rdf-prefix-expansion
          rdf-prefix-registry->alist
@@ -615,10 +622,7 @@ USA.
          write-rdf/turtle
          write-rdf/turtle-file
          write-rdf/turtle-literal
-         write-rdf/turtle-predicate
          write-rdf/turtle-prefix
-         write-rdf/turtle-prefixes
-         write-rdf/turtle-subject
          write-rdf/turtle-triples
          write-rdf/turtle-uri)
   (export (runtime rdf)