From c7e6f2cd71284e41ee6876ec943b1912bd9dc400 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 6 May 2017 14:54:11 -0700 Subject: [PATCH] Change XML output to use predicate dispatcher. --- src/xml/xml-output.scm | 539 ++++++++++++++++++++++------------------- src/xml/xml-struct.scm | 402 +++++++++++++++--------------- 2 files changed, 481 insertions(+), 460 deletions(-) diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm index ba04ab349..54f306c44 100644 --- a/src/xml/xml-output.scm +++ b/src/xml/xml-output.scm @@ -71,15 +71,23 @@ USA. (lambda (char) char #f)) 'PORT port options))) - -(define-structure (ctx (type-descriptor ) - (keyword-constructor make-ctx) - (print-procedure - (standard-unparser-method 'XML-OUTPUT-CONTEXT #f))) - (char-map #f read-only #t) - (port #f read-only #t) - (indent-attributes? #f read-only #t) - (indent-dtd? #f read-only #t)) + +(define (make-ctx . options) + (%make-ctx (get-keyword-value options 'char-map) + (get-keyword-value options 'port) + (get-keyword-value options 'indent-attributes? #f) + (get-keyword-value options 'indent-dtd? #f))) + +(define-record-type + (%make-ctx char-map port indent-attributes? indent-dtd?) + ctx? + (char-map ctx-char-map) + (port ctx-port) + (indent-attributes? ctx-indent-attributes?) + (indent-dtd? ctx-indent-dtd?)) + +(set-record-type-unparser-method! + (standard-unparser-method 'xml-output-context #f)) (define (emit-char char ctx) (let ((port (ctx-port ctx))) @@ -109,259 +117,280 @@ USA. (and (ctx-indent-dtd? ctx) (ctx-start-col ctx))) -(define-generic %write-xml (object ctx)) - -(define-method %write-xml ((document ) ctx) - (if (xml-document-declaration document) - (%write-xml (xml-document-declaration document) ctx)) - (for-each (lambda (object) (%write-xml object ctx)) - (xml-document-misc-1 document)) - (if (xml-document-dtd document) - (%write-xml (xml-document-dtd document) ctx)) - (for-each (lambda (object) (%write-xml object ctx)) - (xml-document-misc-2 document)) - (%write-xml (xml-document-root document) ctx) - (for-each (lambda (object) (%write-xml object ctx)) - (xml-document-misc-3 document))) - -(define-method %write-xml ((declaration ) ctx) - (emit-string "" ctx)) - -(define-method %write-xml ((element ) ctx) - (let ((name (xml-element-name element)) - (content (xml-element-content element))) - (emit-string "<" ctx) - (write-xml-name name ctx) - (write-xml-attributes (xml-element-attributes element) - (if (pair? content) 1 3) - ctx) - (if (pair? content) +(define %write-xml + (standard-predicate-dispatcher '%write-xml 2)) + +(define-predicate-dispatch-handler %write-xml (list xml-document? ctx?) + (lambda (document ctx) + (if (xml-document-declaration document) + (%write-xml (xml-document-declaration document) ctx)) + (for-each (lambda (object) (%write-xml object ctx)) + (xml-document-misc-1 document)) + (if (xml-document-dtd document) + (%write-xml (xml-document-dtd document) ctx)) + (for-each (lambda (object) (%write-xml object ctx)) + (xml-document-misc-2 document)) + (%write-xml (xml-document-root document) ctx) + (for-each (lambda (object) (%write-xml object ctx)) + (xml-document-misc-3 document)))) + +(define-predicate-dispatch-handler %write-xml (list xml-declaration? ctx?) + (lambda (declaration ctx) + (emit-string "" ctx) - (for-each (lambda (content) (%write-xml content ctx)) - content) - (emit-string "" ctx)) - (emit-string " />" ctx)))) - -(define-method %write-xml ((comment ) ctx) - (emit-string "" ctx)) - -(define-method %write-xml ((pi ) ctx) - (emit-string " (string-length text) 0) + (emit-string " encoding=\"" ctx) + (emit-string (xml-declaration-encoding declaration) ctx) + (emit-string "\"" ctx))) + (if (xml-declaration-standalone declaration) (begin - (if (not (char-in-set? (string-ref text 0) - char-set:xml-whitespace)) - (emit-string " " ctx)) - (emit-string text ctx)))) - (emit-string "?>" ctx)) + (emit-string " standalone=\"" ctx) + (emit-string (xml-declaration-standalone declaration) ctx) + (emit-string "\"" ctx))) + (emit-string "?>" ctx))) + +(define-predicate-dispatch-handler %write-xml (list xml-element? ctx?) + (lambda (element ctx) + (let ((name (xml-element-name element)) + (content (xml-element-content element))) + (emit-string "<" ctx) + (write-xml-name name ctx) + (write-xml-attributes (xml-element-attributes element) + (if (pair? content) 1 3) + ctx) + (if (pair? content) + (begin + (emit-string ">" ctx) + (for-each (lambda (content) (%write-xml content ctx)) + content) + (emit-string "" ctx)) + (emit-string " />" ctx))))) + +(define-predicate-dispatch-handler %write-xml (list xml-comment? ctx?) + (lambda (comment ctx) + (emit-string "" ctx))) -(define-method %write-xml ((dtd ) ctx) - ;;root external internal - (emit-string "" ctx))) - -(define-method %write-xml ((decl ) ctx) - (emit-string "string type)) ctx)) - ((and (pair? type) (eq? (car type) '|#PCDATA|)) - (emit-string "(#PCDATA" ctx) - (if (pair? (cdr type)) - (begin - (for-each (lambda (name) - (emit-string "|" ctx) - (write-xml-name name ctx)) - (cdr type)) - (emit-string ")*" ctx)) - (emit-string ")" ctx))) - (else - (letrec - ((write-children - (lambda (type) - (handle-iterator type - (lambda (type) - (if (not (and (pair? type) - (list? (cdr type)))) - (lose)) - (emit-string "(" ctx) - (write-cp (cadr type)) - (for-each - (let ((sep (if (eq? (car type) 'alt) "|" ","))) - (lambda (type) - (emit-string sep ctx) - (write-cp type))) - (cddr type)) - (emit-string ")" ctx))))) - (write-cp - (lambda (type) - (handle-iterator type - (lambda (type) - (if (xml-name? type) - (write-xml-name type ctx) - (write-children type)))))) - (handle-iterator - (lambda (type procedure) - (if (and (pair? type) - (memv (car type) '(#\? #\* #\+)) - (pair? (cdr type)) - (null? (cddr type))) - (begin - (procedure (cadr type)) - (emit-char (car type) ctx)) - (procedure type)))) - (lose - (lambda () - (error "Malformed !ELEMENT content type:" type)))) - (write-children type))))) - (emit-string ">" ctx)) +(define-predicate-dispatch-handler %write-xml + (list xml-processing-instructions? ctx?) + (lambda (pi ctx) + (emit-string " (string-length text) 0) + (begin + (if (not (char-in-set? (string-ref text 0) + char-set:xml-whitespace)) + (emit-string " " ctx)) + (emit-string text ctx)))) + (emit-string "?>" ctx))) + +(define-predicate-dispatch-handler %write-xml (list xml-dtd? ctx?) + (lambda (dtd ctx) + ;;root external internal + (emit-string "" ctx)))) -(define-method %write-xml ((decl ) ctx) - (emit-string "string type)) ctx)) - ((and (pair? type) (eq? (car type) '|NOTATION|)) - (emit-string "NOTATION (" ctx) - (if (pair? (cdr type)) - (begin - (write-xml-name (cadr type) ctx) - (for-each (lambda (name) - (emit-string "|" ctx) - (write-xml-name name ctx)) - (cddr type)))) - (emit-string ")" ctx)) - ((and (pair? type) (eq? (car type) 'enumerated)) - (emit-string "(" ctx) - (if (pair? (cdr type)) - (begin - (write-xml-nmtoken (cadr type) ctx) - (for-each (lambda (nmtoken) - (emit-string "|" ctx) - (write-xml-nmtoken nmtoken ctx)) - (cddr type)))) - (emit-string ")" ctx)) - (else - (error "Malformed !ATTLIST type:" type)))) - (emit-string " " ctx) - (let ((default (caddr definition))) - (cond ((or (eq? default '|#REQUIRED|) - (eq? default '|#IMPLIED|)) - (emit-string (symbol->string default) ctx)) - ((and (pair? default) (eq? (car default) '|#FIXED|)) - (emit-string (symbol->string (car default)) ctx) - (emit-string " " ctx) - (write-xml-attribute-value (cdr default) ctx)) - ((and (pair? default) (eq? (car default) 'default)) - (write-xml-attribute-value (cdr default) ctx)) - (else - (error "Malformed !ATTLIST default:" default))))))) - (if (pair? definitions) - (if (pair? (cdr definitions)) - (for-each (lambda (definition) - (emit-newline ctx) - (emit-string " " ctx) - (write-definition definition)) - definitions) - (begin - (emit-string " " ctx) - (write-definition (car definitions)))))) - (emit-string ">" ctx)) - -(define-method %write-xml ((decl ) ctx) - (emit-string "" ctx))) - -(define-method %write-xml ((decl ) ctx) - (emit-string "string type)) ctx)) + ((and (pair? type) (eq? (car type) '|#PCDATA|)) + (emit-string "(#PCDATA" ctx) + (if (pair? (cdr type)) + (begin + (for-each (lambda (name) + (emit-string "|" ctx) + (write-xml-name name ctx)) + (cdr type)) + (emit-string ")*" ctx)) + (emit-string ")" ctx))) + (else + (letrec + ((write-children + (lambda (type) + (handle-iterator type + (lambda (type) + (if (not (and (pair? type) + (list? (cdr type)))) + (lose)) + (emit-string "(" ctx) + (write-cp (cadr type)) + (for-each + (let ((sep + (if (eq? (car type) 'alt) + "|" + ","))) + (lambda (type) + (emit-string sep ctx) + (write-cp type))) + (cddr type)) + (emit-string ")" ctx))))) + (write-cp + (lambda (type) + (handle-iterator type + (lambda (type) + (if (xml-name? type) + (write-xml-name type ctx) + (write-children type)))))) + (handle-iterator + (lambda (type procedure) + (if (and (pair? type) + (memv (car type) '(#\? #\* #\+)) + (pair? (cdr type)) + (null? (cddr type))) + (begin + (procedure (cadr type)) + (emit-char (car type) ctx)) + (procedure type)))) + (lose + (lambda () + (error "Malformed !ELEMENT content type:" type)))) + (write-children type))))) (emit-string ">" ctx))) - -(define-method %write-xml ((decl ) ctx) - (emit-string "" ctx))) - -(define-method %write-xml ((decl ) ctx) - (emit-string "string type)) ctx)) + ((and (pair? type) (eq? (car type) '|NOTATION|)) + (emit-string "NOTATION (" ctx) + (if (pair? (cdr type)) + (begin + (write-xml-name (cadr type) ctx) + (for-each (lambda (name) + (emit-string "|" ctx) + (write-xml-name name ctx)) + (cddr type)))) + (emit-string ")" ctx)) + ((and (pair? type) (eq? (car type) 'enumerated)) + (emit-string "(" ctx) + (if (pair? (cdr type)) + (begin + (write-xml-nmtoken (cadr type) ctx) + (for-each (lambda (nmtoken) + (emit-string "|" ctx) + (write-xml-nmtoken nmtoken ctx)) + (cddr type)))) + (emit-string ")" ctx)) + (else + (error "Malformed !ATTLIST type:" type)))) + (emit-string " " ctx) + (let ((default (caddr definition))) + (cond ((or (eq? default '|#REQUIRED|) + (eq? default '|#IMPLIED|)) + (emit-string (symbol->string default) ctx)) + ((and (pair? default) (eq? (car default) '|#FIXED|)) + (emit-string (symbol->string (car default)) ctx) + (emit-string " " ctx) + (write-xml-attribute-value (cdr default) ctx)) + ((and (pair? default) (eq? (car default) 'default)) + (write-xml-attribute-value (cdr default) ctx)) + (else + (error "Malformed !ATTLIST default:" default))))))) + (if (pair? definitions) + (if (pair? (cdr definitions)) + (for-each (lambda (definition) + (emit-newline ctx) + (emit-string " " ctx) + (write-definition definition)) + definitions) + (begin + (emit-string " " ctx) + (write-definition (car definitions)))))) (emit-string ">" ctx))) - -(define-method %write-xml ((string ) ctx) - (write-escaped-string string - '((#\< . "<") - (#\& . "&")) - ctx)) - -(define-method %write-xml ((ref ) ctx) - (emit-string "&" ctx) - (write-xml-name (xml-entity-ref-name ref) ctx) - (emit-string ";" ctx)) - -(define-method %write-xml ((ref ) ctx) - (emit-string "%" ctx) - (write-xml-name (xml-parameter-entity-ref-name ref) ctx) - (emit-string ";" ctx)) + +(define-predicate-dispatch-handler %write-xml (list xml-!entity? ctx?) + (lambda (decl ctx) + (emit-string "" ctx)))) + +(define-predicate-dispatch-handler %write-xml (list xml-unparsed-!entity? ctx?) + (lambda (decl ctx) + (emit-string "" ctx)))) + +(define-predicate-dispatch-handler %write-xml (list xml-parameter-!entity? ctx?) + (lambda (decl ctx) + (emit-string "" ctx)))) + +(define-predicate-dispatch-handler %write-xml (list xml-!notation? ctx?) + (lambda (decl ctx) + (emit-string "" ctx)))) + +(define-predicate-dispatch-handler %write-xml (list string? ctx?) + (lambda (string ctx) + (write-escaped-string string + '((#\< . "<") + (#\& . "&")) + ctx))) + +(define-predicate-dispatch-handler %write-xml (list xml-entity-ref? ctx?) + (lambda (ref ctx) + (emit-string "&" ctx) + (write-xml-name (xml-entity-ref-name ref) ctx) + (emit-string ";" ctx))) + +(define-predicate-dispatch-handler %write-xml + (list xml-parameter-entity-ref? ctx?) + (lambda (ref ctx) + (emit-string "%" ctx) + (write-xml-name (xml-parameter-entity-ref-name ref) ctx) + (emit-string ";" ctx))) (define (write-xml-attributes attrs suffix-cols ctx) (let ((col diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm index 01db3a638..9ad54bb80 100644 --- a/src/xml/xml-struct.scm +++ b/src/xml/xml-struct.scm @@ -35,14 +35,14 @@ USA. (identifier? (cadr form)) (list-of-type? (cddr form) (lambda (slot) - (or (syntax-match? '(IDENTIFIER EXPRESSION) slot) - (syntax-match? '(IDENTIFIER 'CANONICALIZE EXPRESSION) + (or (syntax-match? '(identifier expression) slot) + (syntax-match? '(identifier 'canonicalize expression) slot))))) - (let ((root (symbol 'XML- (cadr form))) + (let ((root (symbol 'xml- (cadr form))) (slots (cddr form))) (let ((rtd (symbol '< root '>)) - (%constructor (symbol '%MAKE- root)) - (constructor (symbol 'MAKE- root)) + (%constructor (symbol '%make- root)) + (constructor (symbol 'make- root)) (predicate (symbol root '?)) (slot-vars (map (lambda (slot) @@ -50,24 +50,25 @@ USA. slots))) (let ((canonicalize (lambda (slot var caller) - (if (eq? (cadr slot) 'CANONICALIZE) + (if (eq? (cadr slot) 'canonicalize) `(,(close-syntax (caddr slot) environment) ,var) - `(BEGIN - (IF (NOT (,(close-syntax (cadr slot) environment) + `(begin + (if (not (,(close-syntax (cadr slot) environment) ,var)) - (ERROR:WRONG-TYPE-ARGUMENT + (error:wrong-type-argument ,var ,(symbol->string (car slot)) ',caller)) ,var))))) - `(BEGIN - (DEFINE ,rtd - (MAKE-RECORD-TYPE ',root '(,@(map car slots)))) - (DEFINE ,predicate - (RECORD-PREDICATE ,rtd)) - (DEFINE ,%constructor - (RECORD-CONSTRUCTOR ,rtd '(,@(map car slots)))) - (DEFINE (,constructor ,@slot-vars) + `(begin + (define ,rtd + (make-record-type ',root '(,@(map car slots)))) + (define ,predicate + (record-predicate ,rtd)) + (register-predicate! ,predicate ',root) + (define ,%constructor + (record-constructor ,rtd '(,@(map car slots)))) + (define (,constructor ,@slot-vars) (,%constructor ,@(map (lambda (slot var) (canonicalize slot var constructor)) @@ -75,15 +76,15 @@ USA. slot-vars))) ,@(map (lambda (slot var) (let* ((accessor (symbol root '- (car slot))) - (modifier (symbol 'SET- accessor '!))) - `(BEGIN - (DEFINE ,accessor - (RECORD-ACCESSOR ,rtd ',(car slot))) - (DEFINE ,modifier - (LET ((MODIFIER - (RECORD-MODIFIER ,rtd ',(car slot)))) - (NAMED-LAMBDA (,modifier OBJECT ,var) - (MODIFIER OBJECT + (modifier (symbol 'set- accessor '!))) + `(begin + (define ,accessor + (record-accessor ,rtd ',(car slot))) + (define ,modifier + (let ((modifier + (record-modifier ,rtd ',(car slot)))) + (named-lambda (,modifier object ,var) + (modifier object ,(canonicalize slot var modifier)))))))) @@ -99,39 +100,159 @@ USA. (root xml-element?) (misc-3 xml-misc-content?)) -(define (xml-misc-content? object) - (list-of-type? object xml-misc-content-item?)) +(define-xml-type declaration + (version xml-version?) + (encoding xml-encoding?) + (standalone (lambda (object) (member object '(#f "yes" "no"))))) -(define (xml-misc-content-item? object) - (or (xml-comment? object) - (xml-whitespace-string? object) - (xml-processing-instructions? object))) +(define-xml-type attribute + (name xml-name?) + (value canonicalize canonicalize-char-data)) + +(define-xml-type element + (name xml-name?) + (attributes xml-attribute-list?) + (content canonicalize canonicalize-content)) + +(define-xml-type comment + (text canonicalize canonicalize-char-data)) + +(define-xml-type processing-instructions + (name + (lambda (object) + (and (xml-name-symbol? object) + (not (xml-name=? object 'xml))))) + (text canonicalize canonicalize-char-data)) + +(define-xml-type dtd + (root xml-name-symbol?) + (external (lambda (object) + (or (not object) + (xml-external-id? object)))) + (internal (lambda (object) + (list-of-type? object + (lambda (object) + (or (xml-comment? object) + (xml-!element? object) + (xml-!attlist? object) + (xml-!entity? object) + (xml-unparsed-!entity? object) + (xml-parameter-!entity? object) + (xml-!notation? object) + (xml-parameter-entity-ref? object))))))) + +(define-xml-type external-id + (id (lambda (object) + (or (not object) + (public-id? object)))) + (uri canonicalize + (lambda (object) + (and object + (->uri (canonicalize-char-data object)))))) + +(define-xml-type !element + (name xml-name-symbol?) + (content-type + (lambda (object) + (or (eq? object '|EMPTY|) + (eq? object '|ANY|) + (and (pair? object) + (eq? '|#PCDATA| (car object)) + (list-of-type? (cdr object) xml-name-symbol?)) + (letrec + ((children? + (lambda (object) + (maybe-wrapped object + (lambda (object) + (and (pair? object) + (or (eq? 'alt (car object)) + (eq? 'seq (car object))) + (list-of-type? (cdr object) cp?)))))) + (cp? + (lambda (object) + (or (maybe-wrapped object xml-name-symbol?) + (children? object)))) + (maybe-wrapped + (lambda (object pred) + (or (pred object) + (and (pair? object) + (or (eq? #\? (car object)) + (eq? #\* (car object)) + (eq? #\+ (car object))) + (pair? (cdr object)) + (pred (cadr object)) + (null? (cddr object))))))) + (children? object)))))) + +(define-xml-type !attlist + (name xml-name-symbol?) + (definitions canonicalize + (lambda (object) + (if (not (list-of-type? object + (lambda (item) + (and (pair? item) + (xml-name-symbol? (car item)) + (pair? (cdr item)) + (!attlist-type? (cadr item)) + (pair? (cddr item)) + (!attlist-default? (caddr item)) + (null? (cdddr item)))))) + (error:wrong-type-datum object "an XML !ATTLIST definition")) + (map (lambda (item) + (let ((d (caddr item))) + (if (pair? d) + (list (car item) + (cadr item) + (cons (car d) (canonicalize-char-data (cdr d)))) + item))) + object)))) + +(define-xml-type !entity + (name xml-name-symbol?) + (value canonicalize canonicalize-entity-value)) + +(define-xml-type unparsed-!entity + (name xml-name-symbol?) + (id xml-external-id?) + (notation xml-name-symbol?)) + +(define-xml-type parameter-!entity + (name xml-name-symbol?) + (value canonicalize canonicalize-entity-value)) + +(define-xml-type !notation + (name xml-name-symbol?) + (id xml-external-id?)) + +(define-xml-type entity-ref + (name xml-name-symbol?)) + +(define-xml-type parameter-entity-ref + (name xml-name-symbol?)) + +(define (string-composed-of? object char-set) + (and (string? object) + (string-every (char-set-predicate char-set) object))) (define (xml-whitespace-string? object) (string-composed-of? object char-set:xml-whitespace)) +(register-predicate! xml-whitespace-string? 'xml-whitespace-string '<= string?) -(define (string-composed-of? string char-set) - (and (string? string) - (string-every (char-set-predicate char-set) string))) +(define xml-misc-content-item? + (disjoin xml-comment? + xml-whitespace-string? + xml-processing-instructions?)) -(define (substring-composed-of? string start end char-set) - (let loop ((index start)) - (or (fix:= index end) - (and (char-in-set? (string-ref string index) char-set) - (loop (fix:+ index 1)))))) - -(define-xml-type declaration - (version xml-version?) - (encoding xml-encoding?) - (standalone (lambda (object) (member object '(#f "yes" "no"))))) +(define xml-misc-content? + (is-list-of xml-misc-content-item?)) (define (xml-version? object) (and (string-composed-of? object char-set:xml-version) (fix:> (string-length object) 0))) +(register-predicate! xml-version? 'xml-version '<= string?) (define char-set:xml-version - (char-set-union char-set:alphanumeric - (string->char-set "_.:-"))) + (char-set-union char-set:alphanumeric (string->char-set "_.:-"))) (define (xml-encoding? object) (or (not object) @@ -139,41 +260,24 @@ USA. (let ((end (string-length object))) (and (fix:> end 0) (char-alphabetic? (string-ref object 0)) - (substring-composed-of? object 1 end - char-set:xml-encoding)))))) + (string-composed-of? object char-set:xml-encoding 1 end)))))) +(register-predicate! xml-encoding? 'xml-encoding '<= string?) (define char-set:xml-encoding - (char-set-union char-set:alphanumeric - (string->char-set "_.-"))) - -(define-xml-type attribute - (name xml-name?) - (value canonicalize canonicalize-char-data)) + (char-set-union char-set:alphanumeric (string->char-set "_.-"))) -(define (xml-char-data? object) - (or (xml-char? object) - (and (string? object) - (string-of-xml-chars? object)))) +(define (string-of-xml-chars? object) + (string-composed-of? object char-set:xml-char)) +(register-predicate! string-of-xml-chars? 'string-of-xml-chars '<= string?) -(define (string-of-xml-chars? string) - (string-every xml-char? string)) +(define xml-char-data? + (disjoin xml-char? string-of-xml-chars?)) (define (canonicalize-char-data object) - (cond ((xml-char? object) - (string object)) - ((string? object) - (if (not (string-of-xml-chars? object)) - (error:wrong-type-datum object "well-formed XML char data")) - object) - ((uri? object) - (uri->string object)) - (else - (error:wrong-type-datum object "an XML char data")))) - -(define-xml-type element - (name xml-name?) - (attributes xml-attribute-list?) - (content canonicalize canonicalize-content)) + (cond ((xml-char? object) (string object)) + ((string-of-xml-chars? object) object) + ((uri? object) (uri->string object)) + (else (error:not-a xml-char-data? object)))) (define (xml-attribute-list? object) (and (list-of-type? object xml-attribute?) @@ -185,15 +289,16 @@ USA. (cdr attrs))) (loop (cdr attrs))) #t)))) +(register-predicate! xml-attribute-list? 'xml-attribute-list '<= string?) -(define (xml-content? object) - (list-of-type? object xml-content-item?)) +(define xml-content-item? + (disjoin xml-char-data? + xml-comment? + xml-element? + xml-processing-instructions?)) -(define (xml-content-item? object) - (or (xml-char-data? object) - (xml-comment? object) - (xml-element? object) - (xml-processing-instructions? object))) +(define xml-content? + (is-list-of xml-content-item?)) (define (canonicalize-content content) (letrec @@ -230,17 +335,17 @@ USA. (define (xml-element-child name elt #!optional error?) (let ((child - (let ((name (xml-name-arg name 'XML-ELEMENT-CHILD))) + (let ((name (xml-name-arg name 'xml-element-child))) (find (lambda (item) (and (xml-element? item) (xml-name=? (xml-element-name item) name))) (xml-element-content elt))))) (if (and (not child) (if (default-object? error?) #f error?)) - (error:bad-range-argument name 'XML-ELEMENT-CHILD)) + (error:bad-range-argument name 'xml-element-child)) child)) (define (xml-element-children name elt) - (let ((name (xml-name-arg name 'XML-ELEMENT-CHILDREN))) + (let ((name (xml-name-arg name 'xml-element-children))) (filter (lambda (item) (and (xml-element? item) (xml-name=? (xml-element-name item) name))) @@ -248,16 +353,16 @@ USA. (define (find-xml-attr name elt #!optional error?) (let ((attr - (find (let ((name (xml-name-arg name 'FIND-XML-ATTR))) + (find (let ((name (xml-name-arg name 'find-xml-attr))) (lambda (attr) (xml-name=? (xml-attribute-name attr) name))) (if (xml-element? elt) (xml-element-attributes elt) (begin - (guarantee xml-attribute-list? elt 'FIND-XML-ATTR) + (guarantee xml-attribute-list? elt 'find-xml-attr) elt))))) (if (and (not attr) (if (default-object? error?) #f error?)) - (error:bad-range-argument name 'FIND-XML-ATTR)) + (error:bad-range-argument name 'find-xml-attr)) (and attr (xml-attribute-value attr)))) @@ -268,106 +373,14 @@ USA. (guarantee xml-name? arg caller) arg))) -(define-xml-type comment - (text canonicalize canonicalize-char-data)) - -(define-xml-type processing-instructions - (name - (lambda (object) - (and (xml-name-symbol? object) - (not (xml-name=? object 'xml))))) - (text canonicalize canonicalize-char-data)) - -(define-xml-type dtd - (root xml-name-symbol?) - (external (lambda (object) - (or (not object) - (xml-external-id? object)))) - (internal (lambda (object) - (list-of-type? object - (lambda (object) - (or (xml-comment? object) - (xml-!element? object) - (xml-!attlist? object) - (xml-!entity? object) - (xml-unparsed-!entity? object) - (xml-parameter-!entity? object) - (xml-!notation? object) - (xml-parameter-entity-ref? object))))))) - -(define-xml-type external-id - (id (lambda (object) - (or (not object) - (public-id? object)))) - (uri canonicalize - (lambda (object) - (and object - (->uri (canonicalize-char-data object)))))) - (define (public-id? object) (string-composed-of? object char-set:xml-public-id)) +(register-predicate! public-id? 'public-id '<= string?) (define char-set:xml-public-id (char-set-union char-set:alphanumeric (string->char-set " \r\n-'()+,./:=?;!*#@$_%"))) -(define-xml-type !element - (name xml-name-symbol?) - (content-type - (lambda (object) - (or (eq? object '|EMPTY|) - (eq? object '|ANY|) - (and (pair? object) - (eq? '|#PCDATA| (car object)) - (list-of-type? (cdr object) xml-name-symbol?)) - (letrec - ((children? - (lambda (object) - (maybe-wrapped object - (lambda (object) - (and (pair? object) - (or (eq? 'alt (car object)) - (eq? 'seq (car object))) - (list-of-type? (cdr object) cp?)))))) - (cp? - (lambda (object) - (or (maybe-wrapped object xml-name-symbol?) - (children? object)))) - (maybe-wrapped - (lambda (object pred) - (or (pred object) - (and (pair? object) - (or (eq? #\? (car object)) - (eq? #\* (car object)) - (eq? #\+ (car object))) - (pair? (cdr object)) - (pred (cadr object)) - (null? (cddr object))))))) - (children? object)))))) - -(define-xml-type !attlist - (name xml-name-symbol?) - (definitions canonicalize - (lambda (object) - (if (not (list-of-type? object - (lambda (item) - (and (pair? item) - (xml-name-symbol? (car item)) - (pair? (cdr item)) - (!attlist-type? (cadr item)) - (pair? (cddr item)) - (!attlist-default? (caddr item)) - (null? (cdddr item)))))) - (error:wrong-type-datum object "an XML !ATTLIST definition")) - (map (lambda (item) - (let ((d (caddr item))) - (if (pair? d) - (list (car item) - (cadr item) - (cons (car d) (canonicalize-char-data (cdr d)))) - item))) - object)))) - (define (!attlist-type? object) (or (eq? object '|CDATA|) (eq? object '|IDREFS|) @@ -382,6 +395,7 @@ USA. (list-of-type? (cdr object) xml-name-symbol?)) (and (eq? (car object) 'enumerated) (list-of-type? (cdr object) xml-nmtoken?)))))) +(register-predicate! !attlist-type? '!attlist-type) (define (!attlist-default? object) (or (eq? object '|#REQUIRED|) @@ -390,19 +404,7 @@ USA. (or (eq? (car object) '|#FIXED|) (eq? (car object) 'default)) (xml-char-data? (cdr object))))) - -(define-xml-type !entity - (name xml-name-symbol?) - (value canonicalize canonicalize-entity-value)) - -(define-xml-type unparsed-!entity - (name xml-name-symbol?) - (id xml-external-id?) - (notation xml-name-symbol?)) - -(define-xml-type parameter-!entity - (name xml-name-symbol?) - (value canonicalize canonicalize-entity-value)) +(register-predicate! !attlist-default? '!attlist-default) (define (canonicalize-entity-value object) (if (xml-external-id? object) @@ -417,16 +419,6 @@ USA. (error:wrong-type-datum object "an XML !ENTITY value")) (canonicalize-content object)))) -(define-xml-type !notation - (name xml-name-symbol?) - (id xml-external-id?)) - -(define-xml-type entity-ref - (name xml-name-symbol?)) - -(define-xml-type parameter-entity-ref - (name xml-name-symbol?)) - (define-syntax define-xml-printer (sc-macro-transformer (lambda (form environment) -- 2.25.1