From: Chris Hanson Date: Wed, 24 Sep 2003 03:26:23 +0000 (+0000) Subject: Implement new procedures (and use where appropriate): X-Git-Tag: 20090517-FFI~1801 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f73c4b7b17256ccdd1103db80887933e2aa7f4af;p=mit-scheme.git Implement new procedures (and use where appropriate): SIMPLE-XML-ATTRIBUTE-VALUE? XML-NAME-LOCAL=? XML-NAME-PREFIX=? XML-NAME-SIMPLE=? XML-NAME-URI=? --- diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm index 277548c21..440fb87b8 100644 --- a/v7/src/xml/xml-parser.scm +++ b/v7/src/xml/xml-parser.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-parser.scm,v 1.40 2003/09/16 04:32:59 cph Exp $ +$Id: xml-parser.scm,v 1.41 2003/09/24 03:26:19 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -73,11 +73,6 @@ USA. (alt (sbracket description "\"" "\"" (match (* (alphabet a1)))) (sbracket description "'" "'" (match (* (alphabet a2)))))))) -(define (simple-attribute-value? v) - (and (pair? v) - (string? (car v)) - (null? (cdr v)))) - (define (read-xml-file pathname #!optional pi-handlers) (call-with-input-file pathname (lambda (port) @@ -183,7 +178,7 @@ USA. (define (transform-declaration attributes text-decl? p) (if (not (for-all? attributes (lambda (attribute) - (simple-attribute-value? (cdr attribute))))) + (simple-xml-attribute-value? (cdr attribute))))) (perror p "XML declaration can't contain entity refs" attributes)) (let ((finish (lambda (version encoding standalone) @@ -355,7 +350,7 @@ USA. "Incorrect attribute value" (string->symbol name))) (if (and (not (eq? type '|CDATA|)) - (simple-attribute-value? av)) + (simple-xml-attribute-value? av)) (set-car! av (trim-attribute-whitespace (car av)))) attributes) (begin @@ -479,7 +474,7 @@ USA. (pn (cdr name))) (let ((uri (lambda () - (if (not (simple-attribute-value? value)) + (if (not (simple-xml-attribute-value? value)) (perror pn "Illegal namespace URI" value)) (if (string-null? (car value)) #f ;xmlns="" @@ -892,7 +887,7 @@ USA. (let ((entity (find-parameter-entity name))) (and entity (xml-parameter-!entity-value entity)))))) - (if (simple-attribute-value? value) + (if (simple-xml-attribute-value? value) (car value) (begin (set! *parameter-entities* 'STOP) @@ -922,7 +917,7 @@ USA. (let ((value (xml-!entity-value entity))) (cond ((xml-external-id? value) #f) (in-attribute? value) - ((simple-attribute-value? value) + ((simple-xml-attribute-value? value) (reparse-entity-value-string name (car value) p)) (else (if (or *standalone?* *internal-dtd?*) @@ -1113,7 +1108,7 @@ USA. (list name type (if (and (not (eq? type '|CDATA|)) (pair? default) - (simple-attribute-value? (cdr default))) + (simple-xml-attribute-value? (cdr default))) (list (car default) (trim-attribute-whitespace (cadr default))) default)))) diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm index 5716cb5f2..85c7988b9 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.24 2003/09/17 03:20:45 cph Exp $ +$Id: xml-struct.scm,v 1.25 2003/09/24 03:26:23 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -119,6 +119,9 @@ USA. ((combo-name? name) (combo-name-simple name)) (else (error:not-xml-name name 'XML-NAME-simple)))) +(define (xml-name-simple=? name simple) + (eq? (xml-name-simple name) simple)) + (define (xml-name-string name) (symbol-name (xml-name-simple name))) @@ -127,6 +130,9 @@ USA. ((combo-name? name) (universal-name-uri (combo-name-universal name))) (else (error:not-xml-name name 'XML-NAME-URI)))) +(define (xml-name-uri=? name uri) + (eq? (xml-name-uri name) uri)) + (define (xml-name-prefix name) (let ((simple (lambda (name) @@ -139,6 +145,9 @@ USA. ((combo-name? name) (simple (combo-name-simple name))) (else (error:not-xml-name name 'XML-NAME-PREFIX))))) +(define (xml-name-prefix=? name prefix) + (eq? (xml-name-prefix name) prefix)) + (define (xml-name-local name) (cond ((xml-nmtoken? name) (let ((s (symbol-name name))) @@ -149,6 +158,9 @@ USA. ((combo-name? name) (universal-name-local (combo-name-universal name))) (else (error:not-xml-name name 'XML-NAME-LOCAL)))) +(define (xml-name-local=? name local) + (eq? (xml-name-local name) local)) + (define (xml-name=? n1 n2) (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?)))) (cond ((xml-nmtoken? n1) @@ -341,6 +353,11 @@ 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))) diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 07151ef70..748d9a50f 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.25 2003/09/17 03:20:41 cph Exp $ +$Id: xml.pkg,v 1.26 2003/09/24 03:26:16 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -103,6 +103,7 @@ USA. set-xml-unparsed-!entity-id! set-xml-unparsed-!entity-name! set-xml-unparsed-!entity-notation! + simple-xml-attribute-value? xml-!attlist-definitions xml-!attlist-name xml-!attlist? @@ -151,10 +152,14 @@ USA. xml-intern xml-name-hash xml-name-local + xml-name-local=? xml-name-prefix + xml-name-prefix=? xml-name-simple + xml-name-simple=? xml-name-string xml-name-uri + xml-name-uri=? xml-name=? xml-name? xml-nmtoken? @@ -184,7 +189,7 @@ USA. read-xml-file string->xml substring->xml) - (export (runtime xml structure) + (export (runtime xml) alphabet:name-initial alphabet:name-subsequent))