diff options
Diffstat (limited to 'xml-parse.scm')
| -rw-r--r-- | xml-parse.scm | 2025 |
1 files changed, 2025 insertions, 0 deletions
diff --git a/xml-parse.scm b/xml-parse.scm new file mode 100644 index 0000000..6056220 --- /dev/null +++ b/xml-parse.scm @@ -0,0 +1,2025 @@ +;;;;"xml-parse" XML parsing and conversion to SXML (Scheme-XML) +;;; Copyright (C) 2007 Aubrey Jaffer +;;; 2007-04 jaffer: demacrofied from public-domain SSAX 5.1 +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;;@code{(require 'xml-parse)} or @code{(require 'ssax)} +;; +;;@noindent +;;The XML standard document referred to in this module is@* +;;@url{http://www.w3.org/TR/1998/REC-xml-19980210.html}. +;; +;;@noindent +;;The present frameworks fully supports the XML Namespaces +;;Recommendation@* +;;@url{http://www.w3.org/TR/REC-xml-names}. + +(require 'rev2-procedures) ; for substring-move-left! +(require 'string-search) +(require 'let-values) +(require 'values) +(require 'srfi-1) ; for fold-right, fold, cons* + +;;@subsection String Glue + +;;;; Three functions from SRFI-13 +; procedure string-concatenate-reverse STRINGS [FINAL END] +(define (ssax:string-concatenate-reverse strs final end) + (if (null? strs) (substring final 0 end) + (let* + ((total-len + (let loop ((len end) (lst strs)) + (if (null? lst) len + (loop (+ len (string-length (car lst))) (cdr lst))))) + (result (make-string total-len))) + (let loop ((len end) (j total-len) (str final) (lst strs)) + (substring-move-left! str 0 len result (- j len)) + (if (null? lst) result + (loop (string-length (car lst)) (- j len) + (car lst) (cdr lst))))))) +; string-concatenate/shared STRING-LIST -> STRING +(define (ssax:string-concatenate/shared strs) + (cond ((null? strs) "") ; Test for the fast path first + ((null? (cdr strs)) (car strs)) + (else + (let* + ((total-len + (let loop ((len (string-length (car strs))) (lst (cdr strs))) + (if (null? lst) len + (loop (+ len (string-length (car lst))) (cdr lst))))) + (result (make-string total-len))) + (let loop ((j 0) (str (car strs)) (lst (cdr strs))) + (substring-move-left! str 0 (string-length str) result j) + (if (null? lst) result + (loop (+ j (string-length str)) + (car lst) (cdr lst)))))))) +; string-concatenate-reverse/shared STRING-LIST [FINAL-STRING END] -> STRING +; We do not use the optional arguments of this procedure. Therefore, +; we do not implement them. See SRFI-13 for the complete +; implementation. +(define (ssax:string-concatenate-reverse/shared strs) + (cond ((null? strs) "") ; Test for the fast path first + ((null? (cdr strs)) (car strs)) + (else + (ssax:string-concatenate-reverse (cdr strs) + (car strs) + (string-length (car strs)))))) + + +;;@args list-of-frags +;; +;;Given the list of fragments (some of which are text strings), +;;reverse the list and concatenate adjacent text strings. If +;;LIST-OF-FRAGS has zero or one element, the result of the procedure +;;is @code{equal?} to its argument. +(define (ssax:reverse-collect-str fragments) + (cond + ((null? fragments) '()) ; a shortcut + ((null? (cdr fragments)) fragments) ; see the comment above + (else + (let loop ((fragments fragments) (result '()) (strs '())) + (cond + ((null? fragments) + (if (null? strs) + result + (cons (ssax:string-concatenate/shared strs) result))) + ((string? (car fragments)) + (loop (cdr fragments) result (cons (car fragments) strs))) + (else + (loop (cdr fragments) + (cons (car fragments) + (if (null? strs) + result + (cons (ssax:string-concatenate/shared strs) result))) + '()))))))) + +;;@args list-of-frags +;; +;;Given the list of fragments (some of which are text strings), +;;reverse the list and concatenate adjacent text strings while +;;dropping "unsignificant" whitespace, that is, whitespace in front, +;;behind and between elements. The whitespace that is included in +;;character data is not affected. +;; +;;Use this procedure to "intelligently" drop "insignificant" +;;whitespace in the parsed SXML. If the strict compliance with the +;;XML Recommendation regarding the whitespace is desired, use the +;;@code{ssax:reverse-collect-str} procedure instead. +(define (ssax:reverse-collect-str-drop-ws fragments) + ;; Test if a string is made of only whitespace. + ;; An empty string is considered made of whitespace as well + (define (string-whitespace? str) + (let ((len (string-length str))) + (cond ((zero? len) #t) + ((= 1 len) (char-whitespace? (string-ref str 0))) + (else + (let loop ((i 0)) + (or (>= i len) + (and (char-whitespace? (string-ref str i)) + (loop (+ 1 i))))))))) + (cond + ((null? fragments) '()) ; a shortcut + ((null? (cdr fragments)) ; another shortcut + (if (and (string? (car fragments)) (string-whitespace? (car fragments))) + '() ; remove trailing ws + fragments)) + (else + (let loop ((fragments fragments) (result '()) (strs '()) + (all-whitespace? #t)) + (cond + ((null? fragments) + (if all-whitespace? + result ; remove leading ws + (cons (ssax:string-concatenate/shared strs) result))) + ((string? (car fragments)) + (loop (cdr fragments) + result + (cons (car fragments) strs) + (and all-whitespace? (string-whitespace? (car fragments))))) + (else + (loop (cdr fragments) + (cons (car fragments) + (if all-whitespace? + result + (cons (ssax:string-concatenate/shared strs) result))) + '() + #t))))))) + +;;@subsection Character and Token Functions +;; +;;The following functions either skip, or build and return tokens, +;;according to inclusion or delimiting semantics. The list of +;;characters to expect, include, or to break at may vary from one +;;invocation of a function to another. This allows the functions to +;;easily parse even context-sensitive languages. +;; +;;Exceptions are mentioned specifically. The list of expected +;;characters (characters to skip until, or break-characters) may +;;include an EOF "character", which is coded as symbol *eof* +;; +;;The input stream to parse is specified as a PORT, which is the last +;;argument. + +;;@args char-list string port +;; +;;Reads a character from the @3 and looks it up in the +;;@1 of expected characters. If the read character was +;;found among expected, it is returned. Otherwise, the +;;procedure writes a message using @2 as a comment +;;and quits. +(define (ssax:assert-current-char expected-chars comment port) + (let ((c (read-char port))) + (if (memv c expected-chars) c + (slib:error port "Wrong character " c + " (0x" (if (eof-object? c) + "*eof*" + (number->string (char->integer c) 16)) ") " + comment ". " expected-chars " expected")))) + +;;@args char-list port +;; +;;Reads characters from the @2 and disregards them, as long as they +;;are mentioned in the @1. The first character (which may be EOF) +;;peeked from the stream that is @emph{not} a member of the @1 is +;;returned. +(define (ssax:skip-while skip-chars port) + (do ((c (peek-char port) (peek-char port))) + ((not (memv c skip-chars)) c) + (read-char port))) + +;;; Stream tokenizers +;; +;;Note: since we can't tell offhand how large the token being read is +;;going to be, we make a guess, pre-allocate a string, and grow it by +;;quanta if necessary. The quantum is always the length of the string +;;before it was extended the last time. Thus the algorithm does a +;;Fibonacci-type extension, which has been proven optimal. +;; +;;Size 32 turns out to be fairly good, on average. That policy is +;;good only when a Scheme system is multi-threaded with preemptive +;;scheduling, or when a Scheme system supports shared substrings. In +;;all the other cases, it's better for ssax:init-buffer to return the +;;same static buffer. ssax:next-token* functions return a copy (a +;;substring) of accumulated data, so the same buffer can be reused. +;;We shouldn't worry about an incoming token being too large: +;;ssax:next-token will use another chunk automatically. Still, the +;;best size for the static buffer is to allow most of the tokens to +;;fit in. Using a static buffer _dramatically_ reduces the amount of +;;produced garbage (e.g., during XML parsing). + +;;@body +;; +;;Returns an initial buffer for @code{ssax:next-token*} procedures. +;;@0 may allocate a new buffer at each invocation. +(define (ssax:init-buffer) (make-string 32)) + +;;;(define ssax:init-buffer +;;; (let ((buffer (make-string 512))) +;;; (lambda () buffer))) + +;;@args prefix-char-list break-char-list comment-string port +;; +;;Skips any number of the prefix characters (members of the @1), if +;;any, and reads the sequence of characters up to (but not including) +;;a break character, one of the @2. +;; +;;The string of characters thus read is returned. The break character +;;is left on the input stream. @2 may include the symbol @code{*eof*}; +;;otherwise, EOF is fatal, generating an error message including a +;;specified @3. +(define (ssax:next-token prefix-skipped-chars break-chars comment port) + (let outer ((buffer (ssax:init-buffer)) (filled-buffer-l '()) + (c (ssax:skip-while prefix-skipped-chars port))) + (let ((curr-buf-len (string-length buffer))) + (let loop ((i 0) (c c)) + (cond + ((memv c break-chars) + (if (null? filled-buffer-l) (substring buffer 0 i) + (ssax:string-concatenate-reverse filled-buffer-l buffer i))) + ((eof-object? c) + (if (memq '*eof* break-chars) ; was EOF expected? + (if (null? filled-buffer-l) (substring buffer 0 i) + (ssax:string-concatenate-reverse filled-buffer-l buffer i)) + (slib:error port "EOF while reading a token " comment))) + ((>= i curr-buf-len) + (outer (make-string curr-buf-len) + (cons buffer filled-buffer-l) c)) + (else + (string-set! buffer i c) + (read-char port) ; move to the next char + (loop (+ 1 i) (peek-char port)))))))) + +;;@noindent +;;@code{ssax:next-token-of} is similar to @code{ssax:next-token} +;;except that it implements an inclusion rather than delimiting +;;semantics. + +;;@args inc-charset port +;; +;;Reads characters from the @2 that belong to the list of characters +;;@1. The reading stops at the first character which is not a member +;;of the set. This character is left on the stream. All the read +;;characters are returned in a string. +;; +;;@args pred port +;; +;;Reads characters from the @2 for which @var{pred} (a procedure of +;;one argument) returns non-#f. The reading stops at the first +;;character for which @var{pred} returns #f. That character is left +;;on the stream. All the results of evaluating of @var{pred} up to #f +;;are returned in a string. +;; +;;@var{pred} is a procedure that takes one argument (a character or +;;the EOF object) and returns a character or #f. The returned +;;character does not have to be the same as the input argument to the +;;@var{pred}. For example, +;; +;;@example +;;(ssax:next-token-of (lambda (c) +;; (cond ((eof-object? c) #f) +;; ((char-alphabetic? c) (char-downcase c)) +;; (else #f))) +;; (current-input-port)) +;;@end example +;; +;;will try to read an alphabetic token from the current input port, +;;and return it in lower case. +(define (ssax:next-token-of incl-list/pred port) + (let* ((buffer (ssax:init-buffer)) + (curr-buf-len (string-length buffer))) + (if (procedure? incl-list/pred) + (let outer ((buffer buffer) (filled-buffer-l '())) + (let loop ((i 0)) + (if (>= i curr-buf-len) ; make sure we have space + (outer (make-string curr-buf-len) (cons buffer filled-buffer-l)) + (let ((c (incl-list/pred (peek-char port)))) + (if c + (begin + (string-set! buffer i c) + (read-char port) ; move to the next char + (loop (+ 1 i))) + ;; incl-list/pred decided it had had enough + (if (null? filled-buffer-l) (substring buffer 0 i) + (ssax:string-concatenate-reverse filled-buffer-l buffer i))))))) + + ;; incl-list/pred is a list of allowed characters + (let outer ((buffer buffer) (filled-buffer-l '())) + (let loop ((i 0)) + (if (>= i curr-buf-len) ; make sure we have space + (outer (make-string curr-buf-len) (cons buffer filled-buffer-l)) + (let ((c (peek-char port))) + (cond + ((not (memv c incl-list/pred)) + (if (null? filled-buffer-l) (substring buffer 0 i) + (ssax:string-concatenate-reverse filled-buffer-l buffer i))) + (else + (string-set! buffer i c) + (read-char port) ; move to the next char + (loop (+ 1 i)))))))) + ))) + +;;@body +;; +;;Reads @1 characters from the @2, and returns them in a string. If +;;EOF is encountered before @1 characters are read, a shorter string +;;will be returned. +(define (ssax:read-string len port) + (define buffer (make-string len)) + (do ((idx 0 (+ 1 idx))) + ((>= idx len) idx) + (let ((chr (read-char port))) + (cond ((eof-object? byt) + (set! idx (+ -1 idx)) + (set! len idx)) + (else (string-set! buffer idx chr)))))) + +;;@subsection Data Types +;; +;;@table @code +;; +;;@item TAG-KIND +;; +;;A symbol @samp{START}, @samp{END}, @samp{PI}, @samp{DECL}, +;;@samp{COMMENT}, @samp{CDSECT}, or @samp{ENTITY-REF} that identifies +;;a markup token +;; +;;@item UNRES-NAME +;; +;;a name (called GI in the XML Recommendation) as given in an XML +;;document for a markup token: start-tag, PI target, attribute name. +;;If a GI is an NCName, UNRES-NAME is this NCName converted into a +;;Scheme symbol. If a GI is a QName, @samp{UNRES-NAME} is a pair of +;;symbols: @code{(@var{PREFIX} . @var{LOCALPART})}. +;; +;;@item RES-NAME +;; +;;An expanded name, a resolved version of an @samp{UNRES-NAME}. For +;;an element or an attribute name with a non-empty namespace URI, +;;@samp{RES-NAME} is a pair of symbols, +;;@code{(@var{URI-SYMB} . @var{LOCALPART})}. +;;Otherwise, it's a single symbol. +;; +;;@item ELEM-CONTENT-MODEL +;; +;;A symbol: +;;@table @samp +;;@item ANY +;;anything goes, expect an END tag. +;;@item EMPTY-TAG +;;no content, and no END-tag is coming +;;@item EMPTY +;;no content, expect the END-tag as the next token +;;@item PCDATA +;;expect character data only, and no children elements +;;@item MIXED +;;@item ELEM-CONTENT +;;@end table +;; +;;@item URI-SYMB +;; +;;A symbol representing a namespace URI -- or other symbol chosen by +;;the user to represent URI. In the former case, @code{URI-SYMB} is +;;created by %-quoting of bad URI characters and converting the +;;resulting string into a symbol. +;; +;;@item NAMESPACES +;; +;;A list representing namespaces in effect. An element of the list +;;has one of the following forms: +;; +;;@table @code +;; +;;@item (@var{prefix} @var{uri-symb} . @var{uri-symb}) or +;; +;;@item (@var{prefix} @var{user-prefix} . @var{uri-symb}) +;;@var{user-prefix} is a symbol chosen by the user to represent the URI. +;; +;;@item (#f @var{user-prefix} . @var{uri-symb}) +;;Specification of the user-chosen prefix and a URI-SYMBOL. +;; +;;@item (*DEFAULT* @var{user-prefix} . @var{uri-symb}) +;;Declaration of the default namespace +;; +;;@item (*DEFAULT* #f . #f) +;;Un-declaration of the default namespace. This notation +;;represents overriding of the previous declaration +;; +;;@end table +;; +;;A NAMESPACES list may contain several elements for the same @var{prefix}. +;;The one closest to the beginning of the list takes effect. +;; +;;@item ATTLIST +;; +;;An ordered collection of (@var{NAME} . @var{VALUE}) pairs, where +;;@var{NAME} is a RES-NAME or an UNRES-NAME. The collection is an ADT. +;; +;;@item STR-HANDLER +;; +;;A procedure of three arguments: @var{string1} @var{string2} +;;@var{seed} returning a new @var{seed}. The procedure is supposed to +;;handle a chunk of character data @var{string1} followed by a chunk +;;of character data @var{string2}. @var{string2} is a short string, +;;often @samp{"\n"} and even @samp{""}. +;; +;;@item ENTITIES +;;An assoc list of pairs: +;;@lisp +;; (@var{named-entity-name} . @var{named-entity-body}) +;;@end lisp +;; +;;where @var{named-entity-name} is a symbol under which the entity was +;;declared, @var{named-entity-body} is either a string, or (for an +;;external entity) a thunk that will return an input port (from which +;;the entity can be read). @var{named-entity-body} may also be #f. +;;This is an indication that a @var{named-entity-name} is currently +;;being expanded. A reference to this @var{named-entity-name} will be +;;an error: violation of the WFC nonrecursion. +;; +;;@item XML-TOKEN +;; +;;This record represents a markup, which is, according to the XML +;;Recommendation, "takes the form of start-tags, end-tags, +;;empty-element tags, entity references, character references, +;;comments, CDATA section delimiters, document type declarations, and +;;processing instructions." +;; +;;@table @asis +;;@item kind +;;a TAG-KIND +;;@item head +;;an UNRES-NAME. For XML-TOKENs of kinds 'COMMENT and 'CDSECT, the +;;head is #f. +;;@end table +;; +;;For example, +;;@example +;;<P> => kind=START, head=P +;;</P> => kind=END, head=P +;;<BR/> => kind=EMPTY-EL, head=BR +;;<!DOCTYPE OMF ...> => kind=DECL, head=DOCTYPE +;;<?xml version="1.0"?> => kind=PI, head=xml +;;&my-ent; => kind=ENTITY-REF, head=my-ent +;;@end example +;; +;;Character references are not represented by xml-tokens as these +;;references are transparently resolved into the corresponding +;;characters. +;; +;;@item XML-DECL +;; +;;The record represents a datatype of an XML document: the list of +;;declared elements and their attributes, declared notations, list of +;;replacement strings or loading procedures for parsed general +;;entities, etc. Normally an XML-DECL record is created from a DTD or +;;an XML Schema, although it can be created and filled in in many +;;other ways (e.g., loaded from a file). +;; +;;@table @var +;;@item elems +;;an (assoc) list of decl-elem or #f. The latter instructs +;;the parser to do no validation of elements and attributes. +;; +;;@item decl-elem +;;declaration of one element: +;; +;;@code{(@var{elem-name} @var{elem-content} @var{decl-attrs})} +;; +;;@var{elem-name} is an UNRES-NAME for the element. +;; +;;@var{elem-content} is an ELEM-CONTENT-MODEL. +;; +;;@var{decl-attrs} is an @code{ATTLIST}, of +;;@code{(@var{attr-name} . @var{value})} associations. +;; +;;This element can declare a user procedure to handle parsing of an +;;element (e.g., to do a custom validation, or to build a hash of IDs +;;as they're encountered). +;; +;;@item decl-attr +;;an element of an @code{ATTLIST}, declaration of one attribute: +;; +;;@code{(@var{attr-name} @var{content-type} @var{use-type} @var{default-value})} +;; +;;@var{attr-name} is an UNRES-NAME for the declared attribute. +;; +;;@var{content-type} is a symbol: @code{CDATA}, @code{NMTOKEN}, +;;@code{NMTOKENS}, @dots{} or a list of strings for the enumerated +;;type. +;; +;;@var{use-type} is a symbol: @code{REQUIRED}, @code{IMPLIED}, or +;;@code{FIXED}. +;; +;;@var{default-value} is a string for the default value, or #f if not +;;given. +;; +;;@end table +;; +;;@end table + +;;see a function make-empty-xml-decl to make a XML declaration entry +;;suitable for a non-validating parsing. + +;;We define xml-token simply as a pair. +(define (make-xml-token kind head) (cons kind head)) +(define xml-token? pair?) +(define xml-token-kind car) +(define xml-token-head cdr) + +;;@subsection Low-Level Parsers and Scanners +;; +;;@noindent +;;These procedures deal with primitive lexical units (Names, +;;whitespaces, tags) and with pieces of more generic productions. +;;Most of these parsers must be called in appropriate context. For +;;example, @code{ssax:complete-start-tag} must be called only when the +;;start-tag has been detected and its GI has been read. + +(define char-return (integer->char 13)) +(define ssax:S-chars (map integer->char '(32 10 9 13))) + +;;@body +;; +;;Skip the S (whitespace) production as defined by +;;@example +;;[3] S ::= (#x20 | #x09 | #x0D | #x0A) +;;@end example +;; +;;@0 returns the first not-whitespace character it encounters while +;;scanning the @1. This character is left on the input stream. +(define (ssax:skip-S port) + (ssax:skip-while ssax:S-chars port)) + +;;Check to see if a-char may start a NCName +(define (ssax:ncname-starting-char? a-char) + (and (char? a-char) + (or (char-alphabetic? a-char) + (char=? #\_ a-char)))) + +;;@body +;; +;;Read a NCName starting from the current position in the @1 and +;;return it as a symbol. +;; +;;@example +;;[4] NameChar ::= Letter | Digit | '.' | '-' | '_' | ':' +;; | CombiningChar | Extender +;;[5] Name ::= (Letter | '_' | ':') (NameChar)* +;;@end example +;; +;;This code supports the XML Namespace Recommendation REC-xml-names, +;;which modifies the above productions as follows: +;; +;;@example +;;[4] NCNameChar ::= Letter | Digit | '.' | '-' | '_' +;; | CombiningChar | Extender +;;[5] NCName ::= (Letter | '_') (NCNameChar)* +;;@end example +;; +;;As the Rec-xml-names says, +;; +;;@quotation +;;"An XML document conforms to this specification if all other tokens +;;[other than element types and attribute names] in the document which +;;are required, for XML conformance, to match the XML production for +;;Name, match this specification's production for NCName." +;;@end quotation +;; +;;Element types and attribute names must match the production QName, +;;defined below. +(define (ssax:read-NCName port) + (let ((first-char (peek-char port))) + (or (ssax:ncname-starting-char? first-char) + (slib:error port "XMLNS [4] for '" first-char "'"))) + (string->symbol (ssax:next-token-of (lambda (c) + (cond + ((eof-object? c) #f) + ((char-alphabetic? c) c) + ((string-index "0123456789.-_" c) c) + (else #f))) + port))) + +;;@body +;; +;;Read a (namespace-) Qualified Name, QName, from the current position +;;in @1; and return an UNRES-NAME. +;; +;;From REC-xml-names: +;;@example +;;[6] QName ::= (Prefix ':')? LocalPart +;;[7] Prefix ::= NCName +;;[8] LocalPart ::= NCName +;;@end example +(define (ssax:read-QName port) + (let ((prefix-or-localpart (ssax:read-NCName port))) + (case (peek-char port) + ((#\:) ; prefix was given after all + (read-char port) ; consume the colon + (cons prefix-or-localpart (ssax:read-NCName port))) + (else prefix-or-localpart) ; Prefix was omitted + ))) + +;;The prefix of the pre-defined XML namespace +(define ssax:Prefix-XML (string->symbol "xml")) + +;;An UNRES-NAME that is postulated to be larger than anything that can +;;occur in a well-formed XML document. ssax:name-compare enforces +;;this postulate. +(define ssax:largest-unres-name (cons (string->symbol "#LARGEST-SYMBOL") + (string->symbol "#LARGEST-SYMBOL"))) + +;;Compare one RES-NAME or an UNRES-NAME with the other. +;;Return a symbol '<, '>, or '= depending on the result of +;;the comparison. +;;Names without @var{prefix} are always smaller than those with the @var{prefix}. +(define ssax:name-compare + (letrec ((symbol-compare + (lambda (symb1 symb2) + (cond + ((eq? symb1 symb2) '=) + ((string<? (symbol->string symb1) (symbol->string symb2)) + '<) + (else '>))))) + (lambda (name1 name2) + (cond + ((symbol? name1) (if (symbol? name2) (symbol-compare name1 name2) + '<)) + ((symbol? name2) '>) + ((eq? name2 ssax:largest-unres-name) '<) + ((eq? name1 ssax:largest-unres-name) '>) + ((eq? (car name1) (car name2)) ; prefixes the same + (symbol-compare (cdr name1) (cdr name2))) + (else (symbol-compare (car name1) (car name2))))))) + +;;@args port +;; +;;This procedure starts parsing of a markup token. The current +;;position in the stream must be @samp{<}. This procedure scans +;;enough of the input stream to figure out what kind of a markup token +;;it is seeing. The procedure returns an XML-TOKEN structure +;;describing the token. Note, generally reading of the current markup +;;is not finished! In particular, no attributes of the start-tag +;;token are scanned. +;; +;;Here's a detailed break out of the return values and the position in +;;the PORT when that particular value is returned: +;; +;;@table @asis +;; +;;@item PI-token +;; +;;only PI-target is read. To finish the Processing-Instruction and +;;disregard it, call @code{ssax:skip-pi}. @code{ssax:read-attributes} +;;may be useful as well (for PIs whose content is attribute-value +;;pairs). +;; +;;@item END-token +;; +;;The end tag is read completely; the current position is right after +;;the terminating @samp{>} character. +;; +;;@item COMMENT +;; +;;is read and skipped completely. The current position is right after +;;@samp{-->} that terminates the comment. +;; +;;@item CDSECT +;; +;;The current position is right after @samp{<!CDATA[}. Use +;;@code{ssax:read-cdata-body} to read the rest. +;; +;;@item DECL +;; +;;We have read the keyword (the one that follows @samp{<!}) +;;identifying this declaration markup. The current position is after +;;the keyword (usually a whitespace character) +;; +;;@item START-token +;; +;;We have read the keyword (GI) of this start tag. No attributes are +;;scanned yet. We don't know if this tag has an empty content either. +;;Use @code{ssax:complete-start-tag} to finish parsing of the token. +;; +;;@end table +(define ssax:read-markup-token ; procedure ssax:read-markup-token port + (let () + ;; we have read "<!-". Skip through the rest of the comment + ;; Return the 'COMMENT token as an indication we saw a comment + ;; and skipped it. + (define (skip-comment port) + (ssax:assert-current-char '(#\-) "XML [15], second dash" port) + (if (not (find-string-from-port? "-->" port)) + (slib:error port "XML [15], no -->")) + (make-xml-token 'COMMENT #f)) + ;; we have read "<![" that must begin a CDATA section + (define (read-cdata port) + (define cdstr (ssax:read-string 6 port)) + (if (not (string=? "CDATA[" cdstr)) + (slib:error "expected 'CDATA[' but read " cdstr)) + (make-xml-token 'CDSECT #f)) + + (lambda (port) + (ssax:assert-current-char '(#\<) "start of the token" port) + (case (peek-char port) + ((#\/) (read-char port) + (let ((val (make-xml-token 'END (ssax:read-QName port)))) + (ssax:skip-S port) + (ssax:assert-current-char '(#\>) "XML [42]" port) + val)) + ((#\?) (read-char port) (make-xml-token 'PI (ssax:read-NCName port))) + ((#\!) + (read-char port) + (case (peek-char port) + ((#\-) (read-char port) (skip-comment port)) + ((#\[) (read-char port) (read-cdata port)) + (else (make-xml-token 'DECL (ssax:read-NCName port))))) + (else (make-xml-token 'START (ssax:read-QName port))))))) + +;;@body +;; +;;The current position is inside a PI. Skip till the rest of the PI +(define (ssax:skip-pi port) + (if (not (find-string-from-port? "?>" port)) + (slib:error port "Failed to find ?> terminating the PI"))) + +;;@body +;; +;;The current position is right after reading the PITarget. We read +;;the body of PI and return is as a string. The port will point to +;;the character right after @samp{?>} combination that terminates PI. +;; +;;@example +;;[16] PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>' +;;@end example +(define (ssax:read-pi-body-as-string port) + (ssax:skip-S port) ; skip WS after the PI target name + (ssax:string-concatenate/shared + (let loop () + (let ((pi-fragment + (ssax:next-token '() '(#\?) "reading PI content" port))) + (read-char port) + (if (eqv? #\> (peek-char port)) + (begin + (read-char port) + (cons pi-fragment '())) + (cons* pi-fragment "?" (loop))))))) + +;;@body +;; +;;The current pos in the port is inside an internal DTD subset (e.g., +;;after reading @samp{#\[} that begins an internal DTD subset) Skip +;;until the @samp{]>} combination that terminates this DTD. +(define (ssax:skip-internal-dtd port) + (slib:warn port "Internal DTD subset is not currently handled ") + (if (not (find-string-from-port? "]>" port)) + (slib:error port + "Failed to find ]> terminating the internal DTD subset"))) + +;;@args port str-handler seed +;; +;;This procedure must be called after we have read a string +;;@samp{<![CDATA[} that begins a CDATA section. The current position +;;must be the first position of the CDATA body. This function reads +;;@emph{lines} of the CDATA body and passes them to a @2, a character +;;data consumer. +;; +;;@2 is a procedure taking arguments: @var{string1}, @var{string2}, +;;and @var{seed}. The first @var{string1} argument to @2 never +;;contains a newline; the second @var{string2} argument often will. +;;On the first invocation of @2, @3 is the one passed to @0 as the +;;third argument. The result of this first invocation will be passed +;;as the @var{seed} argument to the second invocation of the line +;;consumer, and so on. The result of the last invocation of the @2 is +;;returned by the @0. Note a similarity to the fundamental @dfn{fold} +;;iterator. +;; +;;Within a CDATA section all characters are taken at their face value, +;;with three exceptions: +;;@itemize @bullet +;;@item +;;CR, LF, and CRLF are treated as line delimiters, and passed +;;as a single @samp{#\newline} to @2 +;; +;;@item +;;@samp{]]>} combination is the end of the CDATA section. +;;@samp{>} is treated as an embedded @samp{>} character. +;; +;;@item +;;@samp{<} and @samp{&} are not specially recognized (and are +;;not expanded)! +;; +;;@end itemize +(define ssax:read-cdata-body + (let ((cdata-delimiters (list char-return #\newline #\] #\&))) + (lambda (port str-handler seed) + (let loop ((seed seed)) + (let ((fragment (ssax:next-token '() cdata-delimiters "reading CDATA" port))) + ;; that is, we're reading the char after the 'fragment' + (case (read-char port) + ((#\newline) (loop (str-handler fragment #\newline seed))) + ((#\]) + (if (not (eqv? (peek-char port) #\])) + (loop (str-handler fragment "]" seed)) + (let check-after-second-braket + ((seed (if (string-null? fragment) seed + (str-handler fragment "" seed)))) + (read-char port) + (case (peek-char port) ; after the second bracket + ((#\>) (read-char port) seed) ; we have read "]]>" + ((#\]) (check-after-second-braket + (str-handler "]" "" seed))) + (else (loop (str-handler "]]" "" seed))))))) + ((#\&) ; Note that #\& within CDATA may stand for itself + (let ((ent-ref ; it does not have to start an entity ref + (ssax:next-token-of + (lambda (c) + (and (not (eof-object? c)) (char-alphabetic? c) c)) + port))) + (cond ; replace ">" with #\> + ((and (string=? "gt" ent-ref) (eqv? (peek-char port) #\;)) + (read-char port) + (loop (str-handler fragment ">" seed))) + (else + (loop + (str-handler ent-ref "" + (str-handler fragment "&" seed))))))) + (else ; Must be CR: if the next char is #\newline, skip it + (if (eqv? (peek-char port) #\newline) (read-char port)) + (loop (str-handler fragment #\newline seed))) + )))))) + +;;@body +;; +;;@example +;;[66] CharRef ::= '&#' [0-9]+ ';' +;; | '&#x' [0-9a-fA-F]+ ';' +;;@end example +;; +;;This procedure must be called after we we have read @samp{&#} that +;;introduces a char reference. The procedure reads this reference and +;;returns the corresponding char. The current position in PORT will +;;be after the @samp{;} that terminates the char reference. +;; +;;Faults detected:@* +;;WFC: XML-Spec.html#wf-Legalchar +;; +;;According to Section @cite{4.1 Character and Entity References} +;;of the XML Recommendation: +;; +;;@quotation +;;"[Definition: A character reference refers to a specific character +;;in the ISO/IEC 10646 character set, for example one not directly +;;accessible from available input devices.]" +;;@end quotation +;; +;;@c Therefore, we use a @code{ucscode->char} function to convert a +;;@c character code into the character -- *regardless* of the current +;;@c character encoding of the input stream. +(define (ssax:read-char-ref port) + (let* ((base (cond ((eqv? (peek-char port) #\x) (read-char port) 16) + (else 10))) + (name (ssax:next-token '() '(#\;) "XML [66]" port)) + (char-code (string->number name base))) + (read-char port) ; read the terminating #\; char + (if (integer? char-code) (integer->char char-code) + (slib:error port "[wf-Legalchar] broken for '" name "'")))) + +(define ssax:predefined-parsed-entities + `( + (,(string->symbol "amp") . "&") + (,(string->symbol "lt") . "<") + (,(string->symbol "gt") . ">") + (,(string->symbol "apos") . "'") + (,(string->symbol "quot") . "\"") + )) + +;;@body +;; +;;Expands and handles a parsed-entity reference. +;; +;;@2 is a symbol, the name of the parsed entity to expand. +;;@c entities - see ENTITIES +;;@4 is a procedure of arguments @var{port}, @var{entities}, and +;;@var{seed} that returns a seed. +;;@5 is called if the entity in question is a pre-declared entity. +;; +;;@0 returns the result returned by @4 or @5. +;; +;;Faults detected:@* +;;WFC: XML-Spec.html#wf-entdeclared@* +;;WFC: XML-Spec.html#norecursion +(define (ssax:handle-parsed-entity port name entities content-handler str-handler seed) + (cond ; First we check the list of the declared entities + ((assq name entities) => + (lambda (decl-entity) + (let ((ent-body (cdr decl-entity)) ; mark the list to prevent recursion + (new-entities (cons (cons name #f) entities))) + (cond + ((string? ent-body) + (call-with-input-string ent-body + (lambda (port) (content-handler port new-entities seed)))) + ((procedure? ent-body) + (let ((port (ent-body))) + (define val (content-handler port new-entities seed)) + (close-input-port port) + val)) + (else + (slib:error port "[norecursion] broken for " name)))))) + ((assq name ssax:predefined-parsed-entities) + => (lambda (decl-entity) + (str-handler (cdr decl-entity) "" seed))) + (else (slib:error port "[wf-entdeclared] broken for " name)))) + +;;;; The ATTLIST Abstract Data Type + +;;; Currently is implemented as an assoc list sorted in the ascending +;;; order of NAMES. + +(define attlist-fold fold) +(define attlist-null? null?) +(define attlist->alist identity) +(define (make-empty-attlist) '()) + +;;@body +;; +;;Add a @2 pair to the existing @1, preserving its sorted ascending +;;order; and return the new list. Return #f if a pair with the same +;;name already exists in @1 +(define (attlist-add attlist name-value) + (if (null? attlist) (cons name-value attlist) + (case (ssax:name-compare (car name-value) (caar attlist)) + ((=) #f) + ((<) (cons name-value attlist)) + (else (cons (car attlist) (attlist-add (cdr attlist) name-value))) + ))) + +;;@body +;; +;;Given an non-null @1, return a pair of values: the top and the rest. +(define (attlist-remove-top attlist) + (values (car attlist) (cdr attlist))) + +;;@args port entities +;; +;;This procedure reads and parses a production @dfn{Attribute}. +;; +;;@example +;;[41] Attribute ::= Name Eq AttValue +;;[10] AttValue ::= '"' ([^<&"] | Reference)* '"' +;; | "'" ([^<&'] | Reference)* "'" +;;[25] Eq ::= S? '=' S? +;;@end example +;; +;;The procedure returns an ATTLIST, of Name (as UNRES-NAME), Value (as +;;string) pairs. The current character on the @1 is a non-whitespace +;;character that is not an NCName-starting character. +;; +;;Note the following rules to keep in mind when reading an +;;@dfn{AttValue}: +;;@quotation +;;Before the value of an attribute is passed to the application or +;;checked for validity, the XML processor must normalize it as +;;follows: +;; +;;@itemize @bullet +;;@item +;;A character reference is processed by appending the referenced +;;character to the attribute value. +;; +;;@item +;;An entity reference is processed by recursively processing the +;;replacement text of the entity. The named entities @samp{amp}, +;;@samp{lt}, @samp{gt}, @samp{quot}, and @samp{apos} are pre-declared. +;; +;;@item +;;A whitespace character (#x20, #x0D, #x0A, #x09) is processed by +;;appending #x20 to the normalized value, except that only a single +;;#x20 is appended for a "#x0D#x0A" sequence that is part of an +;;external parsed entity or the literal entity value of an internal +;;parsed entity. +;; +;;@item +;;Other characters are processed by appending them to the normalized +;;value. +;; +;;@end itemize +;; +;;@end quotation +;; +;;Faults detected:@* +;;WFC: XML-Spec.html#CleanAttrVals@* +;;WFC: XML-Spec.html#uniqattspec +(define ssax:read-attributes ; ssax:read-attributes port entities + (let ((value-delimeters (append '(#\< #\&) ssax:S-chars))) + ;; Read the AttValue from the PORT up to the delimiter (which can + ;; be a single or double-quote character, or even a symbol *eof*). + ;; 'prev-fragments' is the list of string fragments, accumulated + ;; so far, in reverse order. Return the list of fragments with + ;; newly read fragments prepended. + (define (read-attrib-value delimiter port entities prev-fragments) + (let* ((new-fragments + (cons (ssax:next-token '() (cons delimiter value-delimeters) + "XML [10]" port) + prev-fragments)) + (cterm (read-char port))) + (cond + ((or (eof-object? cterm) (eqv? cterm delimiter)) + new-fragments) + ((eqv? cterm char-return) ; treat a CR and CRLF as a LF + (if (eqv? (peek-char port) #\newline) (read-char port)) + (read-attrib-value delimiter port entities + (cons " " new-fragments))) + ((memv cterm ssax:S-chars) + (read-attrib-value delimiter port entities + (cons " " new-fragments))) + ((eqv? cterm #\&) + (cond + ((eqv? (peek-char port) #\#) + (read-char port) + (read-attrib-value delimiter port entities + (cons (string (ssax:read-char-ref port)) new-fragments))) + (else + (read-attrib-value delimiter port entities + (read-named-entity port entities new-fragments))))) + (else (slib:error port "[CleanAttrVals] broken"))))) + + ;; we have read "&" that introduces a named entity reference. + ;; read this reference and return the result of normalizing of the + ;; corresponding string (that is, read-attrib-value is applied to + ;; the replacement text of the entity). The current position will + ;; be after ";" that terminates the entity reference + (define (read-named-entity port entities fragments) + (let ((name (ssax:read-NCName port))) + (ssax:assert-current-char '(#\;) "XML [68]" port) + (ssax:handle-parsed-entity port name entities + (lambda (port entities fragments) + (read-attrib-value '*eof* port entities fragments)) + (lambda (str1 str2 fragments) + (if (equal? "" str2) (cons str1 fragments) + (cons* str2 str1 fragments))) + fragments))) + + (lambda (port entities) + (let loop ((attr-list (make-empty-attlist))) + (if (not (ssax:ncname-starting-char? (ssax:skip-S port))) attr-list + (let ((name (ssax:read-QName port))) + (ssax:skip-S port) + (ssax:assert-current-char '(#\=) "XML [25]" port) + (ssax:skip-S port) + (let ((delimiter + (ssax:assert-current-char '(#\' #\" ) "XML [10]" port))) + (loop + (or (attlist-add attr-list + (cons name + (ssax:string-concatenate-reverse/shared + (read-attrib-value delimiter port entities + '())))) + (slib:error port "[uniqattspec] broken for " name)))))))) + )) + +;;@body +;; +;;Convert an @2 to a RES-NAME, given the appropriate @3 declarations. +;;The last parameter, @4, determines if the default namespace applies +;;(for instance, it does not for attribute names). +;; +;;Per REC-xml-names/#nsc-NSDeclared, the "xml" prefix is considered +;;pre-declared and bound to the namespace name +;;"http://www.w3.org/XML/1998/namespace". +;; +;;@0 tests for the namespace constraints:@* +;;@url{http://www.w3.org/TR/REC-xml-names/#nsc-NSDeclared} +(define (ssax:resolve-name port unres-name namespaces apply-default-ns?) + (cond + ((pair? unres-name) ; it's a QNAME + (cons + (cond + ((assq (car unres-name) namespaces) => cadr) + ((eq? (car unres-name) ssax:Prefix-XML) ssax:Prefix-XML) + (else + (slib:error port "[nsc-NSDeclared] broken; prefix " (car unres-name)))) + (cdr unres-name))) + (apply-default-ns? ; Do apply the default namespace, if any + (let ((default-ns (assq '*DEFAULT* namespaces))) + (if (and default-ns (cadr default-ns)) + (cons (cadr default-ns) unres-name) + unres-name))) ; no default namespace declared + (else unres-name))) ; no prefix, don't apply the default-ns + + +;;Procedure: ssax:uri-string->symbol URI-STR +;;Convert a URI-STR to an appropriate symbol +(define ssax:uri-string->symbol string->symbol) + + +;;@args tag port elems entities namespaces +;; +;;Complete parsing of a start-tag markup. @0 must be called after the +;;start tag token has been read. @1 is an UNRES-NAME. @3 is an +;;instance of the ELEMS slot of XML-DECL; it can be #f to tell the +;;function to do @emph{no} validation of elements and their +;;attributes. +;; +;;@0 returns several values: +;;@itemize @bullet +;;@item ELEM-GI: +;;a RES-NAME. +;;@item ATTRIBUTES: +;;element's attributes, an ATTLIST of (RES-NAME . STRING) pairs. +;;The list does NOT include xmlns attributes. +;;@item NAMESPACES: +;;the input list of namespaces amended with namespace +;;(re-)declarations contained within the start-tag under parsing +;;@item ELEM-CONTENT-MODEL +;;@end itemize +;; +;;On exit, the current position in @2 will be the first character +;;after @samp{>} that terminates the start-tag markup. +;; +;;Faults detected:@* +;;VC: XML-Spec.html#enum@* +;;VC: XML-Spec.html#RequiredAttr@* +;;VC: XML-Spec.html#FixedAttr@* +;;VC: XML-Spec.html#ValueType@* +;;WFC: XML-Spec.html#uniqattspec (after namespaces prefixes are resolved)@* +;;VC: XML-Spec.html#elementvalid@* +;;WFC: REC-xml-names/#dt-NSName +;; +;;@emph{Note}: although XML Recommendation does not explicitly say it, +;;xmlns and xmlns: attributes don't have to be declared (although they +;;can be declared, to specify their default value). +(define ssax:complete-start-tag + + (let ((xmlns (string->symbol "xmlns")) + (largest-dummy-decl-attr (list ssax:largest-unres-name #f #f #f))) + + ;; Scan through the attlist and validate it, against decl-attrs + ;; Return an assoc list with added fixed or implied attrs. + ;; Note that both attlist and decl-attrs are ATTLISTs, and therefore, + ;; sorted + (define (validate-attrs port attlist decl-attrs) + + ;; Check to see decl-attr is not of use type REQUIRED. Add + ;; the association with the default value, if any declared + (define (add-default-decl decl-attr result) + (let*-values + (((attr-name content-type use-type default-value) + (apply values decl-attr))) + (and (eq? use-type 'REQUIRED) + (slib:error port "[RequiredAttr] broken for" attr-name)) + (if default-value + (cons (cons attr-name default-value) result) + result))) + + (let loop ((attlist attlist) (decl-attrs decl-attrs) (result '())) + (if (attlist-null? attlist) + (attlist-fold add-default-decl result decl-attrs) + (let*-values + (((attr attr-others) + (attlist-remove-top attlist)) + ((decl-attr other-decls) + (if (attlist-null? decl-attrs) + (values largest-dummy-decl-attr decl-attrs) + (attlist-remove-top decl-attrs))) + ) + (case (ssax:name-compare (car attr) (car decl-attr)) + ((<) + (if (or (eq? xmlns (car attr)) + (and (pair? (car attr)) (eq? xmlns (caar attr)))) + (loop attr-others decl-attrs (cons attr result)) + (slib:error port "[ValueType] broken for " attr))) + ((>) + (loop attlist other-decls + (add-default-decl decl-attr result))) + (else ; matched occurrence of an attr with its declaration + (let*-values + (((attr-name content-type use-type default-value) + (apply values decl-attr))) + ;; Run some tests on the content of the attribute + (cond + ((eq? use-type 'FIXED) + (or (equal? (cdr attr) default-value) + (slib:error port "[FixedAttr] broken for " attr-name))) + ((eq? content-type 'CDATA) #t) ; everything goes + ((pair? content-type) + (or (member (cdr attr) content-type) + (slib:error port "[enum] broken for " attr-name "=" + (cdr attr)))) + (else + (slib:warn port "declared content type " content-type + " not verified yet"))) + (loop attr-others other-decls (cons attr result))))) + )))) + + + ;; Add a new namespace declaration to namespaces. + ;; First we convert the uri-str to a uri-symbol and search namespaces for + ;; an association (_ user-prefix . uri-symbol). + ;; If found, we return the argument namespaces with an association + ;; (prefix user-prefix . uri-symbol) prepended. + ;; Otherwise, we prepend (prefix uri-symbol . uri-symbol) + (define (add-ns port prefix uri-str namespaces) + (and (equal? "" uri-str) + (slib:error port "[dt-NSName] broken for " prefix)) + (let ((uri-symbol (ssax:uri-string->symbol uri-str))) + (let loop ((nss namespaces)) + (cond + ((null? nss) + (cons (cons* prefix uri-symbol uri-symbol) namespaces)) + ((eq? uri-symbol (cddar nss)) + (cons (cons* prefix (cadar nss) uri-symbol) namespaces)) + (else (loop (cdr nss))))))) + + ;; partition attrs into proper attrs and new namespace declarations + ;; return two values: proper attrs and the updated namespace declarations + (define (adjust-namespace-decl port attrs namespaces) + (let loop ((attrs attrs) (proper-attrs '()) (namespaces namespaces)) + (cond + ((null? attrs) (values proper-attrs namespaces)) + ((eq? xmlns (caar attrs)) ; re-decl of the default namespace + (loop (cdr attrs) proper-attrs + (if (equal? "" (cdar attrs)) ; un-decl of the default ns + (cons (cons* '*DEFAULT* #f #f) namespaces) + (add-ns port '*DEFAULT* (cdar attrs) namespaces)))) + ((and (pair? (caar attrs)) (eq? xmlns (caaar attrs))) + (loop (cdr attrs) proper-attrs + (add-ns port (cdaar attrs) (cdar attrs) namespaces))) + (else + (loop (cdr attrs) (cons (car attrs) proper-attrs) namespaces))))) + + ;; The body of the function + (lambda (tag-head port elems entities namespaces) + (let*-values + (((attlist) (ssax:read-attributes port entities)) + ((empty-el-tag?) + (begin + (ssax:skip-S port) + (and + (eqv? #\/ + (ssax:assert-current-char '(#\> #\/) "XML [40], XML [44], no '>'" port)) + (ssax:assert-current-char '(#\>) "XML [44], no '>'" port)))) + ((elem-content decl-attrs) ; see xml-decl for their type + (if elems ; elements declared: validate! + (cond + ((assoc tag-head elems) => + (lambda (decl-elem) ; of type xml-decl::decl-elem + (values + (if empty-el-tag? 'EMPTY-TAG (cadr decl-elem)) + (caddr decl-elem)))) + (else + (slib:error port "[elementvalid] broken, no decl for " tag-head))) + (values ; non-validating parsing + (if empty-el-tag? 'EMPTY-TAG 'ANY) + #f) ; no attributes declared + )) + ((merged-attrs) (if decl-attrs (validate-attrs port attlist decl-attrs) + (attlist->alist attlist))) + ((proper-attrs namespaces) + (adjust-namespace-decl port merged-attrs namespaces)) + ) + ;; build the return value + (values + (ssax:resolve-name port tag-head namespaces #t) + (fold-right + (lambda (name-value attlist) + (or + (attlist-add attlist + (cons (ssax:resolve-name port (car name-value) namespaces #f) + (cdr name-value))) + (slib:error port "[uniqattspec] after NS expansion broken for " + name-value))) + (make-empty-attlist) + proper-attrs) + namespaces + elem-content))))) + +;;@body +;; +;;Parses an ExternalID production: +;; +;;@example +;;[75] ExternalID ::= 'SYSTEM' S SystemLiteral +;; | 'PUBLIC' S PubidLiteral S SystemLiteral +;;[11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") +;;[12] PubidLiteral ::= '"' PubidChar* '"' +;; | "'" (PubidChar - "'")* "'" +;;[13] PubidChar ::= #x20 | #x0D | #x0A | [a-zA-Z0-9] +;; | [-'()+,./:=?;!*#@@$_%] +;;@end example +;; +;;Call @0 when an ExternalID is expected; that is, the current +;;character must be either #\S or #\P that starts correspondingly a +;;SYSTEM or PUBLIC token. @0 returns the @var{SystemLiteral} as a +;;string. A @var{PubidLiteral} is disregarded if present. +(define (ssax:read-external-id port) + (let ((discriminator (ssax:read-NCName port))) + (ssax:assert-current-char ssax:S-chars "space after SYSTEM or PUBLIC" port) + (ssax:skip-S port) + (let ((delimiter + (ssax:assert-current-char '(#\' #\" ) "XML [11], XML [12]" port))) + (cond + ((eq? discriminator (string->symbol "SYSTEM")) + (let ((val (ssax:next-token '() (list delimiter) "XML [11]" port))) + (read-char port) ; reading the closing delim + val)) + ((eq? discriminator (string->symbol "PUBLIC")) + (let loop ((c (read-char port))) + (cond + ((eqv? c delimiter) c) + ((eof-object? c) + (slib:error port "Unexpected EOF while skipping until " delimiter)) + (else (loop (read-char port))))) + (ssax:assert-current-char ssax:S-chars "space after PubidLiteral" port) + (ssax:skip-S port) + (let* ((delimiter + (ssax:assert-current-char '(#\' #\" ) "XML [11]" port)) + (systemid + (ssax:next-token '() (list delimiter) "XML [11]" port))) + (read-char port) ; reading the closing delim + systemid)) + (else + (slib:error port "XML [75], " discriminator + " rather than SYSTEM or PUBLIC")))))) + + +;;@subsection Mid-Level Parsers and Scanners +;; +;;@noindent +;;These procedures parse productions corresponding to the whole +;;(document) entity or its higher-level pieces (prolog, root element, +;;etc). + +;;@body +;; +;;Scan the Misc production in the context: +;; +;;@example +;;[1] document ::= prolog element Misc* +;;[22] prolog ::= XMLDecl? Misc* (doctypedec l Misc*)? +;;[27] Misc ::= Comment | PI | S +;;@end example +;; +;;Call @0 in the prolog or epilog contexts. In these contexts, +;;whitespaces are completely ignored. The return value from @0 is +;;either a PI-token, a DECL-token, a START token, or *EOF*. Comments +;;are ignored and not reported. +(define (ssax:scan-misc port) + (let loop ((c (ssax:skip-S port))) + (cond + ((eof-object? c) c) + ((not (char=? c #\<)) + (slib:error port "XML [22], char '" c "' unexpected")) + (else + (let ((token (ssax:read-markup-token port))) + (case (xml-token-kind token) + ((COMMENT) (loop (ssax:skip-S port))) + ((PI DECL START) token) + (else + (slib:error port "XML [22], unexpected token of kind " + (xml-token-kind token) + )))))))) + +;;@args port expect-eof? str-handler iseed +;; +;;Read the character content of an XML document or an XML element. +;; +;;@example +;;[43] content ::= +;;(element | CharData | Reference | CDSect | PI | Comment)* +;;@end example +;; +;;To be more precise, @0 reads CharData, expands CDSect and character +;;entities, and skips comments. @0 stops at a named reference, EOF, +;;at the beginning of a PI, or a start/end tag. +;; +;;@2 is a boolean indicating if EOF is normal; i.e., the character +;;data may be terminated by the EOF. EOF is normal while processing a +;;parsed entity. +;; +;;@4 is an argument passed to the first invocation of @3. +;; +;;@0 returns two results: @var{seed} and @var{token}. The @var{seed} +;;is the result of the last invocation of @3, or the original @4 if @3 +;;was never called. +;; +;;@var{token} can be either an eof-object (this can happen only if @2 +;;was #t), or: +;;@itemize @bullet +;; +;;@item +;;an xml-token describing a START tag or an END-tag; +;;For a start token, the caller has to finish reading it. +;; +;;@item +;;an xml-token describing the beginning of a PI. It's up to an +;;application to read or skip through the rest of this PI; +;; +;;@item +;;an xml-token describing a named entity reference. +;; +;;@end itemize +;; +;;CDATA sections and character references are expanded inline and +;;never returned. Comments are silently disregarded. +;; +;;As the XML Recommendation requires, all whitespace in character data +;;must be preserved. However, a CR character (#x0D) must be +;;disregarded if it appears before a LF character (#x0A), or replaced +;;by a #x0A character otherwise. See Secs. 2.10 and 2.11 of the XML +;;Recommendation. See also the canonical XML Recommendation. +(define ssax:read-char-data + (let ((terminators-usual (list #\< #\& char-return)) + (terminators-usual-eof (list #\< '*eof* #\& char-return)) + (handle-fragment + (lambda (fragment str-handler seed) + (if (string-null? fragment) seed + (str-handler fragment "" seed))))) + (lambda (port expect-eof? str-handler seed) + ;; Very often, the first character we encounter is #\< + ;; Therefore, we handle this case in a special, fast path + (if (eqv? #\< (peek-char port)) + ;; The fast path + (let ((token (ssax:read-markup-token port))) + (case (xml-token-kind token) + ((START END) ; The most common case + (values seed token)) + ((CDSECT) + (let ((seed (ssax:read-cdata-body port str-handler seed))) + (ssax:read-char-data port expect-eof? str-handler seed))) + ((COMMENT) + (ssax:read-char-data port expect-eof? str-handler seed)) + (else + (values seed token)))) + ;; The slow path + (let ((char-data-terminators + (if expect-eof? terminators-usual-eof terminators-usual))) + (let loop ((seed seed)) + (let* ((fragment + (ssax:next-token '() char-data-terminators + "reading char data" port)) + (term-char (peek-char port)) ; one of char-data-terminators + ) + (if (eof-object? term-char) + (values + (handle-fragment fragment str-handler seed) + term-char) + (case term-char + ((#\<) + (let ((token (ssax:read-markup-token port))) + (case (xml-token-kind token) + ((CDSECT) + (loop + (ssax:read-cdata-body port str-handler + (handle-fragment fragment str-handler seed)))) + ((COMMENT) + (loop (handle-fragment fragment str-handler seed))) + (else + (values + (handle-fragment fragment str-handler seed) + token))))) + ((#\&) + (read-char port) + (case (peek-char port) + ((#\#) (read-char port) + (loop (str-handler fragment + (string (ssax:read-char-ref port)) + seed))) + (else + (let ((name (ssax:read-NCName port))) + (ssax:assert-current-char '(#\;) "XML [68]" port) + (values + (handle-fragment fragment str-handler seed) + (make-xml-token 'ENTITY-REF name)))))) + (else ; This must be a CR character + (read-char port) + (if (eqv? (peek-char port) #\newline) + (read-char port)) + (loop (str-handler fragment (string #\newline) seed)))) + )))))))) + +;;@body +;; +;;Make sure that @1 is of anticipated @2 and has anticipated @3. Note +;;that the @3 argument may actually be a pair of two symbols, +;;Namespace-URI or the prefix, and of the localname. If the assertion +;;fails, @4 is evaluated by passing it three arguments: @1 @2 @3. The +;;result of @4 is returned. +(define (ssax:assert-token token kind gi error-cont) + (or (and (xml-token? token) + (eq? kind (xml-token-kind token)) + (equal? gi (xml-token-head token))) + (error-cont token kind gi))) + +;;@subsection High-level Parsers +;; +;;These procedures are to instantiate a SSAX parser. A user can +;;instantiate the parser to do the full validation, or no validation, +;;or any particular validation. The user specifies which PI he wants +;;to be notified about. The user tells what to do with the parsed +;;character and element data. The latter handlers determine if the +;;parsing follows a SAX or a DOM model. + +;;@args my-pi-handlers +;; +;;Create a parser to parse and process one Processing Element (PI). +;; +;;@1 is an association list of pairs +;;@code{(@var{pi-tag} . @var{pi-handler})} where @var{pi-tag} is an +;;NCName symbol, the PI target; and @var{pi-handler} is a procedure +;;taking arguments @var{port}, @var{pi-tag}, and @var{seed}. +;; +;;@var{pi-handler} should read the rest of the PI up to and including +;;the combination @samp{?>} that terminates the PI. The handler +;;should return a new seed. One of the @var{pi-tag}s may be the +;;symbol @code{*DEFAULT*}. The corresponding handler will handle PIs +;;that no other handler will. If the *DEFAULT* @var{pi-tag} is not +;;specified, @0 will assume the default handler that skips the body of +;;the PI. +;; +;;@0 returns a procedure of arguments @var{port}, @var{pi-tag}, and +;;@var{seed}; that will parse the current PI according to @1. +(define (ssax:make-pi-parser handlers) + (lambda (port target seed) + (define pair (assv target handlers)) + (or pair (set! pair (assv '*DEFAULT* handlers))) + (cond ((not pair) + (slib:warn port "Skipping PI: " target #\newline) + (ssax:skip-pi port) + seed) + (else ((cdr pair) port target seed))))) + +;;syntax: ssax:make-elem-parser +;; my-new-level-seed my-finish-element my-char-data-handler my-pi-handlers + +;;@body +;; +;;Create a parser to parse and process one element, including its +;;character content or children elements. The parser is typically +;;applied to the root element of a document. +;; +;;@table @asis +;; +;;@item @1 +;;is a procedure taking arguments: +;; +;;@var{elem-gi} @var{attributes} @var{namespaces} @var{expected-content} @var{seed} +;; +;;where @var{elem-gi} is a RES-NAME of the element about to be +;;processed. +;; +;;@1 is to generate the seed to be passed to handlers that process the +;;content of the element. +;; +;;@item @2 +;;is a procedure taking arguments: +;; +;;@var{elem-gi} @var{attributes} @var{namespaces} @var{parent-seed} @var{seed} +;; +;;@2 is called when parsing of @var{elem-gi} is finished. +;;The @var{seed} is the result from the last content parser (or +;;from @1 if the element has the empty content). +;;@var{parent-seed} is the same seed as was passed to @1. +;;@2 is to generate a seed that will be the result +;;of the element parser. +;; +;;@item @3 +;;is a STR-HANDLER as described in Data Types above. +;; +;;@item @4 +;;is as described for @code{ssax:make-pi-handler} above. +;; +;;@end table +;; +;;The generated parser is a procedure taking arguments: +;; +;;@var{start-tag-head} @var{port} @var{elems} @var{entities} @var{namespaces} @var{preserve-ws?} @var{seed} +;; +;;The procedure must be called after the start tag token has been +;;read. @var{start-tag-head} is an UNRES-NAME from the start-element +;;tag. ELEMS is an instance of ELEMS slot of XML-DECL. +;; +;;Faults detected:@* +;;VC: XML-Spec.html#elementvalid@* +;;WFC: XML-Spec.html#GIMatch +(define (ssax:make-elem-parser my-new-level-seed my-finish-element + my-char-data-handler my-pi-handlers) + (lambda (start-tag-head port elems entities namespaces preserve-ws? seed) + (define xml-space-gi (cons ssax:Prefix-XML + (string->symbol "space"))) + (let handle-start-tag ((start-tag-head start-tag-head) + (port port) (entities entities) + (namespaces namespaces) + (preserve-ws? preserve-ws?) (parent-seed seed)) + (let*-values + (((elem-gi attributes namespaces expected-content) + (ssax:complete-start-tag start-tag-head port elems + entities namespaces)) + ((seed) + (my-new-level-seed elem-gi attributes + namespaces expected-content parent-seed))) + (case expected-content + ((EMPTY-TAG) + (my-finish-element + elem-gi attributes namespaces parent-seed seed)) + ((EMPTY) ; The end tag must immediately follow + (ssax:assert-token (and (eqv? #\< (ssax:skip-S port)) + (ssax:read-markup-token port)) + 'END + start-tag-head + (lambda (token exp-kind exp-head) + (slib:error port "[elementvalid] broken for " token + " while expecting " + exp-kind exp-head))) + (my-finish-element + elem-gi attributes namespaces parent-seed seed)) + (else ; reading the content... + (let ((preserve-ws? ; inherit or set the preserve-ws? flag + (cond ((assoc xml-space-gi attributes) => + (lambda (name-value) + (equal? "preserve" (cdr name-value)))) + (else preserve-ws?)))) + (let loop ((port port) (entities entities) + (expect-eof? #f) (seed seed)) + (let*-values + (((seed term-token) + (ssax:read-char-data port expect-eof? + my-char-data-handler seed))) + (if (eof-object? term-token) + seed + (case (xml-token-kind term-token) + ((END) + (ssax:assert-token term-token 'END start-tag-head + (lambda (token exp-kind exp-head) + (slib:error port "[GIMatch] broken for " + term-token " while expecting " + exp-kind exp-head))) + (my-finish-element + elem-gi attributes namespaces parent-seed seed)) + ((PI) + (let ((seed + ((ssax:make-pi-parser my-pi-handlers) + port (xml-token-head term-token) seed))) + (loop port entities expect-eof? seed))) + ((ENTITY-REF) + (let ((seed + (ssax:handle-parsed-entity + port (xml-token-head term-token) + entities + (lambda (port entities seed) + (loop port entities #t seed)) + my-char-data-handler + seed))) ; keep on reading the content after ent + (loop port entities expect-eof? seed))) + ((START) ; Start of a child element + (if (eq? expected-content 'PCDATA) + (slib:error port "[elementvalid] broken for " + elem-gi + " with char content only; unexpected token " + term-token)) + ;; Do other validation of the element content + (let ((seed + (handle-start-tag + (xml-token-head term-token) + port entities namespaces + preserve-ws? seed))) + (loop port entities expect-eof? seed))) + (else + (slib:error port "XML [43] broken for " + term-token)))))))) + ))) + )) + + +;;This is ssax:make-parser with all the (specialization) handlers given +;;as positional arguments. It is called by ssax:make-parser, see below +(define (ssax:make-parser/positional-args + *handler-DOCTYPE + *handler-UNDECL-ROOT + *handler-DECL-ROOT + *handler-NEW-LEVEL-SEED + *handler-FINISH-ELEMENT + *handler-CHAR-DATA-HANDLER + *handler-PROCESSING-INSTRUCTIONS) + (lambda (port seed) + ;; We must've just scanned the DOCTYPE token. Handle the + ;; doctype declaration and exit to + ;; scan-for-significant-prolog-token-2, and eventually, to the + ;; element parser. + (define (handle-decl port token-head seed) + (or (eq? (string->symbol "DOCTYPE") token-head) + (slib:error port "XML [22], expected DOCTYPE declaration, found " + token-head)) + (ssax:assert-current-char ssax:S-chars "XML [28], space after DOCTYPE" port) + (ssax:skip-S port) + (let*-values + (((docname) (ssax:read-QName port)) + ((systemid) + (and (ssax:ncname-starting-char? (ssax:skip-S port)) + (ssax:read-external-id port))) + ((internal-subset?) + (begin + (ssax:skip-S port) + (eqv? #\[ + (ssax:assert-current-char '(#\> #\[) + "XML [28], end-of-DOCTYPE" port)))) + ((elems entities namespaces seed) + (*handler-DOCTYPE port docname systemid internal-subset? seed))) + (scan-for-significant-prolog-token-2 port elems entities namespaces + seed))) + ;; Scan the leading PIs until we encounter either a doctype + ;; declaration or a start token (of the root element). In the + ;; latter two cases, we exit to the appropriate continuation + (define (scan-for-significant-prolog-token-1 port seed) + (let ((token (ssax:scan-misc port))) + (if (eof-object? token) + (slib:error port "XML [22], unexpected EOF") + (case (xml-token-kind token) + ((PI) + (let ((seed + ((ssax:make-pi-parser *handler-PROCESSING-INSTRUCTIONS) + port (xml-token-head token) seed))) + (scan-for-significant-prolog-token-1 port seed))) + ((DECL) (handle-decl port (xml-token-head token) seed)) + ((START) + (let*-values + (((elems entities namespaces seed) + (*handler-UNDECL-ROOT (xml-token-head token) seed))) + (element-parser (xml-token-head token) port elems + entities namespaces #f seed))) + (else (slib:error port "XML [22], unexpected markup " + token)))))) + ;; Scan PIs after the doctype declaration, till we encounter + ;; the start tag of the root element. After that we exit + ;; to the element parser + (define (scan-for-significant-prolog-token-2 port elems entities namespaces seed) + (let ((token (ssax:scan-misc port))) + (if (eof-object? token) + (slib:error port "XML [22], unexpected EOF") + (case (xml-token-kind token) + ((PI) + (let ((seed ((ssax:make-pi-parser *handler-PROCESSING-INSTRUCTIONS) + port (xml-token-head token) seed))) + (scan-for-significant-prolog-token-2 port elems entities + namespaces seed))) + ((START) + (element-parser (xml-token-head token) port elems + entities namespaces #f + (*handler-DECL-ROOT (xml-token-head token) seed))) + (else (slib:error port "XML [22], unexpected markup " + token)))))) + ;; A procedure start-tag-head port elems entities namespaces + ;; preserve-ws? seed + (define element-parser + (ssax:make-elem-parser *handler-NEW-LEVEL-SEED + *handler-FINISH-ELEMENT + *handler-CHAR-DATA-HANDLER + *handler-PROCESSING-INSTRUCTIONS)) + + ;; Get the ball rolling ... + (scan-for-significant-prolog-token-1 port seed) + )) + +(define DOCTYPE 'DOCTYPE) +(define UNDECL-ROOT 'UNDECL-ROOT) +(define DECL-ROOT 'DECL-ROOT) +(define NEW-LEVEL-SEED 'NEW-LEVEL-SEED) +(define FINISH-ELEMENT 'FINISH-ELEMENT) +(define CHAR-DATA-HANDLER 'CHAR-DATA-HANDLER) +(define PROCESSING-INSTRUCTIONS 'PROCESSING-INSTRUCTIONS) + +;;@args user-handler-tag user-handler ... +;; +;;Create an XML parser, an instance of the XML parsing framework. +;;This will be a SAX, a DOM, or a specialized parser depending on the +;;supplied user-handlers. +;; +;;@0 takes an even number of arguments; @1 is a symbol that identifies +;;a procedure (or association list for @code{PROCESSING-INSTRUCTIONS}) +;;(@2) that follows the tag. Given below are tags and signatures of +;;the corresponding procedures. Not all tags have to be specified. +;;If some are omitted, reasonable defaults will apply. +;; +;;@table @samp +;; +;;@item DOCTYPE +;;handler-procedure: @var{port} @var{docname} @var{systemid} @var{internal-subset?} @var{seed} +;; +;;If @var{internal-subset?} is #t, the current position in the port is +;;right after we have read @samp{[} that begins the internal DTD +;;subset. We must finish reading of this subset before we return (or +;;must call @code{skip-internal-dtd} if we aren't interested in +;;reading it). @var{port} at exit must be at the first symbol after +;;the whole DOCTYPE declaration. +;; +;;The handler-procedure must generate four values: +;;@quotation +;;@var{elems} @var{entities} @var{namespaces} @var{seed} +;;@end quotation +;; +;;@var{elems} is as defined for the ELEMS slot of XML-DECL. It may be +;;#f to switch off validation. @var{namespaces} will typically +;;contain @var{user-prefix}es for selected @var{uri-symb}s. The +;;default handler-procedure skips the internal subset, if any, and +;;returns @code{(values #f '() '() seed)}. +;; +;;@item UNDECL-ROOT +;;procedure: @var{elem-gi} @var{seed} +;; +;;where @var{elem-gi} is an UNRES-NAME of the root element. This +;;procedure is called when an XML document under parsing contains +;;@emph{no} DOCTYPE declaration. +;; +;;The handler-procedure, as a DOCTYPE handler procedure above, +;;must generate four values: +;;@quotation +;;@var{elems} @var{entities} @var{namespaces} @var{seed} +;;@end quotation +;; +;;The default handler-procedure returns (values #f '() '() seed) +;; +;;@item DECL-ROOT +;;procedure: @var{elem-gi} @var{seed} +;; +;;where @var{elem-gi} is an UNRES-NAME of the root element. This +;;procedure is called when an XML document under parsing does contains +;;the DOCTYPE declaration. The handler-procedure must generate a new +;;@var{seed} (and verify that the name of the root element matches the +;;doctype, if the handler so wishes). The default handler-procedure +;;is the identity function. +;; +;;@item NEW-LEVEL-SEED +;;procedure: see ssax:make-elem-parser, my-new-level-seed +;; +;;@item FINISH-ELEMENT +;;procedure: see ssax:make-elem-parser, my-finish-element +;; +;;@item CHAR-DATA-HANDLER +;;procedure: see ssax:make-elem-parser, my-char-data-handler +;; +;;@item PROCESSING-INSTRUCTIONS +;;association list as is passed to @code{ssax:make-pi-parser}. +;;The default value is '() +;; +;;@end table +;; +;;The generated parser is a procedure of arguments @var{port} and +;;@var{seed}. +;; +;;This procedure parses the document prolog and then exits to an +;;element parser (created by @code{ssax:make-elem-parser}) to handle +;;the rest. +;; +;;@example +;;[1] document ::= prolog element Misc* +;;[22] prolog ::= XMLDecl? Misc* (doctypedec | Misc*)? +;;[27] Misc ::= Comment | PI | S +;;[28] doctypedecl ::= '<!DOCTYPE' S Name (S ExternalID)? S? +;; ('[' (markupdecl | PEReference | S)* ']' S?)? '>' +;;[29] markupdecl ::= elementdecl | AttlistDecl +;; | EntityDecl +;; | NotationDecl | PI +;; | Comment +;;@end example +(define ssax:make-parser + (let ((descriptors + `((DOCTYPE + ,(lambda (port docname systemid internal-subset? seed) + (cond (internal-subset? + (ssax:skip-internal-dtd port))) + (slib:warn port "DOCTYPE DECL " docname " " + systemid " found and skipped") + (values #f '() '() seed) + )) + (UNDECL-ROOT + ,(lambda (elem-gi seed) (values #f '() '() seed))) + (DECL-ROOT + ,(lambda (elem-gi seed) seed)) + (NEW-LEVEL-SEED) ; required + (FINISH-ELEMENT) ; required + (CHAR-DATA-HANDLER) ; required + (PROCESSING-INSTRUCTIONS ()) + ))) + (lambda proplist + (define count 0) + (if (odd? (length proplist)) + (slib:error 'ssax:make-parser "takes even number of arguments" + proplist)) + (let ((posititional-args + (map (lambda (spec) + (define ptail (member (car spec) proplist)) + (cond ((and ptail (odd? (length ptail))) + (slib:error 'ssax:make-parser 'bad 'argument ptail)) + (ptail + (set! count (+ 1 count)) + (cadr ptail)) + ((not (null? (cdr spec))) + (cadr spec)) + (else + (slib:error + 'ssax:make-parser 'missing (car spec) 'property)))) + descriptors))) + (if (= count (quotient (length proplist) 2)) + (apply ssax:make-parser/positional-args posititional-args) + (slib:error 'ssax:make-parser 'extra 'arguments proplist)))))) + +;;@subsection Parsing XML to SXML + +;;@body +;; +;;This is an instance of the SSAX parser that returns an SXML +;;representation of the XML document to be read from @1. @2 is a list +;;of @code{(@var{user-prefix} . @var{uri-string})} that assigns +;;@var{user-prefix}es to certain namespaces identified by particular +;;@var{uri-string}s. It may be an empty list. @0 returns an SXML +;;tree. The port points out to the first character after the root +;;element. +(define (ssax:xml->sxml port namespace-prefix-assig) + (define namespaces + (map (lambda (el) (cons* #f (car el) (ssax:uri-string->symbol (cdr el)))) + namespace-prefix-assig)) + (define (RES-NAME->SXML res-name) + (string->symbol + (string-append + (symbol->string (car res-name)) + ":" + (symbol->string (cdr res-name))))) + (let ((result + (reverse + ((ssax:make-parser + + 'DOCTYPE + (lambda (port docname systemid internal-subset? seed) + (cond (internal-subset? + (ssax:skip-internal-dtd port))) + (slib:warn port "DOCTYPE DECL " docname " " + systemid " found and skipped") + (values #f '() namespaces seed)) + + 'NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content seed) + '()) + + 'FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed seed) + (define nseed (ssax:reverse-collect-str-drop-ws seed)) + (define attrs + (attlist-fold + (lambda (attr accum) + (cons (list (if (symbol? (car attr)) + (car attr) + (RES-NAME->SXML (car attr))) + (cdr attr)) + accum)) + '() attributes)) + (cons (cons (if (symbol? elem-gi) + elem-gi + (RES-NAME->SXML elem-gi)) + (if (null? attrs) + nseed + (cons (cons '@ attrs) nseed))) + parent-seed)) + + 'CHAR-DATA-HANDLER + (lambda (string1 string2 seed) + (if (string-null? string2) + (cons string1 seed) + (cons* string2 string1 seed))) + + 'UNDECL-ROOT + (lambda (elem-gi seed) + (values #f '() namespaces seed)) + + 'PROCESSING-INSTRUCTIONS + (list + (cons '*DEFAULT* + (lambda (port pi-tag seed) + (cons (list '*PROCESSING-INSTRUCTIONS* + pi-tag + (ssax:read-pi-body-as-string port)) + seed)))) + ) + port + '())))) + (cons '*TOP* + (if (null? namespace-prefix-assig) + result + (cons + (list '@ (cons '*NAMESPACES* + (map (lambda (ns) (list (car ns) (cdr ns))) + namespace-prefix-assig))) + result))))) |