From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Sep 2003 04:17:45 +0000 (+0000)
Subject: Implement GUARANTEE- procedures for all types.  Implement
X-Git-Tag: 20090517-FFI~1798
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e653d11bfe9482d075d324317036a25bcbc3015c;p=mit-scheme.git

Implement GUARANTEE- procedures for all types.  Implement
XML-ELEMENT-NAMESPACE-DECLS.
---

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 0d1d8db56..5a0eab3b2 100644
--- a/v7/src/xml/xml-struct.scm
+++ b/v7/src/xml/xml-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-struct.scm,v 1.26 2003/09/24 03:50:48 cph Exp $
+$Id: xml-struct.scm,v 1.27 2003/09/24 04:17:38 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -51,7 +51,7 @@ USA.
 	   (string-is-xml-name? (symbol-name object)))
       (combo-name? object)))
 
-(define-integrable (guarantee-xml-name object caller)
+(define (guarantee-xml-name object caller)
   (if (not (xml-name? object))
       (error:not-xml-name object caller)))
 
@@ -73,7 +73,7 @@ USA.
   (and (fix:> (string-length object) 0)
        (utf8-string-valid? object)))
 
-(define-integrable (guarantee-xml-namespace-uri object caller)
+(define (guarantee-xml-namespace-uri object caller)
   (if (not (xml-namespace-uri? object))
       (error:not-xml-namespace-uri object caller)))
 
@@ -256,6 +256,8 @@ USA.
 	       (slots (cddr form)))
 	   (let ((rtd (symbol-append '< root '>))
 		 (constructor (symbol-append 'MAKE- root))
+		 (predicate (symbol-append root '?))
+		 (error:not (symbol-append 'ERROR:NOT- root))
 		 (slot-vars
 		  (map (lambda (slot)
 			 (close-syntax (car slot) environment))
@@ -268,8 +270,19 @@ USA.
 	       `(BEGIN
 		  (DEFINE ,rtd
 		    (MAKE-RECORD-TYPE ',root '(,@(map car slots))))
-		  (DEFINE ,(symbol-append root '?)
+		  (DEFINE ,predicate
 		    (RECORD-PREDICATE ,rtd))
+		  (DEFINE (,(symbol-append 'GUARANTEE- root) OBJECT CALLER)
+		    (IF (NOT ,predicate)
+			(,error:not OBJECT CALLER)))
+		  (DEFINE (,error:not OBJECT CALLER)
+		    (ERROR:WRONG-TYPE-ARGUMENT
+		     OBJECT
+		     ,(string-append "an XML "
+				     (string-replace (symbol-name (cadr form))
+						     #\-
+						     #\space))
+		     CALLER))
 		  (DEFINE ,constructor
 		    (LET ((CONSTRUCTOR
 			   (RECORD-CONSTRUCTOR ,rtd '(,@(map car slots)))))
@@ -365,11 +378,6 @@ USA.
   (and (pair? object)
        (list-of-type? object xml-attribute-value-item?)))
 
-(define (simple-xml-attribute-value? object)
-  (and (pair? object)
-       (xml-char-data? (car object))
-       (null? (cdr object))))
-
 (define (xml-attribute-value-item? object)
   (or (xml-char-data? object)
       (xml-entity-ref? object)))
@@ -625,4 +633,37 @@ USA.
 (define-xml-printer external-id
   (lambda (dtd)
     (or (xml-external-id-id dtd)
-	(xml-external-id-uri dtd))))
\ No newline at end of file
+	(xml-external-id-uri dtd))))
+
+(define (simple-xml-attribute-value? object)
+  (and (pair? object)
+       (xml-char-data? (car object))
+       (null? (cdr object))
+       (car object)))
+
+(define (guarantee-simple-xml-attribute-value object caller)
+  (let ((v (simple-xml-attribute-value? object)))
+    (if (not v)
+	(error:not-simple-xml-attribute-value object caller))
+    v))
+
+(define (error:not-simple-xml-attribute-value object caller)
+  (error:wrong-type-argument object "simple XML attribute value" caller))
+
+(define (xml-element-namespace-decls elt)
+  (guarantee-xml-element elt 'XML-ELEMENT-NAMESPACE-DECLS)
+  (let loop ((attrs (xml-element-attributes elt)))
+    (if (pair? attrs)
+	(let ((name (caar attrs))
+	      (keep
+	       (lambda (prefix)
+		 (cons (cons prefix
+			     (make-xml-namespace-uri
+			      (guarantee-simple-xml-attribute-value
+			       (cdar attrs)
+			       #f)))
+		       (loop (cdr attrs))))))
+	  (cond ((xml-name=? name 'xmlns) (keep #f))
+		((xml-name-prefix=? name 'xmlns) (keep (xml-name-local name)))
+		(else (loop (cdr attrs)))))
+	'())))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 5f2f77526..2b3172d05 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.27 2003/09/24 03:50:45 cph Exp $
+$Id: xml.pkg,v 1.28 2003/09/24 04:17:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -51,8 +51,42 @@ USA.
 	  <xml-parameter-entity-ref>
 	  <xml-processing-instructions>
 	  <xml-unparsed-!entity>
+	  error:not-simple-xml-attribute-value
+	  error:not-xml-!attlist
+	  error:not-xml-!element
+	  error:not-xml-!entity
+	  error:not-xml-!notation
+	  error:not-xml-comment
+	  error:not-xml-declaration
+	  error:not-xml-document
+	  error:not-xml-dtd
+	  error:not-xml-element
+	  error:not-xml-entity-ref
+	  error:not-xml-external-id
+	  error:not-xml-name
+	  error:not-xml-namespace-uri
+	  error:not-xml-parameter-!entity
+	  error:not-xml-parameter-entity-ref
+	  error:not-xml-processing-instructions
+	  error:not-xml-unparsed-!entity
+	  guarantee-simple-xml-attribute-value
+	  guarantee-xml-!attlist
+	  guarantee-xml-!element
+	  guarantee-xml-!entity
+	  guarantee-xml-!notation
+	  guarantee-xml-comment
+	  guarantee-xml-declaration
+	  guarantee-xml-document
+	  guarantee-xml-dtd
+	  guarantee-xml-element
+	  guarantee-xml-entity-ref
+	  guarantee-xml-external-id
 	  guarantee-xml-name
 	  guarantee-xml-namespace-uri
+	  guarantee-xml-parameter-!entity
+	  guarantee-xml-parameter-entity-ref
+	  guarantee-xml-processing-instructions
+	  guarantee-xml-unparsed-!entity
 	  make-xml-!attlist
 	  make-xml-!element
 	  make-xml-!entity
@@ -146,6 +180,7 @@ USA.
 	  xml-element-attributes
 	  xml-element-contents
 	  xml-element-name
+	  xml-element-namespace-decls
 	  xml-element?
 	  xml-entity-ref-name
 	  xml-entity-ref?