;; sdom.scm: main module exports and implementations for SDOM
;; Copyright (C) 2007 Julian Graham

;; SDOM is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; SDOM is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with SDOM; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

(define-module (sdom core)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-13)
  #:use-module (sxml ssax)
  #:export     (sdom:sxml->sdom 
		sdom:xml->sdom
		sdom:set-dom-property!
		sdom:get-dom-property
		sdom:node?
		sdom:node-attributes
		sdom:node-name
		sdom:node-type

		sdom:node-type-element
		sdom:node-type-attr
		sdom:node-type-text
		sdom:node-type-cdata-section
		sdom:node-type-entity-reference
		sdom:node-type-entity
		sdom:node-type-processing-instruction
		sdom:node-type-comment
		sdom:node-type-document
		sdom:node-type-document-type
		sdom:node-type-document-fragment
		sdom:node-type-notation

		sdom:exception-code-index-size-err
		sdom:exception-code-domstring-size-err
		sdom:exception-code-hierarchy-request-err
		sdom:exception-code-wrong-document-err
		sdom:exception-code-invalid-character-err
		sdom:exception-code-no-data-allowed-err
		sdom:exception-code-no-modification-allowed-err
		sdom:exception-code-not-found-err
		sdom:exception-code-not-supported-err
		sdom:exception-code-inuse-attribute-err
		sdom:exception-code-invalid-state-err
		sdom:exception-code-syntax-err
		sdom:exception-code-invalid-modification-err
		sdom:exception-code-namespace-err
		sdom:exception-code-invalid-access-err
		sdom:exception-code-validation-err
		sdom:exception-code-type-mismatch-err

		sdom:error-severity-warning
		sdom:error-severity-error
		sdom:error-severity-fatal-error

		sdom:document-position-disconnected
		sdom:document-position-contained-by
		sdom:document-position-contains
		sdom:document-position-following
		sdom:document-position-preceding
		sdom:document-position-implementation-specific
		
		sdom:user-data-event-node-cloned
		sdom:user-data-event-node-imported
		sdom:user-data-event-node-deleted
		sdom:user-data-event-node-renamed
		sdom:user-data-event-node-adopted

		sdom:register-feature!
		sdom:has-feature?

		sdom:config-parameter-names
		sdom:add-dom-config-parameter!
		sdom:get-dom-config-parameter
		sdom:set-dom-config-parameter!
		sdom:can-set-dom-config-parameter?
		sdom:signal-error

		sdom:insert-before!
		sdom:insert-after!
		sdom:remove-child!
		sdom:replace-child!
		sdom:replace-whole-text!
		sdom:append-child!
		sdom:clone-node
		sdom:normalize!
		sdom:normalize-document!
		sdom:adopt-node!
		sdom:import-node
		sdom:rename-node!

		sdom:same-node?
		sdom:equal-node?
		sdom:has-child-nodes?
		sdom:supported?

		sdom:default-namespace?		
		sdom:lookup-prefix
		sdom:lookup-namespace-uri

		sdom:set-user-data!
		sdom:get-user-data

		sdom:create-node
		sdom:create-document
		sdom:create-document-type
		
		sdom:get-elements-by-tag-name
		sdom:get-element-by-id
		sdom:set-id-attribute!
		sdom:set-id-attribute-node!
		sdom:get-attribute-node
		sdom:set-attribute-node!
		sdom:remove-attribute-node!
		sdom:get-attribute
		sdom:set-attribute!
		sdom:remove-attribute!

		sdom:compare-document-position
		
		sdom:dispatch-event))

;; The following constructs get added to the SXML tree to make it into a DOM-
;; compliant document tree. !!! We're going to use sub @-annotations to store
;; our data!

(define sdom:node-type-node 0)
(define sdom:node-type-character-data 100)

(define sdom:node-type-element 			1)
(define sdom:node-type-attr	 		2)
(define sdom:node-type-text 			3)
(define sdom:node-type-cdata-section 		4)
(define sdom:node-type-entity-reference 	5)
(define sdom:node-type-entity 			6)
(define sdom:node-type-processing-instruction 	7)
(define sdom:node-type-comment 			8)
(define sdom:node-type-document			9)
(define sdom:node-type-document-type 		10)
(define sdom:node-type-document-fragment 	11)
(define sdom:node-type-notation 		12)

(define sdom:exception-code-index-size-err 		1)
(define sdom:exception-code-domstring-size-err 		2)
(define sdom:exception-code-hierarchy-request-err 	3)
(define sdom:exception-code-wrong-document-err 		4)
(define sdom:exception-code-invalid-character-err 	5)
(define sdom:exception-code-no-data-allowed-err 	6)
(define sdom:exception-code-no-modification-allowed-err 7)
(define sdom:exception-code-not-found-err 		8)
(define sdom:exception-code-not-supported-err 		9)
(define sdom:exception-code-inuse-attribute-err 	10)
(define sdom:exception-code-invalid-state-err 		11)
(define sdom:exception-code-syntax-err 			12)
(define sdom:exception-code-invalid-modification-err 	13)
(define sdom:exception-code-namespace-err 		14)
(define sdom:exception-code-invalid-access-err 		15)
(define sdom:exception-code-validation-err 		16)
(define sdom:exception-code-type-mismatch-err 		17)

(define sdom:error-severity-warning		1)
(define sdom:error-severity-error		2)
(define sdom:error-severity-fatal-error		3)

(define sdom:document-position-disconnected 		1)
(define sdom:document-position-preceding 		2)
(define sdom:document-position-following 		4)
(define sdom:document-position-contains 		8)
(define sdom:document-position-contained-by 		16)
(define sdom:document-position-implementation-specific 	32)

(define sdom:user-data-event-node-cloned 	1)
(define sdom:user-data-event-node-imported	2)
(define sdom:user-data-event-node-deleted	3)
(define sdom:user-data-event-node-renamed	4)
(define sdom:user-data-event-node-adopted	5)

(define sdom:event-exception-code-unspecified-event-type-err	0)
(define sdom:event-exception-code-dispatch-request-err		1)

(define sdom:event-phase-capturing	1)
(define sdom:event-phase-target		2)
(define sdom:event-phase-bubbling	3)

(define xml-ns-uri "http://www.w3.org/XML/1998/namespace")
(define xmlns-ns-uri "http://www.w3.org/2000/xmlns")

;; This is to override the definition in SXML, which discards, for some reason,
;; the publid ID.

