(lambda (char) char #f))
'PORT port
options)))
-
-(define-structure (ctx (type-descriptor <ctx>)
- (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))
+\f
+(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 <ctx>
+ (%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! <ctx>
+ (standard-unparser-method 'xml-output-context #f))
(define (emit-char char ctx)
(let ((port (ctx-port ctx)))
(and (ctx-indent-dtd? ctx)
(ctx-start-col ctx)))
\f
-(define-generic %write-xml (object ctx))
-
-(define-method %write-xml ((document <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 <xml-declaration>) ctx)
- (emit-string "<?xml version=\"" ctx)
- (emit-string (xml-declaration-version declaration) ctx)
- (emit-string "\"" ctx)
- (if (xml-declaration-encoding declaration)
- (begin
- (emit-string " encoding=\"" ctx)
- (emit-string (xml-declaration-encoding declaration) ctx)
- (emit-string "\"" ctx)))
- (if (xml-declaration-standalone declaration)
- (begin
- (emit-string " standalone=\"" ctx)
- (emit-string (xml-declaration-standalone declaration) ctx)
- (emit-string "\"" ctx)))
- (emit-string "?>" ctx))
-
-(define-method %write-xml ((element <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 "<?xml version=\"" ctx)
+ (emit-string (xml-declaration-version declaration) ctx)
+ (emit-string "\"" ctx)
+ (if (xml-declaration-encoding declaration)
(begin
- (emit-string ">" ctx)
- (for-each (lambda (content) (%write-xml content ctx))
- content)
- (emit-string "</" ctx)
- (write-xml-name name ctx)
- (emit-string ">" ctx))
- (emit-string " />" ctx))))
-
-(define-method %write-xml ((comment <xml-comment>) ctx)
- (emit-string "<!--" ctx)
- (emit-string (xml-comment-text comment) ctx)
- (emit-string "-->" ctx))
-
-(define-method %write-xml ((pi <xml-processing-instructions>) ctx)
- (emit-string "<?" ctx)
- (write-xml-name (xml-processing-instructions-name pi) ctx)
- (let ((text (xml-processing-instructions-text pi)))
- (if (fix:> (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)
+ (write-xml-name name ctx)
+ (emit-string ">" ctx))
+ (emit-string " />" ctx)))))
+
+(define-predicate-dispatch-handler %write-xml (list xml-comment? ctx?)
+ (lambda (comment ctx)
+ (emit-string "<!--" ctx)
+ (emit-string (xml-comment-text comment) ctx)
+ (emit-string "-->" ctx)))
\f
-(define-method %write-xml ((dtd <xml-dtd>) ctx)
- ;;root external internal
- (emit-string "<!DOCTYPE " ctx)
- (let ((col (dtd-start-col ctx)))
- (write-xml-name (xml-dtd-root dtd) ctx)
- (if (xml-dtd-external dtd)
- (write-xml-external-id (xml-dtd-external dtd) col ctx))
- (if (pair? (xml-dtd-internal dtd))
- (begin
- (if (xml-dtd-external dtd)
- (emit-newline ctx)
- (emit-string " " ctx))
- (emit-string "[" ctx)
- (emit-newline ctx)
- (for-each (lambda (element)
- (%write-xml element ctx)
- (emit-newline ctx))
- (xml-dtd-internal dtd))
- (emit-string "]" ctx)))
- (emit-string ">" ctx)))
-
-(define-method %write-xml ((decl <xml-!element>) ctx)
- (emit-string "<!ELEMENT " ctx)
- (write-xml-name (xml-!element-name decl) ctx)
- (emit-string " " ctx)
- (let ((type (xml-!element-content-type decl)))
- (cond ((symbol? type)
- (emit-string (string-upcase (symbol->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 "<?" ctx)
+ (write-xml-name (xml-processing-instructions-name pi) ctx)
+ (let ((text (xml-processing-instructions-text pi)))
+ (if (fix:> (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 "<!DOCTYPE " ctx)
+ (let ((col (dtd-start-col ctx)))
+ (write-xml-name (xml-dtd-root dtd) ctx)
+ (if (xml-dtd-external dtd)
+ (write-xml-external-id (xml-dtd-external dtd) col ctx))
+ (if (pair? (xml-dtd-internal dtd))
+ (begin
+ (if (xml-dtd-external dtd)
+ (emit-newline ctx)
+ (emit-string " " ctx))
+ (emit-string "[" ctx)
+ (emit-newline ctx)
+ (for-each (lambda (element)
+ (%write-xml element ctx)
+ (emit-newline ctx))
+ (xml-dtd-internal dtd))
+ (emit-string "]" ctx)))
+ (emit-string ">" ctx))))
\f
-(define-method %write-xml ((decl <xml-!attlist>) ctx)
- (emit-string "<!ATTLIST " ctx)
- (write-xml-name (xml-!attlist-name decl) ctx)
- (let ((definitions (xml-!attlist-definitions decl))
- (write-definition
- (lambda (definition)
- (write-xml-name (car definition) ctx)
- (emit-string " " ctx)
- (let ((type (cadr definition)))
- (cond ((symbol? type)
- (emit-string (string-upcase (symbol->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))
-\f
-(define-method %write-xml ((decl <xml-!entity>) ctx)
- (emit-string "<!ENTITY " ctx)
- (let ((col (dtd-start-col ctx)))
- (write-xml-name (xml-!entity-name decl) ctx)
- (emit-string " " ctx)
- (write-entity-value (xml-!entity-value decl) col ctx)
- (emit-string ">" ctx)))
-
-(define-method %write-xml ((decl <xml-unparsed-!entity>) ctx)
- (emit-string "<!ENTITY " ctx)
- (let ((col (dtd-start-col ctx)))
- (write-xml-name (xml-unparsed-!entity-name decl) ctx)
+(define-predicate-dispatch-handler %write-xml (list xml-!element? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!ELEMENT " ctx)
+ (write-xml-name (xml-!element-name decl) ctx)
(emit-string " " ctx)
- (write-xml-external-id (xml-unparsed-!entity-id decl) col ctx)
- (emit-string " NDATA " ctx)
- (write-xml-name (xml-unparsed-!entity-notation decl) ctx)
+ (let ((type (xml-!element-content-type decl)))
+ (cond ((symbol? type)
+ (emit-string (string-upcase (symbol->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 <xml-parameter-!entity>) ctx)
- (emit-string "<!ENTITY " ctx)
- (let ((col (dtd-start-col ctx)))
- (emit-string "% " ctx)
- (write-xml-name (xml-parameter-!entity-name decl) ctx)
- (emit-string " " ctx)
- (write-entity-value (xml-parameter-!entity-value decl) col ctx)
- (emit-string ">" ctx)))
-
-(define-method %write-xml ((decl <xml-!notation>) ctx)
- (emit-string "<!NOTATION " ctx)
- (let ((col (dtd-start-col ctx)))
- (write-xml-name (xml-!notation-name decl) ctx)
- (emit-string " " ctx)
- (write-xml-external-id (xml-!notation-id decl) col ctx)
+\f
+(define-predicate-dispatch-handler %write-xml (list xml-!attlist? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!ATTLIST " ctx)
+ (write-xml-name (xml-!attlist-name decl) ctx)
+ (let ((definitions (xml-!attlist-definitions decl))
+ (write-definition
+ (lambda (definition)
+ (write-xml-name (car definition) ctx)
+ (emit-string " " ctx)
+ (let ((type (cadr definition)))
+ (cond ((symbol? type)
+ (emit-string (string-upcase (symbol->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 <string>) ctx)
- (write-escaped-string string
- '((#\< . "<")
- (#\& . "&"))
- ctx))
-
-(define-method %write-xml ((ref <xml-entity-ref>) ctx)
- (emit-string "&" ctx)
- (write-xml-name (xml-entity-ref-name ref) ctx)
- (emit-string ";" ctx))
-
-(define-method %write-xml ((ref <xml-parameter-entity-ref>) ctx)
- (emit-string "%" ctx)
- (write-xml-name (xml-parameter-entity-ref-name ref) ctx)
- (emit-string ";" ctx))
+\f
+(define-predicate-dispatch-handler %write-xml (list xml-!entity? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (dtd-start-col ctx)))
+ (write-xml-name (xml-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-entity-value (xml-!entity-value decl) col ctx)
+ (emit-string ">" ctx))))
+
+(define-predicate-dispatch-handler %write-xml (list xml-unparsed-!entity? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (dtd-start-col ctx)))
+ (write-xml-name (xml-unparsed-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-xml-external-id (xml-unparsed-!entity-id decl) col ctx)
+ (emit-string " NDATA " ctx)
+ (write-xml-name (xml-unparsed-!entity-notation decl) ctx)
+ (emit-string ">" ctx))))
+
+(define-predicate-dispatch-handler %write-xml (list xml-parameter-!entity? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (dtd-start-col ctx)))
+ (emit-string "% " ctx)
+ (write-xml-name (xml-parameter-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-entity-value (xml-parameter-!entity-value decl) col ctx)
+ (emit-string ">" ctx))))
+
+(define-predicate-dispatch-handler %write-xml (list xml-!notation? ctx?)
+ (lambda (decl ctx)
+ (emit-string "<!NOTATION " ctx)
+ (let ((col (dtd-start-col ctx)))
+ (write-xml-name (xml-!notation-name decl) ctx)
+ (emit-string " " ctx)
+ (write-xml-external-id (xml-!notation-id decl) col 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)))
\f
(define (write-xml-attributes attrs suffix-cols ctx)
(let ((col
(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)
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))
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))))))))
(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))))))
+\f
+(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?))
+\f
+(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)
(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 "_.-")))
-\f
-(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?)
(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?))
\f
(define (canonicalize-content content)
(letrec
(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)))
(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))))
(guarantee xml-name? arg caller)
arg)))
\f
-(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))))))
-\f
-(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|)
(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|)
(or (eq? (car object) '|#FIXED|)
(eq? (car object) 'default))
(xml-char-data? (cdr object)))))
-\f
-(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)
(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)
projects / mit-scheme.git / commitdiff