;;;;"xml-parse.scm" 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)))))