(define (ssax:read-external-id p)
  (let ((discriminator (ssax:read-NCName p)))
    (assert-curr-char ssax:S-chars "space after SYSTEM or PUBLIC" p)
    (ssax:skip-S p)
    (let ((delim (assert-curr-char '(#\' #\" ) "XML [11], XML [12]" p)))
      (cond
        ((eq? discriminator (string->symbol "SYSTEM"))
	 (begin0 (next-token '() (list delim) "XML [11]" p)
		 (read-char p))) ; reading the closing delim
	((eq? discriminator (string->symbol "PUBLIC"))
	 (let ((publicid (next-token '() (list delim) "XML [11]" p)))
	   (read-char p)
	   (assert-curr-char ssax:S-chars "space after PubidLiteral" p)
	   (ssax:skip-S p)
           (let* ((delim (assert-curr-char '(#\' #\" ) "XML [11]" p))
                  (systemid (next-token '() (list delim) "XML [11]" p)))
	     (read-char p) ; reading the closing delim
	     (cons publicid systemid))))
	(else (parser-error port "XML [75], " discriminator 
			    " rather than SYSTEM or PUBLIC"))))))

;; This guy stores the user data across all nodes / documents.  We're not going
;; to export it, because we have a pair of functions that handle access to it.

(define initial-user-data-hash-size 16)
(define user-data-hash (make-weak-key-hash-table initial-user-data-hash-size))

(define initial-parent-node-hash-size 16)
(define parent-node-hash 
  (make-weak-key-hash-table initial-user-data-hash-size))

(define default-dom-error-handler
  (lambda (severity msg type excep data loc)
    (display (string-append "SDOM: "
			    (cond ((eqv? severity sdom:error-severity-warning)
				   "warning: ")
				  ((eqv? severity sdom:error-severity-error)
				   "error: ")
				  ((eqv? severity 
					 sdom:error-severity-fatal-error)
				   "fatal error: "))
			    msg))
    (newline)
    #t))

(define sdom:signal-error
  (lambda (doc severity msg type excep data loc)
    (let* ((handler (sdom:get-dom-config-parameter doc "error-handler")))
      (apply handler `(,severity ,msg ,type ,excep ,data ,loc)))))

;; How to extract the annotations from a particular node?
;; If the node is an element node, annotations are stored in sub attributes
;; like so '(@ (@ ...)).  If the node is an attribute, then the sub-annotation
;; looks like an attribute itself -- but we know it's not, because attributes
;; don't have attributes.

;; (attr (@ (sdom:name "value")))
;; (node (@ (attribute "value")))
;; (node (@ (attribute "value") (@ (sdom:name "value"))))

(define fold
  (lambda (_kons_38 _knil_39 _lis1_40)
    ((letrec ((_lp_41 (lambda (_lis_42 _ans_43)
                        (if (null? _lis_42)
			    _ans_43
			    (_lp_41 (cdr _lis_42)
				    (_kons_38 (car _lis_42) _ans_43))))))
       _lp_41)
     _lis1_40
     _knil_39)))

(define xor (lambda (x y) (if x (if y #f #t) (if y #t #f))))

(define extended-char-regex "\\/\\:")
(define qname-char-regex "([[:alnum:]._-]|\\:)+")
(define qname-char-regex-extended "([[:alnum:]._-]|\\:|\\/)+")
(define qname-regex 
  "([[:alpha:]_][[:alnum:]._-]*\\:)?[[:alpha:]_][[:alnum:]._-]*")
(define qname-regex-extended
  "([[:alpha:]_]([[:alnum:]._-]|\\:|\\/)*)?[[:alpha:]_][[:alnum:]._-]*")

(define regex-match?
  (lambda (pattern str)
    (let ((match (string-match pattern str)))
      (and match (equal? (match:substring match) str)))))

(define entity-parse-prefix "<?xml version=\"1.0\"?><sdom-entity>")
(define entity-parse-suffix "</sdom-entity>")

;; I feel like this will be useful -- but I don't feel like writing it just yet

(define sdom:node?
  (lambda (x) #t))

(define single-at-finder 
  (lambda (node)
    (let ((saff (lambda (x) (and (list? x) (eq? (car x) '@)))))
      (find saff (cdr node)))))

(define multi-at-finder
  (lambda (node)
    (let ((maff (lambda (x) (eq? (car x) '@))))
      (filter maff (cdr node)))))

(define annotations
  (lambda (node type)
    (let ((at-list (single-at-finder node)))
      (if at-list
	  (if (eqv? type sdom:node-type-element)
	      (let ((sub-at-list (single-at-finder at-list)))
		(if sub-at-list (cdr sub-at-list) '()))
	      (cdr at-list))
	  '()))))

(define whole-annotation
  (lambda (node annts name)
    (let ((waf (lambda (x) (eq? (car x) name))))
      (find waf annts))))

(define annotation
  (lambda (node annts annotation-name)
    (let ((whole (whole-annotation node annts annotation-name)))
      (if whole (cadr whole) whole))))

(define annotate!
  (lambda (node type new-annotation)
    (let* ((anntns (annotations node type))
	   (cna (car new-annotation))
	   (axf (lambda (x) (eq? (car x) cna))))	   
      (if (null? anntns)
	  (if (eqv? type sdom:node-type-element)
	      (let ((attrs (single-at-finder node)))
		(if (eq? attrs #f)
		    (append! node (list (list '@ (list '@ new-annotation))))
		    (let ((sub-attrs (single-at-finder attrs)))
		      (if sub-attrs
			  (let ((x (find axf (cdr sub-attrs))))
			    (if x 
				(set-cdr! x (cdr new-annotation))
				(append! sub-attrs `(,new-annotation))))
			  (append! attrs (list (list '@ new-annotation)))))))
	      (set-cdr! (last-pair node) (list (list '@ new-annotation)))))
      (let ((x (find axf anntns)))
	(if x (set-cdr! x (cdr new-annotation))
	    (append! anntns (list new-annotation)))))))

;; This not only removes the annotation itself, but may also remove the entire
;; annotative node if there are no more annotations left in it.

(define remove-annotation!
  (lambda (node type sym)
    (let ((annt (find (lambda (x) (eq? (car x) sym)) (annotations node type)))
	  (at-list (single-at-finder node)))
      (if (eqv? type sdom:node-type-element)
	  (for-each (lambda (item)
		      (begin (if (eq? (car item) '@)
				 (delq! annt item))
			     (if (= (length item) 1)
				 (delq! item at-list))))
		    (if at-list (cdr at-list) '()))
	  (if at-list (begin 
			(delq! annt at-list)
			(if (= (length at-list) 1)
			    (delq! at-list node))))))))

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; Internal functions for manipulating namespaces                            ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

(define add-namespace
  (lambda (node prefix uri) 
    (let ((type (sdom:node-type node)))
      (if (null? prefix)
	  (annotate! node type (list 'sdom:default-namespace uri))
	  (let* ((doc (if (eqv? type sdom:node-type-document)
			  node 
			  (get-dom-property node type 'sdom:owner-document)))
		 (new-decl (if (sdom:get-dom-config-parameter 
				doc "sdom:resolve-new-prefixes")
			       `(,(string->symbol uri) ,uri ,prefix)
			       `(,prefix ,uri ,prefix)))
		 (annts (annotations node type))
		 (w (whole-annotation node annts '*NAMESPACES*)))
	    (if w
		(let ((n (lookup-prefix-at-node node prefix)))
		  (if n 
		      (begin (if (= (length n) 3) 
				 (set-car! (caddr n) prefix) 
				 (append! n `(,prefix)))
			     (set-car! (cadr n) uri))
		      (append! w `(,new-decl))))
		(annotate! node type `(*NAMESPACES* ,new-decl))))))))

(define remove-namespace-by-prefix
  (lambda (node prefix) #f))

(define remove-namespace-by-namespace
  (lambda (node uri) #f))

(define lookup-prefix-at-node
  (lambda (node prefix) 
    (let* ((type (sdom:node-type node))
	   (annts (annotations node type))
	   (w (whole-annotation node annts '*NAMESPACES*))
	   (doc (if (eqv? type sdom:node-type-document)
		    node
		    (get-dom-property node type 'sdom:owner-document)))
	   (p (sdom:get-dom-config-parameter doc "sdom:prefer-orig-prefix"))
	   (pref-sym (string->symbol prefix)))
      (if w
	  (find (if p 
		    (lambda (x) (if (= (length x) 3)
				    (eq? (caddr x) pref-sym)
				    (eq? (car x) pref-sym)))
		    (lambda (x) (eq? (car x) pref-sym)))
		(cdr w))
	  #f))))

(define lookup-namespace-at-node
  (lambda (node uri) 
    (let* ((annts (annotations node (sdom:node-type node)))
	   (w (whole-annotation node annts '*NAMESPACES*)))
      (if w
	  (find (lambda (x) (equal? (cadr x) uri)) (cdr w))
	  #f))))

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; DOM feature management functions                                          ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

(define sdom-feature-registry '(("Core" . "3.0") ("XML" . "1.0")))
(define sdom:register-feature! 
  (lambda (feature version)
      (if (not (sdom:has-feature? feature version)) 
	  (append! sdom-feature-registry `((,feature . ,version))))))
(define sdom:has-feature? 
  (lambda (feature version) 
    (let ((f (find (lambda (x) (equal? x `(,feature . ,version))) 
		   sdom-feature-registry))) 
      (if (not f) #f #t))))

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; DOM configuration functions                                               ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

;; The values after the option name are required supported values; the first
;; is the default.

(define sdom:config-parameter-names
  `("canonical-form" "cdata-sections" "check-character-normalization"
    "comments" "datatype-normalization" "element-content-whitespace" "entities"
    "error-handler" "infoset" "namespaces" "namespace-declarations"
    "normalize-characters" "split-cdata-sections" "strict-error-checking"
    "validate" "validate-if-schema" "well-formed" "sdom:prefer-orig-prefix"
    "sdom:resolve-new-prefixes"))

(define sdom-config-defaults
  `(("canonical-form" #f ,boolean?
     ,(lambda (d x)
	(if x (begin (sdom:set-dom-config-parameter! d "entities" #f)
		     (sdom:set-dom-config-parameter! 
		      d "normalize-characters" #f)
		     (sdom:set-dom-config-parameter! d "cdata-sections" #f)
		     (sdom:set-dom-config-parameter! d "namespaces" #t)
		     (sdom:set-dom-config-parameter! 
		      d "namespace-declarations" #t)
		     (sdom:set-dom-config-parameter! d "well-formed" #t)
		     (sdom:set-dom-config-parameter! 
		      d "element-content-whitespace" #t)))))
    ("cdata-sections" #t ,boolean?)
    ("check-character-normalization" #f ,(lambda (x) (not x)))
    ("comments" #t ,boolean?)
    ("datatype-normalization" #f ,(lambda (x) (not x)))
    ("element-content-whitespace" #t ,(lambda (x) (eq? #t x)))
    ("entities" #t ,boolean?)
    ("error-handler" ,default-dom-error-handler ,procedure?)
    ("infoset" #f ,boolean? 
     ,(lambda (d x) 
	(if x (begin (sdom:set-dom-config-parameter! d "validate-if-schema" #f)
		     (sdom:set-dom-config-parameter! d "entities" #f)
		     (sdom:set-dom-config-parameter! 
		      d "datatype-normalization" #f)
		     (sdom:set-dom-config-parameter! d "cdata-sections" #f)
		     (sdom:set-dom-config-parameter! 
		      d "namespace-declarations" #t)
		     (sdom:set-dom-config-parameter! d "well-formed" #t)
		     (sdom:set-dom-config-parameter! 
		      d "element-content-whitespace" #t)
		     (sdom:set-dom-config-parameter! d "comments" #t)
		     (sdom:set-dom-config-parameter! d "namespaces" #t))
	    (set-car! 
	     (let* ((annts (annotations d sdom:node-type-document))
		    (w (whole-annotation d annts '*CONFIG*)))
	       (cdr (find (lambda (x) 
			    (and (list? x) 
				 (equal? "infoset" (car x))))
			  (if w w '()))))
	     #t))))
    ("namespaces" #t ,(lambda (x) (eq? #t x)))
    ("namespace-declarations" #t ,boolean?)
    ("normalize-characters" #f ,(lambda (x) (not x)))
    ("split-cdata-sections" #t ,boolean?)
    ("strict-error-checking" #t ,boolean?)
    ("validate" #f ,(lambda (x) (not x)))
    ("validate-if-schema" #f ,(lambda (x) (not x)))
    ("well-formed" #t ,(lambda (x) (eq? #t x)))

    ("sdom:prefer-orig-prefix" #f ,boolean?)
    ("sdom:resolve-new-prefixes" #t ,boolean?)))

(define get-sdom-config-default 
  (lambda (str) 
    (let ((def (find (lambda (x) (equal? (car x) (string-downcase str)))
		     sdom-config-defaults)))
      (if (not def)
	  (throw 'sdom:exception sdom:exception-code-not-found-err)
	  (cadr def)))))

(define sdom:get-dom-config-parameter
  (lambda (doc str) 
    (if (not (eqv? (sdom:node-type doc) sdom:node-type-document))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let* ((annts (annotations doc sdom:node-type-document))
	   (config (whole-annotation doc annts '*CONFIG*))
	   (match (if config 
		      (find (lambda (x) 
			      (and (list? x) (equal? (car x) 
						     (string-downcase str))))
			    config)
		      #f)))
      (if (not match) (get-sdom-config-default str) (cadr match)))))

(define internal-get-dom-config-entry
  (lambda (str)
    (find (lambda (x) (equal? (car x) (string-downcase str))) 
	  sdom-config-defaults)))

(define internal-check-dom-config-parameter
  (lambda (doc str val)
    (if (not (eqv? (sdom:node-type doc) sdom:node-type-document))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let ((foo (internal-get-dom-config-entry str)))
      (if (not foo) 
	  (throw 'sdom:exception sdom:exception-code-not-found-err))
      (if (not (apply (caddr foo) val '()))
	  (throw 'sdom:exception sdom:exception-code-not-supported-err)))))

(define sdom:add-dom-config-parameter! 
  (lambda (str . vals) 
    (append! sdom-config-defaults `(,(append `(,str) vals)))))

(define sdom:set-dom-config-parameter!
  (lambda (doc str val)
    (internal-check-dom-config-parameter doc str val)
    (let* ((annts (annotations doc sdom:node-type-document))
	   (config (begin (if (not (annotation doc annts '*CONFIG*))
			      (begin (annotate! doc 9 (list '*CONFIG*))
				     (set! annts (annotations doc 9))))
			  (whole-annotation doc annts '*CONFIG*)))
	   (match (find (lambda (x) 
			  (and (list? x) 
			       (equal? (string-downcase str) (car x))))
			config)))
      (if match 
	  (set-car! (cdr match) val)
	  (append! config `((,(string-downcase str) ,val))))
      (let ((entry (internal-get-dom-config-entry str)))
	(if (= (length entry) 4)
	    (apply (cadddr entry) doc val '()))))))

(define sdom:can-set-dom-config-parameter?
  (lambda (doc str val)
    (false-if-exception (internal-check-dom-config-parameter doc str val))))

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; Internal functions for managing entities and entity references            ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

(define update-entity-reference! 
  (lambda (doc n)
    (let* ((dtd (get-dom-property doc 9 'sdom:doc-type))
	   (ents (if dtd (get-dom-property dtd 10 'sdom:entities) '()))
	   (refname (derive-name n 5))
	   (match (find (lambda (x) (equal? (derive-name x 6) refname)) ents))
	   (refkids (extract-children n 5))
	   (entkids (if match (extract-children match 5) '())))
      (if (not (list= sdom:equal-node? refkids entkids))
	  (let ((len (length entkids)))
	    (for-each (lambda (x) (remove-child! n 1)) refkids)
	    (for-each (lambda (x) 
			(let ((t (sdom:node-type x)))
			  (insert-child! n 5 (clone-node x t doc #t) t len)))
		      entkids))))))

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; Internal functions for managing internal and external node                ;;
;; representations                                                           ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

;; The motivation for this pair of functions is that according to the SXML
;; grammar, character data, entities, and comments can't have annotations.
;; The solution is to store the annotations in the node's parent and just
;; attach them to the node when we extract it.

(define internal-rep-cache (make-weak-key-hash-table 16))

(define pos-symbol 
  (lambda (pos) (string->symbol (string-append "@-" (number->string pos)))))

(define ext->int
  (lambda (node type)
    (let* ((parent (get-dom-property node type 'sdom:parent-node))
	   (oldrep (get-dom-property node type 'sdom:sxml-representation))
	   (val (derive-value node type))
	   (ptype (if parent (sdom:node-type parent) #f)))
      (if (or (eqv? type sdom:node-type-text)
	      (eqv? type sdom:node-type-cdata-section))
	  (begin 
	    (if parent
		(let* ((rep `(sdom:sxml-representation ,oldrep))
		       (pos (letrec 
				((f (lambda (x count)
				      (let ((cx (car x))
					    (dx (cdr x)))
					(cond ((null? x) #f)
					      ((and (list? cx) 
						    (eq? (car cx) '@))
					       (f dx count))
					      ((eq? cx (cadr rep)) count)
					      (else (f dx (+ count 1))))))))
			      (f (cdr parent) 
				 (if (memv ptype (list 2 5 6)) 0 1))))
		       (a-pos (list-index (lambda (x) (and (list? x) 
							   (eq? (car x) '@)))
					  parent))
		       (r-pos (+ (if (and a-pos (< a-pos pos)) (+ pos 1) pos)
				 (if (memv ptype (list 2 5 6)) 1 0))))
		  (if pos 
		      (begin 
			(annotate! 
			 parent
			 ptype
			 (cons (pos-symbol pos)
			       `(,(append '(@) (annotations node type)))))
			(cond ((or (eqv? type sdom:node-type-text)
				   (eqv? type sdom:node-type-cdata-section))
			       (list-set! parent r-pos val)))
			(hashq-remove! parent-node-hash oldrep)
			(hashq-set! parent-node-hash val parent))
		      (throw 'sdom:exception 
			     sdom:exception-code-not-found-err))))
	    (annotate! node type `(sdom:sxml-representation ,val)))))))

(define int->ext
  (lambda (parent t child-pos)
    (let ((a (annotations parent t)))
      (letrec ((annts (annotation parent a (pos-symbol child-pos)))
	       (create-rep (lambda (x)
			     (append (if (list? x) x `(,x)) `(,annts))))
	       (f (lambda (item count)
		    (let ((ci (car item)))
		      (cond ((eq? item '()) '())
			    ((and (list? ci) (eq? (car ci) '@)) 
			     (f (cdr item) count))
			    ((eqv? count child-pos) 
			     (if annts
				 (let ((cached-ref (hashq-ref 
						    internal-rep-cache 
						    ci)))
				   (if (not cached-ref)
				       (let ((c (create-rep ci)))
					 (hashq-set! internal-rep-cache ci c)
					 c)
				       cached-ref))
				 ci))
			    (else (f (cdr item) (+ count 1))))))))
	(if (memv t (list 2 5 6))
	    (f (cddr parent) 1)
	    (f (cdr parent) 1))))))
  
;; Unless the events module is loaded, this is a no-op.

(define sdom:dispatch-event
  (lambda args
    (if (defined? 'sdom:dispatch-event-internal)
	(apply (module-ref (resolve-module '(sdom events))
			   'sdom:dispatch-event-internal) args)
	#f)))

(define sdom:dom-implementation-create-document-type
  (lambda (q-name public-id system-id) ()))

(define sdom:dom-implementation-get-feature
  (lambda (feature version) ()))

(define sdom:node-type
  (lambda (node) 
    (let ((cn (car node)))
      (case cn
	((*TOP*) sdom:node-type-document)
	((*COMMENT*) sdom:node-type-comment)
	((*ENTITY*) sdom:node-type-entity)
	((*ENTITY-REF*) sdom:node-type-entity-reference)
	((*FRAGMENT*) sdom:node-type-document-fragment)
	((*DOCTYPE*) sdom:node-type-document-type)
	((*PI*) sdom:node-type-processing-instruction)
	((*NOTATION*) sdom:node-type-notation)
	((@) sdom:node-type-attr) 
	(else (cond ((string? cn)
		     (let ((a (single-at-finder node)))
		       (if (and a (find (lambda (x) 
					  (equal? x '(sdom:is-cdata #t)))
					(cdr a)))
			   sdom:node-type-cdata-section
			   sdom:node-type-text)))
		    ((symbol? cn) sdom:node-type-element)
		    (else throw 'sdom:exception 
			  sdom:exception-code-type-mismatch-err)))))))

(define derive-name
  (lambda (node type)
    (case type
      ((2) (symbol->string (cadr node)))
      ((4) "#cdata-section")
      ((8) "#comment")
      ((9) "#document")
      ((11) "#document-fragment")
      ((10) (annotation node (annotations node 10) 'sdom:name))
      ((1) (symbol->string (car node)))
      ((6) (symbol->string (cadr node)))
      ((5) (symbol->string (cadr node)))
      ((12) (symbol->string (cadr node)))
      ((7) (symbol->string (cadr node)))
      ((3) "#text"))))

(define derive-value
  (lambda (node type)
    (case type
      ((2)
       (if (get-dom-property node 2 'sdom:specified)
	   (if (sdom:has-child-nodes? node)
	       (let ((fc (get-dom-property node 2 'sdom:first-child)))
		 (derive-value fc (sdom:node-type fc)))
	       "")))
      ((4) (car node))
      ((3) (car node))
      ((8) (cadr node))
      ((7) (caddr node))
      (else '()))))

(define set-value!
  (lambda (node type value)
    (if (not (equal? (derive-value node type) value))
	(begin
	  (cond ((eqv? type sdom:node-type-attr)
		 (let* ((d (get-dom-property node type 
					     'sdom:owner-document))
			(t (sdom:create-node d sdom:node-type-text value))
			(x (get-dom-property node type 'sdom:first-child)))
		   (if x
		       (sdom:replace-child! node t x)
		       (sdom:append-child! node t))))
		((or (eqv? type sdom:node-type-cdata-section)
		     (eqv? type sdom:node-type-text))
		 (let ((old-value (derive-value node type)))
		   (set-car! node value)
		   (ext->int node type)
		   (sdom:dispatch-event
		    node 'sdom:event-dom-character-data-modified 
		    node old-value value "" 0)))
		((eqv? type sdom:node-type-comment) 
		 (set-car! (cdr node) value))
		((eqv? type sdom:node-type-processing-instruction) 
		 (let ((old-value (derive-value node type)))
		   (set-car! (cddr node) value)
		   (sdom:dispatch-event 
		    node 'sdom:event-dom-character-data-modified
		    node old-value value "" 0))))))))

(define get-prefix 
  (lambda (str) 
    (let ((i (string-rindex str #\:))) 
      (if (and i (> i 0)) (substring str 0 i) '()))))

(define valid-qname-chars?
  (lambda (doc qname)
    (let ((resolve (sdom:get-dom-config-parameter 
		    doc "sdom:resolve-new-prefixes")))
      (regex-match? (if resolve qname-char-regex-extended qname-char-regex) 
		    qname))))

(define valid-namespace-combo? 
  (lambda (doc qname uri)
    (let ((resolve (sdom:get-dom-config-parameter 
		    doc "sdom:resolve-new-prefixes"))
	  (prefix (get-prefix qname)))
    (cond ((not (regex-match? (if resolve qname-regex-extended qname-regex)
			      qname)) #f)
	  ((and (not (null? prefix)) (null? uri)) #f)
	  ((and (or (equal? qname "xml")
		    (equal? prefix "xml"))
		(not (equal? uri xml-ns-uri))) #f)
	  ((and (or (equal? qname "xmlns")
		    (equal? prefix "xmlns"))
		(not (equal? uri xmlns-ns-uri))) #f)
	  ((and (equal? uri xmlns-ns-uri)
		(not (equal? qname "xmlns"))
		(not (equal? prefix "xmlns"))) #f)
	  (else #t)))))

(define get-local-name 
  (lambda (str) 
    (let ((i (string-rindex str #\:))) 
      (if (and i (not (eqv? i (- (string-length str) 1)))) 
	  (substring str (+ i 1)) 
	  str))))

(define set-prefix!
  (lambda (node type p)
    (let* ((namespace-uri (get-dom-property node type 'sdom:namespace-uri))
	   (name (get-dom-property node type 'sdom:local-name)))
      (if (or (not namespace-uri)
	      (and (equal? p "xml")
		   (not (equal? namespace-uri xml-ns-uri)))
	      (and (eqv? type sdom:node-type-attr)
		   (or (and (equal? p "xmlns")
			    (not (equal? namespace-uri xmlns-ns-uri)))
		       (equal? (get-dom-property
				node type 'sdom:qualified-name)
			       "xmlns"))))
	  (throw 'sdom:exception sdom:exception-code-namespace-err)
	  (cond ((eqv? type sdom:node-type-attr)
		 (set-car! (cdr node) 
			   (string->symbol (string-append (p ":" name)))))
		((eqv? type sdom:node-type-element)
		 (set-car! (cdr node)
			   (string->symbol (string-append (p ":" name))))))))))

(define extract-attributes
  (lambda (node type)
    (cond ((eqv? type sdom:node-type-element)
	   (let ((node-list (single-at-finder node))
		 (eaf1 (lambda (x) (cons '@ x)))
		 (eaf2 (lambda (x) (not (eq? (car x) '@)))))
	     (if (not (eq? node-list #f))
		 (map eaf1 (filter eaf2 (cdr node-list)))
		 '())))
	  (else '()))))

(define extract-children
  (lambda (node type)
    (let ((not-annt-fn (lambda (item) 
			 (or (and (list? item) (not (eq? (car item) '@)))
			     (string? item)))))
      (cond ((memv type (list 1 2 5 6))
	     (let ((counter 0)
		   (x (filter not-annt-fn (if (eqv? type 1)
					      (cdr node)
					      (cddr node)))))
	       (map (lambda (item) 
		      (set! counter (+ counter 1))
		      (int->ext node type counter))
		    x)))
	    ((or (eqv? type sdom:node-type-document)
		 (eqv? type sdom:node-type-document-fragment))
	     (let ((counter 0))
	       (map (lambda (item)
		      (set! counter (+ counter 1))
		      (int->ext node type counter))
		    (filter not-annt-fn (cdr node)))))
	    ((eqv? type sdom:node-type-attr)
	     (let ((child (caddr node))) 
	       (if (not (and (list? child) (eq? (car child) '@))) 
		   `(,(int->ext node type 1))
		   '())))
	    (else '())))))

(define first-child 
  (lambda (node type)
    (let ((child-list (extract-children node type)))
      (if (null? child-list) #f (car child-list)))))

(define last-child
  (lambda (node type)
    (let ((child-list (extract-children node type)))
      (if (null? child-list) #f (car (last-pair child-list))))))

(define owner-document
  (lambda (node type)
    (letrec 
	((top-finder 
	  (lambda (item)
	    (if item
		(let* ((it (sdom:node-type item))
		       (annts (annotations item it))
		       (owner (annotation item annts 'sdom:owner-document))
		       (item (let ((a (annotation 
				       item annts 'sdom:sxml-representation)))
			       (if a a item))))			       
		  (cond (owner (owner))
			((eqv? it sdom:node-type-document) item)
			((eqv? it sdom:node-type-attr)
			 (top-finder (hashq-ref parent-node-hash (cdr item))))
			((or (eqv? it sdom:node-type-element)
			     (eqv? it sdom:node-type-entity-reference)
			     (eqv? it sdom:node-type-document-type)
			     (eqv? it sdom:node-type-processing-instruction)
			     (eqv? it sdom:node-type-text)
			     (eqv? it sdom:node-type-cdata-section)
			     (eqv? it sdom:node-type-comment))
			 (top-finder (hashq-ref parent-node-hash item)))
			(else #f)))
		#f))))
      (if (eqv? type sdom:node-type-document) #f (top-finder node)))))

(define sdom:dom-structure
  `(,sdom:node-type-node 
    (@ (sdom:read-only 
	,(lambda (x t) 
	   (let* ((annts (annotations x (sdom:node-type x)))
		  (r (find (lambda (y) 
			     (eq? (annotation y annts 'sdom:read-only) #t))
			   (ancestors x))))
	     (if r #t #f))))
       (sdom:node-type ,(lambda (x t) t))
       (sdom:node-name ,derive-name)
       (sdom:node-value ,derive-value ,set-value!)
       (sdom:parent-node 
	,(lambda (node t)
	   (let* ((x (cond ((memv t `(,sdom:node-type-cdata-section
				      ,sdom:node-type-text))
			    (annotation node 
					(annotations node t)
					'sdom:sxml-representation))
			   ((eqv? t sdom:node-type-attr) (cdr node))
			   (else node))))
	     (hashq-ref parent-node-hash x))))
       (sdom:child-nodes ,(lambda (x t) (extract-children x t)))
       (sdom:first-child ,first-child)
       (sdom:last-child ,last-child)
       (sdom:previous-sibling 
	,(lambda (node t) 
	   (let* ((p (get-dom-property node t 'sdom:parent-node))
		  (r (if p (reverse (extract-children 
				     p (sdom:node-type p))) #f)))
	     (letrec ((f (lambda (x)
			   (if (or (null? x) (sdom:same-node? (car x) node))
			       x (f (cdr x))))))
	       (if p
		   (let ((fr (f r)))
		     (if (> (length fr) 1) (cadr fr) #f))
		   #f)))))
       (sdom:next-sibling
	,(lambda (node t) 
	   (let* ((p (get-dom-property node t 'sdom:parent-node))
		  (r (if p (extract-children 
			    p (sdom:node-type p)) #f)))
	     (letrec ((f (lambda (x)
			   (if (or (null? x) (sdom:same-node? (car x) node))
			       x (f (cdr x))))))
	       (if p
		   (let ((fr (f r)))
		     (if (> (length fr) 1) (cadr fr) #f))
		   #f)))))
       (sdom:attributes ,extract-attributes)
       (sdom:owner-document ,owner-document)
       (sdom:namespace-uri #f)
       (sdom:prefix ,(lambda (x t) (get-prefix (derive-name x t)))
		    ,set-prefix!)
       (sdom:local-name
	,(lambda (x t) 
	   (if (whole-annotation x (annotations x t) 'sdom:namespace-uri)
	       (get-local-name (derive-name x t))
	       #f)))
       (sdom:base-uri
	,(lambda (x t)
	   (cond ((memv t `(,sdom:node-type-element
			    ,sdom:node-type-processing-instruction))
		  (let ((attr (if (eqv? t sdom:node-type-element)
				  (sdom:get-attribute x "xml:base")
				  #f)))
		    (if attr
			attr
			(let* ((p (get-dom-property x t 'sdom:parent-node))
			       (pt (sdom:node-type p)))
			  (if p 
			      (get-dom-property p pt 'sdom:base-uri)
			      (let ((pp (get-dom-property 
					 x t 'sdom:owner-document)))
				(get-dom-property pp (sdom:node-type pp)
						  'sdom:document-uri)))))))
		 ((eqv? t sdom:node-type-document)
		  (get-dom-property x t 'sdom:document-uri))
		 (else #f))))
       (sdom:text-content 
	,(lambda (x t)
	   (cond ((memv t `(,sdom:node-type-element
			    ,sdom:node-type-attr
			    ,sdom:node-type-entity
			    ,sdom:node-type-entity-reference
			    ,sdom:node-type-document-fragment))
		  (let ((nodes 
			 (filter 
			  (lambda (y)
			    (not 
			     (memv y
				   `(,sdom:node-type-comment
				     ,sdom:node-type-processing-instruction))))
			  (extract-children x t))))
		    (if (null? nodes) 
			"" 
			(apply string-append 
			       (map (lambda (y) (get-dom-property 
						 y (sdom:node-type y) 
						 'sdom:text-content))
				    nodes)))))
		 ((memv t `(,sdom:node-type-text
			    ,sdom:node-type-cdata-section
			    ,sdom:node-type-comment
			    ,sdom:node-type-processing-instruction))
		  (derive-value x t))
		 (else #f)))
	,(lambda (x t y)
	   (let ((children (extract-children x t)))
	     (if (is-readonly? x) 
		 (throw 'sdom:exception 
			sdom:exception-code-no-modification-allowed-err))
	     (if (not (memv t `(,sdom:node-type-document
				,sdom:node-type-document-type
				,sdom:node-type-notation)))
		 (begin 
		   (for-each (lambda (z) (sdom:remove-child! x z)) children)
		   (if (not (null? y))
		       (if (memv t `(,sdom:node-type-text
				     ,sdom:node-type-cdata-section
				     ,sdom:node-type-comment
				     ,sdom:node-type-processing-instruction))
			   (set-value! x t y)
			   (sdom:append-child! 
			    x (sdom:create-node (get-dom-property 
						 x t 'sdom:owner-document) 
						sdom:node-type-text y)))))))))
       (sdom:sxml-representation #f #f))
    (,sdom:node-type-character-data 
     (@ (sdom:data ,derive-value ,set-value!)
	(sdom:length ,(lambda (node t) 
			(let ((v (derive-value node t)))
			  (if (null? v)
			      0
			      (string-length (derive-value node t)))))))
     (,sdom:node-type-text 
      (@ (sdom:is-element-content-whitespace #f)
	 (sdom:whole-text 
	  ,(lambda (x t) 
	     (let ((span (get-adjacent-text-nodes x)))
	       (letrec ((f (lambda (y)
			     (if (null? y) 
				 ""
				 (let* ((cy (car y))
					(yt (sdom:node-type cy)))
				   (if (memv yt `(,3 ,4))
				       (string-append (derive-value cy yt)
						      (f (cdr y)))
				       (f (cdr y))))))))
		 (f span))))))
      (,sdom:node-type-cdata-section))
     (,sdom:node-type-comment))
    (,sdom:node-type-notation (@ (sdom:public-id #f)
				 (sdom:system-id #f)))
    (,sdom:node-type-entity (@ (sdom:public-id #f)
			       (sdom:system-id #f)
			       (sdom:notation-name #f)
			       (sdom:input-encoding #f)
			       (sdom:xml-encoding #f)
			       (sdom:xml-version #f)))
    (,sdom:node-type-entity-reference)
    (,sdom:node-type-processing-instruction 
     (@ (sdom:target ,(lambda (x t) (symbol->string (cadr x))))
	(sdom:data ,(lambda (x t) (caddr x))
		   ,set-value!)))
    (,sdom:node-type-attr 
     (@ (sdom:name ,derive-name)
	(sdom:specified 
	 ,(lambda (n t) (if (or (annotation 
				 n (annotations n 2) 'sdom:specified)
				(find (lambda (item) 
					(eqv? (sdom:node-type item)
					      sdom:node-type-text))
				      (extract-children n t)))
			    #t 
			    #f)))
	(sdom:value ,derive-value ,set-value!)
	(sdom:owner-element
	 ,(lambda (x t) (hashq-ref parent-node-hash (cdr x))))
	(sdom:schema-type-info ())
	(sdom:is-id ,(lambda (x t) 
		       (if (annotation x (annotations x 2) 'sdom:is-id) 
			   #t 
			   #f)))))
    (,sdom:node-type-element (@ (sdom:tag-name ,derive-name)
				(sdom:schema-type-info ())))
    (,sdom:node-type-document-type (@ (sdom:name #f)
				      (sdom:entities #f)
				      (sdom:notations #f)
				      (sdom:public-id #f)
				      (sdom:system-id #f)
				      (sdom:internal-subset #f)))
    (,sdom:node-type-document-fragment)
    (,sdom:node-type-document 
     (@ (sdom:doc-type 
	 ,(lambda (x t)
	    (find (lambda (y)
		    (eqv? (sdom:node-type y) sdom:node-type-document-type))
		  (extract-children x t))))
	(sdom:implementation #f)
	(sdom:document-element
	   ,(lambda (x t) 
	      (find (lambda (y) 
		      (eqv? (sdom:node-type y) sdom:node-type-element))
		    (extract-children x t))))
	(sdom:input-encoding #f)
	(sdom:xml-encoding #f)
	(sdom:xml-standalone #f #f)
	(sdom:xml-version #f #f)
	(sdom:document-uri #f #f)
	(sdom:dom-config #f)))))

(define property-table
  (let ((t (make-hash-table 32))
	(g (lambda (list-head)
	     (let ((r (find (lambda (x) (eq? (car x) '@)) list-head)))
	       (if r (cdr r) '())))))
    (letrec ((f (lambda (node-type list-head inheritance)
		  (let* ((hv (hashv-ref t node-type))
			 (hv (if (not hv) 
				 (let ((hv2 (make-hash-table 8)))
				   (hashv-set! t node-type hv2)
				   hv2)
				 hv))
			 (i (lambda (x) 
			      (hashq-set! hv (car x) (cdr x))))
			 (props (g list-head))
			 (subtrees (filter (lambda (x) (not (eq? (car x) '@)))
					   list-head)))
		    (for-each i inheritance)
		    (for-each i props)
		    (for-each (lambda (x) 
				(f (car x) (cdr x) (append inheritance props)))
			      subtrees)))))
      (let ((cds (cdr sdom:dom-structure)))
	(f (car sdom:dom-structure) cds (g cds))))
    t))

(define get-property-info
  (lambda (node-type name)
    (let ((r (hashv-ref property-table node-type)))
      (if r (hashq-ref r name #f) #f))))

(define get-dom-property
  (lambda (node t sym)
    (let* ((prop-spec (get-property-info t sym)))
      (if prop-spec 
	  (let ((f (car prop-spec)))
	    (if f 
		(f node t) 
		(annotation node (annotations node t) sym)))
	  (throw 'sdom:exception sdom:exception-code-not-found-err)))))
      
(define sdom:get-dom-property
  (lambda (node name)
    (if (not (sdom:node? node))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (string? name))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (get-dom-property node (sdom:node-type node) (string->symbol name))))

(define sdom:set-dom-property!
  (lambda (node name value) 
    (let* ((t (sdom:node-type node))
	   (x (get-property-info t (string->symbol name))))
      (cond ((not x)
	     (throw 'sdom:exception sdom:exception-code-not-found-err))
	    ((eqv? (length x) 1)
	     (throw 'sdom:exception 
		    sdom:exception-code-no-modification-allowed-err))
	    (else (let ((f (cadr x)))
		    (if f (apply f (list node t value)) 
			(annotate! node t `(,(string->symbol name) 
					    ,value)))))))))

(define ancestors
  (lambda (node)
    (letrec 
	((f (lambda (x)
	      (let ((type (sdom:node-type x)))
		(cons x
		      (cond ((or (eqv? type sdom:node-type-document)
				 (eqv? type 
				       sdom:node-type-document-fragment))
			     '())
			    ((eqv? type sdom:node-type-attr)
			     (let ((g (hashq-ref parent-node-hash (cdr x))))
			       (if g (f g) '())))
			    (else
			     (let ((g (get-dom-property
				       x type 'sdom:parent-node)))
			       (if g (f g) '())))))))))
      (cdr (f node)))))

(define allowed-child-types
  (lambda (node-type)
    (cond ((eqv? node-type sdom:node-type-attr)
	   `(,sdom:node-type-text
	     ,sdom:node-type-entity-reference))
	  ((or (eqv? node-type sdom:node-type-cdata-section)
	       (eqv? node-type sdom:node-type-comment)
	       (eqv? node-type sdom:node-type-document-type)
	       (eqv? node-type sdom:node-type-notation)
	       (eqv? node-type sdom:node-type-processing-instruction)) '())
	  ((eqv? node-type sdom:node-type-document)
	   `(,sdom:node-type-element
	     ,sdom:node-type-processing-instruction
	     ,sdom:node-type-comment
	     ,sdom:node-type-document-type))
	  ((or (eqv? node-type sdom:node-type-document-fragment)
	       (eqv? node-type sdom:node-type-element)
	       (eqv? node-type sdom:node-type-entity)
	       (eqv? node-type sdom:node-type-entity-reference))
	   `(,sdom:node-type-element
	     ,sdom:node-type-processing-instruction
	     ,sdom:node-type-comment
	     ,sdom:node-type-text
	     ,sdom:node-type-cdata-section
	     ,sdom:node-type-entity-reference))
	  (else (throw 'sdom:exception 
		       sdom:exception-code-type-mismatch-err)))))

(define type-allowed-as-child
  (lambda (parent-type child-type) 
    (not (eq? (memv child-type (allowed-child-types parent-type)) #f))))

(define remove-child!
  (lambda (node pos)
    (letrec ((type (sdom:node-type node))
	     (pos-sym (pos-symbol pos))
	     (f (lambda (item count)
		  (cond ((null? item) '())
			((and (list? (car item)) (eq? (caar item) '@)) 
			 (f (cdr item) count))
			((eqv? count pos) 
			 (hashq-remove! parent-node-hash (car item))
			 (delq! (car item) node))
			(else (f (cdr item) (+ count 1)))))))
      (f node (if (eqv? type sdom:node-type-attr) -1 0))
      (remove-annotation! node type pos-sym)
      (for-each 
       (lambda (item) 
	 (let ((str (symbol->string (car item))))
	   (if (and (equal? (substring str 0 1) "@")
		    (>= (string->number (substring str 2)) pos))
	       (set-car! item (pos-symbol (- (string->number (substring str 2))
					     1))))))
       (annotations node type)))))

;; pos starts at 0

(define insert-child!
  (lambda (node ntype child ctype pos)
    (let* ((annts (annotations child ctype))
	   (old-parent (get-dom-property child ctype 'sdom:parent-node)))
      (if old-parent (sdom:remove-child! old-parent child))      
      (remove-annotation! child ctype 'sdom:owner-document)      
      (hashq-set! parent-node-hash
		  (let ((sr (annotation child annts 
					'sdom:sxml-representation)))
		    (if sr sr child))
		  node)

      ;; Here we need to actually insert the sxml representation of the node,
      ;; plus change the special annotations for any requisite nodes that
      ;; fall after the insertion.  First, push all numbered annotations up by
      ;; one.

      (for-each 
       (lambda (item) 
	 (let ((str (symbol->string (car item))))
	   (if (and (equal? (substring str 0 1) "@")
		    (>= (string->number (substring str 2)) pos))
	       (set-car! item (pos-symbol (+ (string->number (substring str 2))
					     1))))))
       (annotations node ntype))

      (let* ((base-pos (cond ((memv ntype (list 2 5 6)) (+ pos 1))
			     (else pos)))
	     (a-pos (list-index (lambda (x) (and (list? x) (eq? (car x) '@)))
				node))
	     (real-pos (if (and a-pos (< a-pos base-pos))
			   (+ base-pos 1) base-pos))

	     ;; This is how we decide whether or not the child needs to be
	     ;; represented by its sxml-representation.

	     (rep (let ((annt (annotation child annts
					  'sdom:sxml-representation)))
		    (if annt annt child))))
	(if (< (length node) real-pos) 
	    (append! node (list rep))
	    (set-cdr! (list-tail node (- real-pos 1))
		      (let ((b (take-right (cdr node) 
					   (- (length node) real-pos))))
			(append (list rep) b))))))
    (ext->int child ctype)))
      ;; (sdom:dispatch-event (child 'sdom:event-dom-node-inserted)))))

(define list-pos
  (lambda (lst item pred) 
    (letrec ((f (lambda (x y z)
		  (cond ((null? x) #f) 
			((pred (car x) y) z) 
			(else (f (cdr x) y (+ z 1)))))))
      (f lst item 1))))

(define sdom:insert-before!
  (lambda (node new-node . ref-node)
    (let* ((t (sdom:node-type node))
	   (nt (sdom:node-type new-node))
	   (cs (extract-children node t))
	   (s (if (or (null? ref-node) (null? (car ref-node)))
		  1
		  (let ((pos (list-pos cs (car ref-node) sdom:same-node?)))
		    (if pos pos (throw 'sdom:exception 8))))))
      (if (eqv? nt sdom:node-type-document-fragment)
	  (for-each (lambda (x)
		      (let ((tx (sdom:node-type x)))
			(check-insertion-error node t x tx)
			(insert-child! node t x tx s)
			(set! s (+ s 1))))
		    (extract-children new-node nt))
	  (begin
	    (check-insertion-error node t new-node nt)
	    (insert-child! node t new-node nt s)))
      new-node)))

(define sdom:insert-after!
  (lambda (node new-node . ref-node)
    (let* ((t (sdom:node-type node))
	   (nt (sdom:node-type new-node))
	   (cs (extract-children node t))
	   (s (if (or (null? ref-node) (null? (car ref-node)))
		  (+ (length cs) 1)
		  (let ((pos (list-pos cs (car ref-node) sdom:same-node?)))
		    (if pos (+ pos 1) (throw 'sdom:exception 8))))))
      (begin
	(check-insertion-error node t new-node nt)
	(insert-child! node t new-node nt s)))))

(define sdom:remove-child!
  (lambda (node oc)
    (let* ((type (sdom:node-type node))
	   (otype (sdom:node-type oc))
	   (parent (get-dom-property oc otype 'sdom:parent-node)))
      (if (and parent (sdom:same-node? node parent))
	  (begin (remove-child! node (list-pos (extract-children node type) 
					       oc 
					       sdom:same-node?))
		 (if (eqv? type sdom:node-type-document)
		     (annotate! oc otype `(sdom:owner-document 
					   ,(lambda () node)))
		     (annotate! oc 
				otype 
				`(sdom:owner-document
				  ,(lambda ()
				     (get-dom-property
				      node type 'sdom:owner-document)))))
		 oc)
	  (throw 'sdom:exception sdom:exception-code-not-found-err)))))

;; FOR MORE-THAN-ONE-STEP MODIFICATIONS, NEED TO CHECK TO SEE WHETHER BOTH
;; STEPS CAN COMPLETE BEFORE ACTUALLY PERFORMING MODIFICATIONS.  NO, YOU
;; HAVEN'T DONE THIS YET!

(define sdom:replace-child!
  (lambda (node new-child old-child)
    (if (sdom:same-node? node new-child)
	(throw 'sdom:exception sdom:exception-code-hierarchy-request-err))
    (let* ((type (sdom:node-type node))
	   (otype (sdom:node-type old-child))
	   (ntype (sdom:node-type new-child))
	   (parentold (get-dom-property old-child otype 'sdom:parent-node))
	   (parentnew (get-dom-property new-child ntype 'sdom:parent-node)))
      (if (or (is-readonly? node)
	      (if (not parentold) #f (is-readonly? parentold)))
	  (throw 'sdom:exception 
		 sdom:exception-code-no-modification-allowed-err))
      (if (and parentold (sdom:same-node? node parentold))
	  (let ((pos (list-pos (extract-children node type) old-child 
			       sdom:same-node?)))
	    (sdom:remove-child! node old-child)
	    (check-insertion-error node type new-child ntype)
	    (insert-child! node type new-child ntype pos)
	    (if (eqv? type sdom:node-type-document)
		(annotate! old-child otype `(sdom:owner-document 
					     ,(lambda () node)))
		(annotate! old-child otype `(sdom:owner-document
				       ,(lambda ()
					  (get-dom-property
					   node type 'sdom:owner-document)))))
	    old-child)
	  (throw 'sdom:exception sdom:exception-code-not-found-err)))))

(define check-insertion-error
  (lambda (x xt y yt)
    (let ((od1 (owner-document x xt))
	  (od2 (owner-document y yt)))
      (if (not (or (and (not (eqv? xt sdom:node-type-document)) 
			(eq? od1 od2))
		   (and (eqv? xt sdom:node-type-document)
			(or (eqv? yt sdom:node-type-document-type)
			    (eq? x od2))))) 
	  (throw 'sdom:exception sdom:exception-code-wrong-document-err))
      (if (or (not (type-allowed-as-child xt yt))
	      (or (eq? x y)
		  (not (eq? (memv y (ancestors x)) #f)))
	      (and (eqv? xt sdom:node-type-document)
		   (eqv? yt sdom:node-type-element)
		   (get-dom-property x xt 'sdom:document-element)))
	  (throw 'sdom:exception sdom:exception-code-hierarchy-request-err)))))
    
(define sdom:append-child!
  (lambda (node new-child)
    (let ((type (sdom:node-type node))
	  (new-type (sdom:node-type new-child)))
      (check-insertion-error node type new-child new-type)
      (insert-child! node type new-child new-type 
		     (+ (length (extract-children node type)) 1)))))

;; I THINK THIS IS A STUPID PIECE OF THE API.  SHOULDN'T STORE THE DATA IN THE
;; TREE ITSELF, SINCE THE SPEC DOESN'T SAY IT'S A DOM PROPERTY.  EXTERNAL HASH
;; MAYBE?

(define handle-user-data-event
  (lambda (node op src dst)
    (let ((node-hash (hashq-ref user-data-hash node)))
      (if node-hash
	  (hash-fold (lambda (key val foo) 
		       (if (and val (procedure? (cdr val)))
			   (apply (cdr val) op key (car val) src dst '()))
		       '())
		     '()
		     node-hash)))))

(define sdom:set-user-data!
  (lambda (node key data . handler)
    (let ((node-hash (hashq-ref user-data-hash node)))
      (if node-hash
	  (let ((oldval (hash-ref node-hash key #f)))
	    (hash-set! node-hash key (if (and (not (null? handler))
					      (procedure? (car handler)))
					 (cons data (car handler))
					 (cons data #f)))
	    (if oldval (car oldval) #f))
	  (let ((new-hash-table (make-hash-table initial-user-data-hash-size)))
	    (hashq-set! user-data-hash node new-hash-table)
	    (hash-set! new-hash-table key (if (and (not (null? handler))
						   (procedure? (car handler)))
					      (cons data (car handler))
					      (cons data #f)))
	    #f)))))

(define sdom:get-user-data
  (lambda (node key) 
    (let ((node-hash (hashq-ref user-data-hash node)))
      (if node-hash 
	  (let ((data (hash-ref node-hash key)))
	    (if data (car data) #f))
	  #f))))

(define sdom:equal-node? 
  (lambda (n1 n2)
    (let* ((n1t (sdom:node-type n1))
	   (n2t (sdom:node-type n2))
	   (nsu1 (annotation n1 (annotations n1 n1t) 'sdom:namespace-uri))
	   (nsu2 (annotation n2 (annotations n2 n2t) 'sdom:namespace-uri))
	   (nm1 (derive-name n1 n1t))
	   (nm2 (derive-name n2 n2t)))
      (and (eqv? n1t n2t)
	   (equal? nm1 nm2)
	   (if (xor nsu1 nsu2)
	       #f
	       (if nsu1 (equal? (get-local-name nm1) (get-local-name nm2)) #t))
	   (equal? nsu1 nsu2)
	   (equal? (get-prefix nm1) (get-prefix nm2))
	   (equal? (derive-value n1 n1t) (derive-value n2 n2t))
	   (list= sdom:equal-node? 
		  (extract-attributes n1 n1t)
		  (extract-attributes n2 n2t))
	   (list= sdom:equal-node?
		  (extract-children n1 n1t)
		  (extract-children n2 n2t))))))

(define sdom:has-child-nodes? 
  (lambda (node) (> (length (extract-children node (sdom:node-type node))) 0)))

(define sdom:same-node?
  (lambda (node1 node2) 
    (let* ((type1 (sdom:node-type node1))
	   (type2 (sdom:node-type node2))
	   (annotation1 (annotation node1 
				    (annotations node1 type1)
				    'sdom:sxml-representation))
	   (annotation2 (annotation node2
				    (annotations node2 type2)
				    'sdom:sxml-representation)))
      (cond ((and annotation1 (eq? annotation1 annotation2)) #t)
	    ((eqv? type1 sdom:node-type-attr) (eq? (cdr node1) (cdr node2)))
	    (else (eq? node1 node2))))))
      
(define sdom:supported? (lambda (node feature version) #f))

(define get-adjacent-text-nodes
  (lambda (node)
    (letrec ((seekend 
	      (lambda (lst counter)
		(if (or (null? lst)
			(memv (sdom:node-type (car lst))
			      `(,sdom:node-type-element
				,sdom:node-type-comment
				,sdom:node-type-processing-instruction)))
		    counter
		    (seekend (cdr lst) (+ counter 1))))))
    (let* ((docorder 
	    (document-order (car (last-pair (cons node (ancestors node))))))
	   (ldocorder (length docorder))
	   (rdocorder (reverse docorder))
	   (fpos (list-index (lambda (x) (sdom:same-node? x node)) docorder))
	   (rpos (list-index (lambda (x) (sdom:same-node? x node)) rdocorder))
	   (start (- ldocorder (seekend (list-tail rdocorder rpos) rpos)))
	   (end (seekend (list-tail docorder fpos) fpos)))
      (list-head (list-tail docorder start) (- end start))))))

(define sdom:replace-whole-text! 
  (lambda (node txt)
    (if (not (eqv? (sdom:node-type node) sdom:node-type-text))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let* ((span (get-adjacent-text-nodes node))
	   (cspan (if (equal? txt "") span (cdr span))))
      (for-each (lambda (x) 
		  (let* ((xt (sdom:node-type x))
			 (isattr (eqv? xt sdom:node-type-attr))
			 (parent (get-dom-property
				  x xt (if isattr
					'sdom:owner-element
					'sdom:parent-node))))
		    (if parent
			(if isattr
			    (sdom:remove-attribute-node! parent x)
			    (sdom:remove-child! parent x)))))
		cspan)
      (if (equal? txt "") 
	  #f 
	  (begin (set-value! (car span) 3 txt) (car span))))))

(define is-readonly?
  (lambda (node)
    (let ((a (cons node (ancestors node))))
      (if (find (lambda (x) 
		  (let ((t (sdom:node-type x))) 
		    (memv t `(,sdom:node-type-document-type
			      ,sdom:node-type-entity
			      ,sdom:node-type-entity-reference
			      ,sdom:node-type-notation))))
		a)
	  #t 
	  #f))))
  
(define internal-lookup-scoped-namespace
  (lambda (node)
    (let ((type (sdom:node-type node)))
      (letrec ((aef (lambda (x) 
		      (find (lambda (y) 
			      (eqv? (sdom:node-type y) 
				    sdom:node-type-element))
			    (ancestors x))))
	       (ns-prop (get-dom-property node type 'sdom:namespace-uri))
	       (f (lambda (n)
		    (let* ((an (annotations n (sdom:node-type n)))
			   (ns-decl (annotation n an 'sdom:default-namespace)))
		      (if ns-decl
			  ns-decl
			  (let ((a (aef n)))
			    (if a (f a) '())))))))
	(if ns-prop
	    ns-prop
	    (cond ((eqv? type sdom:node-type-element) (f node))
		  ((eqv? type sdom:node-type-attr) 
		   (f (get-dom-property node type 'sdom:owner-element)))
		  (else #f)))))))

(define internal-ns-lookup
  (lambda (node str sym)
    (let ((type (sdom:node-type node))
	  (aef (lambda (x) 
		 (find (lambda (y) 
			 (eqv? (sdom:node-type y) sdom:node-type-element))
		       (ancestors x)))))
      (cond ((eqv? type sdom:node-type-element)
	     (let* ((annts (annotations node type))
		    (ns (annotation node annts 'sdom:namespace-uri))
		    (prefix (get-dom-property node type 'sdom:prefix))
		    (decls (whole-annotation node annts '*NAMESPACES*)))

	       ;; We're doing a prefix lookup.
	       
	       (cond ((eq? sym 'prefix)
		      (let ((f (lambda (elt uri orig)
				 (let ((eltns (get-dom-property 
					       elt 3 'sdom:namespace-uri))
				       (eltprefix (get-dom-property
						   elt 3 'sdom:prefix)))
				   (if (and eltns
					    (equal? eltns uri)
					    eltprefix
					    (let ((r (internal-ns-lookup 
						      orig eltprefix 'ns)))
					      (and r (equal? r uri))))
				       eltprefix
				       (let ((ae (aef elt)))
					 (if ae 
					     (internal-ns-lookup 
					      ae eltprefix sym)
					     #f)))))))
			(f node str node)))

		     ;; We're doing a namespaceURI lookup.

		     ((eq? sym 'ns)
		      (if (and ns (equal? str prefix)) 
			  ns
			  (let ((decl (lookup-namespace-at-node node str)))
			    (if decl
				(cadr decl)
				(let ((ae (aef node)))
				  (if ae 
				      (internal-ns-lookup ae str sym) 
				      #f))))))
				
		     ;; We're doing a default namespace lookup.

		     ((eq? sym 'default)
		      (if prefix
			  (let ((ae (aef node)))
			    (if ae (internal-ns-lookup ae str sym) #f))
			  (equal? str ns))))))
	    
	    ((eqv? type sdom:node-type-document)	     
	     (let ((de (get-dom-property node type 'sdom:document-element)))
	       (if de (internal-ns-lookup de str sym) #f)))
	    ((or (eqv? type sdom:node-type-entity)
		 (eqv? type sdom:node-type-notation)
		 (eqv? type sdom:node-type-document-type)
		 (eqv? type sdom:node-type-document-fragment)) #f)
	    ((eqv? type sdom:node-type-attr)
	     (let ((p (hashq-ref parent-node-hash (cdr node))))
	       (if p (internal-ns-lookup p str sym) #f)))
	    (else (let ((ae (aef node)))
		    (if ae (internal-ns-lookup ae str sym) #f)))))))

(define sdom:default-namespace?
  (lambda (node namespace-uri)
    (let ((ns (internal-ns-lookup node namespace-uri 'default)))
      (not (eq? ns #f)))))

;; I don't think we support DOM level 2 namespace-declarations as attributes

(define sdom:lookup-namespace-uri
  (lambda (node prefix)
    (if (not (sdom:node? node))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (string? prefix))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (internal-ns-lookup node prefix 'ns)))

(define sdom:lookup-prefix
  (lambda (node namespace-uri)
    (internal-ns-lookup node namespace-uri 'prefix)))

(define clone-node
  (lambda (node type doc deep)
    (let*
	((new-node 
	  (cond ((eqv? type sdom:node-type-document)
		 (let* ((x (sdom:create-document '() '()))
			(cnf (lambda (y) 
			       (let* ((t (sdom:node-type y))
				      (z (if (eqv? t 10)
					     (clone-node y t doc #f)
					     (import-node x doc y t #t))))
				 (insert-child! x 9 z t 1024)))))
		   (if deep 
		       (begin
			 (for-each cnf (extract-children node type))
			 (let* ((dtd1 (get-dom-property doc 9 'sdom:doc-type))
				(dtd2 (get-dom-property x 9 'sdom:doc-type))
				(ents (if dtd1 (get-dom-property 
						dtd1 10 'sdom:entities) #f)))
			   (if ents 
			       (annotate! 
				dtd2 
				10 
				`(sdom:entities
				  ,(map (lambda (y) 
					  (import-node 
					   x doc y (sdom:node-type y) #t))
					ents)))))))
		   x))
		((eqv? type sdom:node-type-element)
		 (let* ((x (sdom:create-node doc type (derive-name node type)))
			(cnf (lambda (y) 
			       (let ((z (clone-node y 2 doc #t)))
				 (sdom:set-attribute-node-internal! x z)))))
		   (for-each cnf (extract-attributes node type))
		   (if deep
		       (let ((p 1))
			 (for-each 
			  (lambda (y)
			    (let* ((t (sdom:node-type y))
				   (z (clone-node y t doc #t)))
			      (insert-child! x sdom:node-type-element z t p)
			      (set! p (+ p 1))))
			  (extract-children node type))))
		   x))
		((or (eqv? type sdom:node-type-cdata-section)
		     (eqv? type sdom:node-type-text))
		 (let ((n (sdom:create-node 
			   doc type (string-copy (derive-value node type)))))
		   (ext->int n type) n))
		((eqv? type sdom:node-type-attr)
		 (let ((new-node (sdom:create-node 
				  doc type (derive-name node type))))
		   (if (sdom:has-child-nodes? node)
		       (let* ((fc (first-child node 2))
			      (t (sdom:node-type fc))
			      (x (clone-node fc t doc #t)))
			 (annotate! 
			  x t `(sdom:owner-document ,(lambda () doc)))
			 (insert-child! new-node 2 x t 1)))
		   new-node))
		((eqv? type sdom:node-type-processing-instruction)
		 (sdom:create-node 
		  doc type (symbol->string (cadr node)) 
		  (string-copy (derive-value node type))))
		((eqv? type sdom:node-type-comment)
		 (sdom:create-node 
		  doc type (string-copy (derive-value node type))))
		((eqv? type sdom:node-type-document-type)
		 (sdom:create-document-type
		  (derive-name node 10)
		  (get-dom-property node 10 'sdom:public-id)
		  (get-dom-property node 10 'sdom:system-id)))
		((eqv? type sdom:node-type-entity)
		 (let* ((new-node (list '*ENTITY* (cadr node)))
			(cs (extract-children node 6))
			(len (length cs)))
		   (if deep (for-each (lambda (x) 
					(insert-child! 
					 new-node 6 x (sdom:node-type x) len))
				      cs))
		   new-node))))
	 (ns (get-dom-property node type 'sdom:namespace-uri)))
      (if ns (annotate! new-node type `(sdom:namespace-uri ,ns)))
      new-node)))

(define sdom:clone-node
  (lambda (node deep)
    (let* ((t (sdom:node-type node))
	   (d (if (eqv? t sdom:node-type-document)
		  node
		  (get-dom-property node t 'sdom:owner-document)))
	   (new-node (clone-node node t d deep)))
      (if (and (not (eqv? t sdom:node-type-document-type))
	       (not (eqv? t sdom:node-type-document)))  
	  (annotate! new-node t `(sdom:owner-document ,(lambda () d))))
      (handle-user-data-event node sdom:user-data-event-node-cloned node 
			      new-node)
      new-node)))
    
;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; Normalization functions for nodes and documents                           ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

(define internal-document-normalize!
  (lambda (doc w x)
    (if (not (null? x))
	(let* ((node (car x))
	       (type (sdom:node-type node)))
	  (cond ((eqv? type sdom:node-type-entity-reference)
		 (begin 
		   (update-entity-reference! doc node)
		   (let ((cs (extract-children node type)))
		     (if (and (not (null? cs))
			      (not (sdom:get-dom-config-parameter
				    doc "entities")))
			 (begin
			   (sdom:remove-child! w node)
			   (for-each (lambda (y) (sdom:append-child! w y))
				     (extract-children node type))
			   (internal-document-normalize! 
			    doc w (extract-children w (sdom:node-type w))))
		       (internal-document-normalize! doc w (cdr x))))))
		((eqv? type sdom:node-type-cdata-section)
		 (let ((val (derive-value node type)))
		   (if (sdom:get-dom-config-parameter doc "cdata-sections")
		       (let ((pos (string-contains val "]]>")))
			 (if pos 
			     (if (sdom:get-dom-config-parameter 
				  doc "split-cdata-sections")
				 (let ((pre (substring val 0 pos))
				       (post (substring val (+ pos 3))))
				   (begin
				     (if (> (string-length pre) 0)
					 (begin
					   (sdom:set-dom-property! 
					    (car x) "sdom:node-value" pre)
					   (if (> (string-length post) 0)
					       (sdom:insert-before! 
						w (sdom:create-node 
						   doc 
						   sdom:node-type-cdata-section
						   post) (if (null? (cdr x))
							     '()
							     (cadr x)))))
					 (if (> (string-length post) 0)
					     (sdom:set-dom-property!
					      (car x) "sdom:node-value" post)
					     (sdom:remove-child! w (car x))))
				     
				     (if (sdom:signal-error
					  doc sdom:error-severity-warning
					  "splitting cdata section" 
					  "cdata-sections-splitted" '() val 
					  '())
					 (internal-document-normalize! 
					  doc w (extract-children 
						 w (sdom:node-type w))))))
				 (sdom:signal-error 
				  doc sdom:error-severity-error 
				  "unrepresentable character data"
				  "character data" '() val '()))
			     (internal-document-normalize! 
			      doc w (cdr x))))
		       (begin
			 (sdom:replace-child! 
			  w (sdom:create-node doc sdom:node-type-text val) 
			  (car x))
			 (internal-document-normalize! 
			  doc w (extract-children w (sdom:node-type w)))))))

		((and (eqv? type sdom:node-type-comment)
		      (not (sdom:get-dom-config-parameter doc "comments")))
		 (sdom:remove-child! w (car x)) 
		 (internal-document-normalize! doc w (extract-children 
						      w (sdom:node-type w))))
		(else (internal-document-normalize! doc w (cdr x))))))))

(define internal-normalize-node!
  (lambda (w wt x)
    (if (not (null? x))
	(let* ((cx (car x))
	       (cxt (sdom:node-type cx))
	       (cax (if (null? (cdr x)) #f (cadr x)))
	       (caxt (if cax (sdom:node-type cax) #f)))	  
	  (if (and (eqv? cxt sdom:node-type-text)
		   (eqv? caxt sdom:node-type-text))
	      (begin
		(sdom:set-dom-property! 
		 cx "sdom:node-value"
		 (string-append (derive-value cx cxt) (derive-value cax caxt)))
		(sdom:remove-child! w cax)
		(internal-normalize-node! w wt (extract-children w wt))))
	  (internal-normalize-node! w wt (cdr x))))))

(define internal-normalize!
  (lambda (node type doc)
    (if (not (null? doc)) 
	(internal-document-normalize! doc node (extract-children node type)))
    (internal-normalize-node! node type (extract-children node type))
    (for-each (lambda (x) (internal-normalize! x (sdom:node-type x) doc)) 
	      (extract-children node type))))
	     
(define sdom:normalize!
  (lambda (node) (internal-normalize! node (sdom:node-type node) '())))

(define sdom:normalize-document!
  (lambda (node) 
    (if (not (eqv? (sdom:node-type node) sdom:node-type-document))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err)
	(internal-normalize! node sdom:node-type-document node))))

(define sdom:compare-document-position
  (lambda (node1 node2)
    (let* ((type1 (sdom:node-type node1))
	   (type2 (sdom:node-type node2))
	   (ownerdoc1 (if (eqv? type1 sdom:node-type-document)
			  node1 (get-dom-property 
				 node1 type1 'sdom:owner-document)))
	   (ownerdoc2 (if (eqv? type2 sdom:node-type-document)
			  node2 (get-dom-property 
				 node2 type2 'sdom:owner-document)))
	   (ancestors1 (ancestors node1))
	   (ancestors2 (ancestors node2)))
      (cond ((eq? node1 node2) 0)
	    ((or (not (eq? ownerdoc1 ownerdoc2)) ;; Different owners?
		 (and (not (and (eqv? type1 sdom:node-type-document)
				(eqv? type2 sdom:node-type-document)))
		      (let ((lpa1 (last-pair ancestors1))
			    (lpa2 (last-pair ancestors2)))
			(or (and (null? lpa1) (null? lpa2))
			    (and (not (and (null? lpa1) 
					   (sdom:same-node? 
					    node1 (car lpa2))))
				 (not (and (null? lpa2) 
					   (sdom:same-node? 
					    node2 (car lpa1))))
				 (not (sdom:same-node? (car lpa1) 
						       (car lpa2))))))))
	     (logior (if (> (hashq node1 most-positive-fixnum)
			    (hashq node2 most-positive-fixnum))
			 sdom:document-position-following
			 sdom:document-position-preceding)
		     sdom:document-position-disconnected
		     sdom:document-position-implementation-specific))
	    ((sdom:same-node? node1 node2) 0)
	    ((find (lambda (x) (sdom:same-node? x node1)) ancestors2)
	     (logior sdom:document-position-contained-by
		     sdom:document-position-following))
	    ((find (lambda (x) (sdom:same-node? x node2)) ancestors1)
	     (logior sdom:document-position-contains
		     sdom:document-position-preceding))
	    (else (let* ((commonroot (find (lambda (x) 
					     (find (lambda (y)
						     (sdom:same-node? x y)) 
						   ancestors2))
					   ancestors1))
			 (commontype (if commonroot 
					 (sdom:node-type commonroot)
					 #f))
			 (rootlist1
			  (reverse (take-while (lambda (x) 
						 (not (sdom:same-node? 
						       x commonroot))) 
					       ancestors1)))
			 (rootlist1 (if (null? rootlist1) 
					node1 
					(car rootlist1)))
			 (rootlist2 
			  (reverse (take-while (lambda (x)
						 (not (sdom:same-node?
						       x commonroot)))
					       ancestors2)))
			 (rootlist2 (if (null? rootlist2) 
					node2 
					(car rootlist2)))
			 (typer1 (eqv? (sdom:node-type rootlist1)
				       sdom:node-type-attr))
			 (typer2 (eqv? (sdom:node-type rootlist2)
				       sdom:node-type-attr)))
		    (if (eqv? typer1 typer2)
			(if typer1
			    (logior 
			     32 (let ((attrs (extract-attributes 
					      commonroot commontype)))
				  (if (> (list-index (lambda (x)
						       (sdom:same-node? 
							x rootlist1))
						     attrs)
					 (list-index (lambda (x) 
						       (sdom:same-node? 
							x rootlist2))
						     attrs))
				      sdom:document-position-following
				      sdom:document-position-preceding)))
			    (let ((children (extract-children 
					     commonroot commontype)))
			      (if (< (list-index (lambda (x)
						   (sdom:same-node? 
						    x rootlist1))
						 children)
				     (list-index (lambda (x)
						   (sdom:same-node?
						    x rootlist2))
						 children))
				  sdom:document-position-following
				  sdom:document-position-preceding)))
			(if typer1
			    sdom:document-position-following
			    sdom:document-position-preceding))))))))

(define sdom:create-node
  (lambda (document type . args)
    (let ((newnode 
	   (cond ((eqv? type sdom:node-type-attr)
		  (list '@ (string->symbol (car args))))
		 ((eqv? type sdom:node-type-cdata-section)
		  (list (string-copy (car args))
			(list '@ (list 'sdom:is-cdata #t)))) 
		 ((eqv? type sdom:node-type-comment)
		  (list '*COMMENT* (string-copy (car args))))
		 ((eqv? type sdom:node-type-document-fragment)
		  (list '*FRAGMENT*))
		 ((eqv? type sdom:node-type-element)
		  (list (string->symbol (car args))))
		 ((eqv? type sdom:node-type-entity) (list '*ENTITY))
		 ((eqv? type sdom:node-type-entity-reference)
		  (list '*ENTITY-REF* (string->symbol (car args))))
		 ((eqv? type sdom:node-type-processing-instruction)
		  (list '*PI* (string->symbol (car args)) (cadr args)))
		 ((eqv? type sdom:node-type-text)
		  (list (string-copy (car args))))
		 (else (throw 'sdom:exception 
			      sdom:exception-code-type-mismatch-err)))))
      (cond ((and (= (length args) 2)
		  (or (eqv? type sdom:node-type-attr)
		      (eqv? type sdom:node-type-element))
		  (not (null? (cadr args))))

	     ;; Need to check the qname / namespace combo here!!!

	     (annotate! newnode type `(sdom:namespace-uri ,(cadr args))))
	    ((or (eqv? type sdom:node-type-text)
		 (eqv? type sdom:node-type-cdata-section))
	     (annotate! newnode type 
			`(sdom:sxml-representation ,(car newnode)))))
      (if (not (eqv? type sdom:node-type-document-type))
	  (annotate! newnode type 
		     `(sdom:owner-document ,(lambda () document))))
      newnode)))

(define sdom:create-document
  (lambda (root-name doctype . namespace-uri)
    (let* ((head (list '*TOP*))
	   (newdoc (if (not (null? root-name))
		       (let ((e (list (string->symbol root-name))))
			 (begin0 (append! head (list e))
				 (hashq-set! parent-node-hash e head)))
		       head)))
      (if (not (null? doctype))
	  (begin
	    (if (not (eqv? (sdom:node-type doctype) 
			   sdom:node-type-document-type))
		(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
	    (if (get-dom-property doctype 10 'sdom:owner-document)
		(throw 'sdom:exception sdom:exception-code-wrong-document-err))
	    (annotate! doctype 
		       sdom:node-type-document-type 
		       `(sdom:owner-document `(lambda () ,newdoc)))
	    (annotate! newdoc 
		       sdom:node-type-document
		       `(sdom:doctype ,doctype)))
	  (if (and (not (null? namespace-uri))
		   (not (null? (car namespace-uri))))
	      (annotate! (get-dom-property newdoc 9 'sdom:document-element)
			 sdom:node-type-element
			 `(sdom:namespace-uri ,(car namespace-uri)))))
      newdoc)))

(define sdom:create-document-type
  (lambda (qname public-id system-id)
    (let ((new-dtd (list '*DOCTYPE*)))
      (annotate! new-dtd sdom:node-type-document-type `(sdom:name ,qname))
      (if (not (null? public-id))
	  (annotate! new-dtd 
		     sdom:node-type-document-type 
		     `(sdom:public-id ,public-id)))
      (if (not (null? system-id))
	  (annotate! new-dtd 
		     sdom:node-type-document-type 
		     `(sdom:system-id ,system-id)))
      new-dtd)))

;; I *think* this is correct -- DOM core isn't formally precise on the
;; definition of document order for non-element/attr nodes             - julian

(define document-order
  (lambda (start)
    (if (not (null? start))
	(let ((type (sdom:node-type start))
	      (f (lambda (x y) (append (document-order x) y))))
	  (cond ((eqv? type sdom:node-type-document)
		 (document-order (get-dom-property start type
				  'sdom:document-element)))
		((eqv? type sdom:node-type-element)
		 (cons start (fold-right 
			      f '() (append (extract-attributes start type)
					    (extract-children start type)))))
		((eqv? type sdom:node-type-attr)
		 (cons start (fold-right 
			      f '() (extract-children start type))))
		((or (eqv? type sdom:node-type-document-fragment)
		     (eqv? type sdom:node-type-entity)
		     (eqv? type sdom:node-type-entity-reference))
		 (fold-right 
		  f '() (extract-children start type)))
		(else `(,start))))
	'())))

(define sdom:get-elements-by-tag-name
  (lambda (doc name . args)
    (let* ((type (sdom:node-type doc))
	   (ns (if (not (null? args))
		   (let ((ca (car args)))
		     (if (string? ca) 
			 ca 
			 (throw sdom:exception-code-type-mismatch-err)))
		   "*")))      
      (if (not (eqv? type sdom:node-type-document))
	  (throw 'sdom:exception sdom:exception-code-type-mismatch-err))
      (filter (lambda (x)
		(and (eqv? (sdom:node-type x) sdom:node-type-element)
		     (or (equal? name "*")
			 (equal? (get-local-name (symbol->string (car x))) 
				 name))
		     (or (equal? ns "*")
			 (let ((y (sdom:lookup-prefix 
				   x (get-prefix (car x)))))
			   (if (null? y) #f (equal? ns y))))
		     #t))
	      (document-order doc)))))

;; NOT DONE, OBVIOUSLY

(define import-node
  (lambda (doc old-doc node type deep)
    (let ((new-node (clone-node node type old-doc deep)))
      (annotate! new-node type `(sdom:owner-document ,(lambda () doc)))
      (handle-user-data-event 
       node sdom:user-data-event-node-imported node new-node)
      new-node)))

(define sdom:import-node
  (lambda (doc node deep)
    (let ((type (sdom:node-type node)))
      (if (memv type `(,sdom:node-type-document 
		       ,sdom:node-type-document-type))
	  (throw 'sdom:exception sdom:exception-code-not-supported-err)
	  (import-node doc (owner-document node type) node type deep)))))

;; INCOMPLETE -- NEED TO ADD NEW NAMESPACE DECL IF NECESSARY!

(define adopt-node!
  (lambda (doc node type)
    (if (eqv? type sdom:node-type-attr)
	(begin 
	  (hashq-remove! parent-node-hash (cdr node))
	  (if (not (get-dom-property node type 'sdom:specified))
	      (begin
		(annotate! node type `(sdom:value ,(derive-value node type)))
		(annotate! node type '(sdom:specified #t))))))
    (let ((parent (get-dom-property node type 'sdom:parent-node)))
      (if parent (sdom:remove-child! parent node))
      (annotate! node type `(sdom:owner-document ,(lambda () doc))))
    (handle-user-data-event node sdom:user-data-event-node-adopted node '())
    node))

(define sdom:adopt-node!
  (lambda (doc node)
    (if (not (eqv? (sdom:node-type doc) sdom:node-type-document))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let ((type (sdom:node-type node)))
      (if (memv type `(,sdom:node-type-document
		       ,sdom:node-type-document-type))
	  (throw 'sdom:exception sdom:exception-code-not-supported-err))
      (if (memv type `(,sdom:node-type-notation
		       ,sdom:node-type-entity))
	  (throw 'sdom:exception sdom:exception-code-type-mismatch-err))
      (if (get-dom-property node type 'sdom:read-only)
	  (throw 'sdom:exception 
		 sdom:exception-code-no-modification-allowed-err))
      (adopt-node! doc node type))))

;; This needs to handle user data events and real event handlers 
;; (DOESN'T, YET) -- for all intents and purposes, this is a new node.  
;; The difficulty is that for elements, the name is the head of the list, which
;; we can't modify.

(define sdom:rename-node!
  (lambda (node qname ns)
    (let* ((type (sdom:node-type node))
	   (old-name (string-copy (derive-name node type)))
	   (old-ns (let ((x (get-dom-property node type 'sdom:namespace-uri)))
		     (if x (string-copy x) '())))
	   (doc (get-dom-property node type 'sdom:owner-document)))
      (if (not (memv type `(,sdom:node-type-attr ,sdom:node-type-element)))
	  (throw 'sdom:exception sdom:exception-code-not-supported-err))
      (if (not (valid-qname-chars? doc qname))
	  (throw 'sdom:exception sdom:exception-code-invalid-character-err))
      (if (not (valid-namespace-combo? doc qname ns))
	  (throw 'sdom:exception sdom:exception-code-namespace-err))
      (if (or (null? ns) (string-null? ns))
	  (remove-annotation! node type 'sdom:namespace-uri)
	  (annotate! node type (list 'sdom:namespace-uri ns)))
      (if (eqv? type sdom:node-type-element)
	  (begin

	    ;; Need to update any user-data hash keys that might be using this
	    ;; node as a key. This is the only instance in which we need to do
	    ;; this, since the ptr at the head of the list is changing...

	    (let ((oldtable (hashq-ref user-data-hash node)))
	      (if oldtable (hashq-remove! user-data-hash node))
	      (set-car! node (string->symbol qname))
	      (if oldtable (hashq-set! user-data-hash node oldtable)))
	    (sdom:dispatch-event node 'sdom:event-dom-element-name-changed node
				 '() '() '() '() old-name old-ns))
	  (let ((parent (get-dom-property node type 'sdom:parent-node)))
	    (set-car! (cdr node) (string->symbol qname))
	    (if parent
		(sdom:dispatch-event 
		 parent 'sdom:event-dom-attribute-name-changed node '() '() 
		 old-name '() old-name old-ns))))
      (handle-user-data-event 
       node sdom:user-data-event-node-renamed node '())
      node)))
		   
;; Here are some attribute-mangling functions -- the ones that don't deal with
;; nodes explicitly will call into the ones that do.

;;---------------------------------------------------------------------------;;
;;                                                                           ;;
;; Attribute management functions                                            ;;
;;                                                                           ;;
;;---------------------------------------------------------------------------;;

(define sdom:get-attribute-node
  (lambda (elt name . namespace-uri) 
    (if (not (eqv? (sdom:node-type elt) sdom:node-type-element))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let* ((finder (if (null? namespace-uri) 
		       (lambda (x) (equal? name (get-dom-property 
						 x 2 'sdom:name)))
		       (lambda (x) (and (equal? name 
						(get-dom-property 
						 x 2 'sdom:local-name))
					(equal? (get-dom-property 
						 x 2 'sdom:namespace-uri)
						(car namespace-uri)))))))
      (find finder (extract-attributes elt sdom:node-type-element)))))

(define sdom:set-attribute-node-internal!
  (lambda (elt node)
    (let ((x (find (lambda (y) (equal? (get-dom-property node 2 'sdom:name)
				       (get-dom-property y 2 'sdom:name)))
		   (extract-attributes elt sdom:node-type-element))))
      (hashq-set! parent-node-hash (cdr node) elt)
      (remove-annotation! node sdom:node-type-attr 'sdom:owner-document)
      (if x (delq! x (single-at-finder elt)))
      (append! (single-at-finder elt) `(,(cdr node))))))

(define sdom:set-attribute-node!
  (lambda (elt node) 
    (if (not (and (eqv? (sdom:node-type elt) sdom:node-type-element)
		  (eqv? (sdom:node-type node) sdom:node-type-attr)))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (eq? (get-dom-property elt 1 'sdom:owner-document)
		  (get-dom-property node 2 'sdom:owner-document)))
	(throw 'sdom:exception sdom:exception-code-wrong-document-err))
    (if (get-dom-property node 2 'sdom:owner-element)
	(throw 'sdom:exception sdom:exception-code-inuse-attribute-err))

    (let* ((name (get-dom-property node 2 'sdom:name))
	   (old-node (sdom:get-attribute-node elt name))
	   (old-value (sdom:get-attribute elt name))
	   (new-value (get-dom-property node 2 'sdom:value)))
      (if old-value
	  (sdom:dispatch-event elt 'sdom:event-dom-attr-modified 
			       old-node old-value old-value name 3))
      (sdom:set-attribute-node-internal! elt node)
      (sdom:dispatch-event elt 'sdom:event-dom-attr-modified 
			   node new-value new-value name 2))))

(define sdom:remove-attribute-node!
  (lambda (elt node) 
    (if (not (and (eqv? (sdom:node-type elt) sdom:node-type-element)
		  (eqv? (sdom:node-type node) sdom:node-type-attr)))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (eq? elt (get-dom-property node 2 'sdom:owner-element)))
	(throw 'sdom:exception sdom:exception-code-not-found-err))
    (delq! (cdr node) (single-at-finder elt))
    (let ((doc (get-dom-property node 2 'sdom:owner-document)))
      (annotate! node 
		 sdom:node-type-attr 
		 `(sdom:owner-document ,(lambda () doc))))
    (hashq-remove! parent-node-hash (cdr node))))

(define sdom:get-attribute
  (lambda (elt name . namespace-uri)
    (let ((node (if (not (null? namespace-uri))
		    (sdom:get-attribute-node elt name (car namespace-uri))
		    (sdom:get-attribute-node elt name))))
      (if node (derive-value node 2) #f))))

(define sdom:set-attribute!
  (lambda (elt name value . namespace-uri)
    (if (not (and (sdom:node? elt)
		  (eqv? (sdom:node-type elt) sdom:node-type-element)))
	(throw 'sdom:exceptiom sdom:exception-code-type-mismatch-err))
    (let ((ns (if (not (null? namespace-uri)) (car namespace-uri) #f))
	  (doc (get-dom-property elt 1 'sdom:owner-document)))
      (if (not (valid-namespace-combo? doc name (if ns ns '())))
	  (throw 'sdom:exception sdom:exception-code-namespace-err))
      (let ((attr (if ns 
		      (sdom:get-attribute-node elt name ns)
		      (sdom:get-attribute-node elt name))))
	(if attr
	    (let ((old-value (get-dom-property attr 2 'sdom:value)))
	      (sdom:set-dom-property! attr 'sdom:value value)
	      (sdom:dispatch-event elt 'sdom:event-dom-attr-modified 
				   attr old-value value name 2))
	    (let* ((attr (if ns
			     (sdom:create-node doc sdom:node-type-attr name ns)
			     (sdom:create-node doc sdom:node-type-attr name))))
	      (sdom:set-dom-property! attr "sdom:value" value)
	      (sdom:set-attribute-node-internal! elt attr)
	      (sdom:dispatch-event elt 'sdom:event-dom-attr-modified 
				   attr value value name 1)))))))

(define sdom:remove-attribute!
  (lambda (elt name . namespace-uri) 
    (let ((attr (if (not (null? namespace-uri))
		    (sdom:get-attribute-node elt name (car namespace-uri))
		    (sdom:get-attribute-node elt name))))
      (if attr (sdom:remove-attribute-node! elt attr)))))

(define sdom:get-element-by-id
  (lambda (doc id)
    (let ((pred (lambda (x) 
		  (and (eqv? (sdom:node-type x)
			     sdom:node-type-element)
		       (find (lambda (y) 
			       (and (get-dom-property y 2 'sdom:is-id)
				    (equal? id (derive-value y 2))))
			     (extract-attributes x sdom:node-type-element))))))
      (if (not (eqv? (sdom:node-type doc) sdom:node-type-document))
	  (throw 'sdom:exception sdom:exception-code-type-mismatch-err))
      (find pred (document-order doc)))))

(define sdom:set-id-attribute!
  (lambda (node name is-id . args)
    (let ((attr (if (null? args)
		    (sdom:get-attribute-node node name)
		    (sdom:get-attribute-node node name (car args)))))
      (if attr
	  (if is-id 
	      (annotate! attr sdom:node-type-attr '(sdom:is-id #t)) 
	      (remove-annotation! attr sdom:node-type-attr 'sdom:is-id))
	  (throw 'sdom:exception sdom:exception-code-not-found-err)))))

(define sdom:set-id-attribute-node!
  (lambda (attr is-id)
    (if (not (eqv? (sdom:node-type attr) sdom:node-type-attr))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if is-id
	(annotate! attr sdom:node-type-attr '(sdom:is-id #t))
	(remove-annotation! attr sdom:node-type-attr 'sdom:is-id))))

(define (xml-parser port namespace-prefix-assig)
  (letrec ((ns (map (lambda (el)
		      (cons* #f (car el) (ssax:uri-string->symbol (cdr el))))
		    namespace-prefix-assig))
	   (RES-NAME->SXML (lambda (res-name)
			     (string->symbol
			      (string-append
			       (symbol->string (car res-name))
			       ":"
			       (symbol->string (cdr res-name))))))

	   ; This is a teensy bit of trickery -- to properly create the
	   ; entity definition, we have to run its contents through the
	   ; parser and then append the expanded structure to a new entity
	   ; node, which is typically read-only. So we temporarily make SDOM 
	   ; think it's actually an element node.

	   (post-parse-entity 
	    (lambda (doc entdef)
	      (let* ((newdoc (sdom:xml->sdom 
			      (open-input-string
			       (string-append entity-parse-prefix
					      (cdr entdef)
					      entity-parse-suffix))))
		     (ent (list '*ENTITY* (car entdef)))
		     (elts (extract-children 
			    (get-dom-property 
			     newdoc 9 'sdom:document-element) 1))
		     (len (length elts)))
		(for-each (lambda (x)
			    (let ((xt (sdom:node-type x)))
			      (adopt-node! doc x xt) 
			      (insert-child! ent 6 x xt len)))
			  elts)
		ent)))
	   
	   (parse-dtd 
	    (lambda (p ents)
	      (letrec ((rt (lambda (p c lst)
			     (let ((c1 (read-char p)))
			       (cond ((eqv? c c1) lst)
				     ((eof-object? c1) 
				      (error "unexpected eof"))
				     (else (rt 
					    p c (append lst (list c1)))))))))
		(if (eof-object? (skip-until (list #\< '*eof*) p))
		    (list ents)
		    (begin
		      (unread-char #\< p)
		      (let ((tok (ssax:read-markup-token p)))
			(cond ((eq? (cdr tok) 'ENTITY)
			       (ssax:skip-S p)
			       (parse-dtd 
				p (cons (cons (ssax:read-NCName p)
					      (list->string 
					       (rt p 
						   (skip-until (list #\" #\') 
							       p) 
						   (list))))
					ents)))
			      (else (parse-dtd p ents))))))))))
    (let ((result
	   (reverse
	    ((ssax:make-parser
	      NEW-LEVEL-SEED 
	      (lambda (elem-gi attributes ns expected-content seed) '())
	      
	      FINISH-ELEMENT
	      (lambda (elem-gi attributes ns parent-seed seed)
		(let ((seed (ssax:reverse-collect-str-drop-ws seed))
		      (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) seed
				  (cons (cons '@ attrs) seed)))
			parent-seed)))
	      
	      CHAR-DATA-HANDLER
	      (lambda (string1 string2 seed)
		(if (string-null? string2) 
		    (cons string1 seed)
		    (cons* string2 string1 seed)))
	      
	      DOCTYPE
	      (lambda (port docname systemid internal-subset? seed)
		(let* ((s (if internal-subset?
			      (letrec 
				  ((f (lambda (y)
					(let ((z (read-char port)))
					  (if (and (eqv? (car (last-pair y)) 
							 #\]) 
						   (eqv? z #\>))
					      y
					      (f (append y (list z))))))))
				(list->string (f (list (read-char port)))))
			      '()))
		       (sdata (if (null? s)
				  '() 
				  (parse-dtd (open-input-string s) (list))))
		       (dtd (list '*DOCTYPE*)))
		  (if (list? systemid)
		      (begin
			(annotate! dtd 10 
				   (list 'sdom:public-id (car systemid)))
			(annotate! dtd 10
				   (list 'sdom:system-id (cdr systemid))))
		      (annotate! dtd 10 (list 'sdom:system-id systemid)))
		  (annotate!
		   dtd 10 (list 'sdom:name (symbol->string 
					    (if (pair? docname)
						(car docname)
						docname))))
		  (if (not (null? sdata))
		      (annotate! dtd 
				 10 
				 (list 'sdom:entities
				       (map (lambda (x)
					      (post-parse-entity seed x))
					    (car sdata)))))
		  (if (not (null? s)) 
		      (annotate! dtd 10 (list 'sdom:internal-subset s)))
		  (values 
		   #f (if (null? sdata) '() (car sdata)) ns (cons dtd seed))))
	      
	      UNDECL-ROOT
	      (lambda (elem-gi seed) (values #f '() ns seed))
	      
	      PI
	      ((*DEFAULT* .
			  (lambda (port pi-tag seed)
			    (cons (list '*PI* 
					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))))))

(define sdom:xml->sdom
  (lambda (port . extras)
    (let ((ns (if (not (null? extras)) (car extras) '()))
	  (parser (if (> (length extras) 1) (cadr extras) xml-parser)))
      (sdom:sxml->sdom (parser port ns)))))

(define sdom:sxml->sdom
  (lambda (sxml-tree)
    (letrec 
	((found-url-prefix #f)
	 (sdom-tree (copy-tree sxml-tree))	 
	 (tag-sibs!
	  (lambda (node-head parent-node pos)
	    (if (string? node-head)
		(begin 
		  (annotate! parent-node
			     (sdom:node-type parent-node)
			     `(,(pos-symbol pos)
			       (@ (sdom:sxml-representation ,node-head))))
		  (hashq-set! parent-node-hash node-head parent-node))
		(let ((type (sdom:node-type node-head))
		      (attr-fn (lambda (attr-item) 
				 (if (not (eq? (car attr-item) '@))
				     (tag-sibs! (append '(@) attr-item) 
						node-head 1))))
		      (string-fn (lambda (item)
				   (if (string? (car item))
				       (set-car! item 
						 (string-copy (car item))))))
		      (parent-fn (lambda () parent-node))
		      (counter 1))
		  (hashq-set! parent-node-hash 
			      (if (eqv? type sdom:node-type-attr)
				  (cdr node-head)
				  node-head)
			      parent-node)
		  (if (memv type `(,sdom:node-type-attr 
				   ,sdom:node-type-element))
		      (let* ((name (derive-name node-head type))
			     (p (get-prefix name))
			     (l (get-local-name name)))
			(if (not (null? p))
			    (let ((ns (sdom:lookup-namespace-uri node-head p))
				  (scope-ns (internal-lookup-scoped-namespace
					     node-head)))

			      ;; If the prefix has a slash or colon in it, it
			      ;; must have been resolved to a namespace URI
			      ;; beforehand by SXML, so we need to adapt the
			      ;; behavior of our parser for this document.

			      (if (and (not found-url-prefix)
				       (string-match extended-char-regex p))
				  (begin
				    (sdom:set-dom-config-parameter 
				     sdom-tree "sdom:resolve-new-prefixes" #t)
				    (set! found-url-prefix #t)))
				  
			      (if ns
				  (begin 
				    (annotate! node-head type
					       `(sdom:namespace-uri
						 ,ns))
				    (if (or (and (not ns)
						 (not scope-ns))
					    (not (equal? ns scope-ns)))
					(annotate! node-head
						   type
						   `(sdom:default-namespace 
						     ,ns))
					(if (eqv? type sdom:node-type-attr)
					    (set-car! (cdr node-head) 
						      (string->symbol l))
					    (set-car! node-head 
						      (string->symbol 
						       l)))))
				  (begin 
				    (annotate! node-head type 
					       `(sdom:namespace-uri ,p))
				    (if (eqv? type sdom:node-type-element)
					(begin (add-namespace node-head p p) 
					       (annotate! 
						node-head type
						`(sdom:default-namespace 
						  ,p))))))))))
		  (pair-for-each string-fn (cdr node-head))
		  (for-each (cond ((eqv? type sdom:node-type-element)
				   (lambda (item)
				     (if (and (list? item) 
					      (eq? (car item) '@))
					 (for-each attr-fn (cdr item))
					 (begin
					   (tag-sibs! item node-head counter)
					   (set! counter (+ counter 1))))))
				  ((eqv? type sdom:node-type-document)
				   (lambda (item)
				     (if (and (list? item)
					      (not (eq? (car item) '@)))
					 (begin 
					   (tag-sibs! item node-head counter)
					   (set! counter (+ counter 1))))))
				  ((eqv? type sdom:node-type-attr)
				   (lambda (item)
				     (if (not (and (list? item)
						   (eq? (car item) '@)))
					 (begin
					   (tag-sibs! item node-head counter)
					   (set! counter (+ counter 1))))))
				  (else (lambda (item) '())))
			    (cond ((eqv? type sdom:node-type-attr)
				   (cddr node-head))
				  (else (cdr node-head)))))))))
      (tag-sibs! sdom-tree #f 1)
      sdom-tree)))