From e653d11bfe9482d075d324317036a25bcbc3015c Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 24 Sep 2003 04:17:45 +0000 Subject: [PATCH] Implement GUARANTEE- procedures for all types. Implement XML-ELEMENT-NAMESPACE-DECLS. --- v7/src/xml/xml-struct.scm | 61 ++++++++++++++++++++++++++++++++------- v7/src/xml/xml.pkg | 37 +++++++++++++++++++++++- 2 files changed, 87 insertions(+), 11 deletions(-) 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. + 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? -- 2.25.1