Import Upstream version 3a5upstream/3a5

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)))))