summaryrefslogtreecommitdiffstats
path: root/xml-parse.scm
diff options
context:
space:
mode:
authorThomas Bushnell, BSG <tb@debian.org>2007-12-28 16:25:32 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:39 -0800
commitd8ae23691ed6392b7f320f5fa7d4dd78ae52c10e (patch)
treeb20b8bc02e854c4c86d39ee22a0638a8b06e01af /xml-parse.scm
parentedd1ebef3ad774e7cbcc2f5918d555bfb0b44091 (diff)
parent64f037d91e0c9296dcaef9a0ff3eb33b19a2ed34 (diff)
downloadslib-d8ae23691ed6392b7f320f5fa7d4dd78ae52c10e.tar.gz
slib-d8ae23691ed6392b7f320f5fa7d4dd78ae52c10e.zip
Import Debian changes 3a5-1debian/3a5-1
slib (3a5-1) unstable; urgency=low * New upstream release. * slib.texi (Library Catalogs): Repeat change from 3a3-3. * Makefile: Repeat $(htmldir)slib_toc.html changes from 3a2-1. * guile.init: (library-vicinity): Repeat change from 3a4-2. * debian/rules (binary-indep): Don't hide .init files in a separate subdirectory, thus conforming better to the usual slib practice. Put a symlink in place to ease transitions. (Closes: #407370).
Diffstat (limited to 'xml-parse.scm')
-rw-r--r--xml-parse.scm2025
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{&gt;} is treated as an embedded @samp{>} character.
+;;
+;;@item
+;;@samp{&lt;} and @samp{&amp;} 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 "&gt;" 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)))))