  Parser for XML documents that contain XLink elements
;
; This software is in Public Domain.
  IT IS PROVIDED " AS IS " , WITHOUT WARRANTY OF ANY KIND .
;
; Please send bug reports and comments to:
            
;       Dmitry Lizorkin
;
  Returns an SXML presentation for a document plus additional information
  extracted from XLink markup ( described below )
;
; 'SSAX:XML->SXML+xlink' function is the core of the programme. This funcion
  is a modified    ' SSAX : XML->SXML ' function .
  ' SSAX : XML->SXML+xlink ' has a complicated seed which consists of ten elements :
   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
;                      locators+resources  arcs  declared-labels)
; 
  1 . mode = ' general , ' extended or ' none . They have the following meaning :
;  - 'general - there are no XLink elements among current element's ancestors.
; So, 'extended' or 'simple' elements are expected (others don't have any XLink
; semantical meaning)
;  - 'extended - for elements that are direct children of an extended link
; element, i.e. 'locator', 'resource' or 'arc'
;  - 'none - no XLink elements are expected niether in the current element
; nor in any of its descendants
;
  2 .  - arcs - contains information extracted from XLink elements .
;  sxlink-arcs = (list  sxlink-arc
;                          sxlink-arc
;                          ...)
;  sxlink-arc - as defined in the SXLink Specification
;
  3 . Reverse S - expression representation for XPointer ChildSeq for a currently
; processed element
   sxpointer : : = ( listof number )
  For example , ' ( 5 4 1 ) corresponds to " /1/4/5 "  
;
  4 . stack - a list of stack - elements . This list has the following semantics :
; - new stack-element is added when the beginning of each element is processed
; - the stack-element is consumed at the finish-element (of the same element)
;  stack = (list  stack-element
;                 stack-element
;                 ...)
;  stack-element = (list  position  xlink-values)
;  position - a position within a file
   xlink - values = ( list   type   href   role   arcrole   show   actuate   label   from   to )
; where, for example, 'type' is the value of xlink:type attribute or #f if 
; there is no such attribute
;
; The other parameters of the seed are presented when an extended link is
; processed
;
  5 . locators+resources - locator and resource elements defined within an
; extended link. They are temporarily stored in this parameter. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  locators+resources = (list  locator-or-resource
;                              locator-or-resource
;                              ...)
;  locator-or-resource = (list  uri  fragment  role  label
;                               position  element)
;  label - a string representing the value of xlink:label attribute, or #f if
; this attribute was omitted 
;
  6 . arcs - information about arce defined within an extended link . This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  arcs = (list  arc-info
;                arc-info
;                ...)
   arc - info = ( list   arcrole   show   actuate   from   to
;                    position  element)
;  from - a string representing the value of xlink:from attribute, or #f if
; this attribute was omitted 
;  to - the same for an xlink:to attribute
;
  7 . declared - labels - labels declared within an extended link . This parameter
; is used for constraint checking
;  declared-labels = (list  label  label ...)
;  label - a string

; Some global constants
(define xlink:namespace-uri ')
(define xlink:linkbase-uri "")

;=========================================================================
; A 'seed' datatype
   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
;                      locators+resources  arcs  declared-labels)
  The last three parameters are optional . See a head comment for details

;------------------------------------------------
  Two constructors for a seed
; They are introducted in order to control (possible) future modifications of
; a 'seed' list

  This function constructs a seed consisting only of six compulsory elements
(define (xlink:make-small-seed mode sxlink-arcs sxpointer stack)
  (list mode sxlink-arcs sxpointer stack))

; The similar function which makes a full-length seed
(define (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)
  (list mode sxlink-arcs sxpointer stack
        locators+resources arcs declared-labels))

;------------------------------------------------
  Accessor functions

(define (xlink:seed-mode seed)
  (car seed))
(define (xlink:seed-sxlink-arcs seed)
  (cadr seed))
(define (xlink:seed-sxpointer seed)
  (list-ref seed 2))
(define (xlink:seed-stack seed)
  (list-ref seed 3))

  We assume that the seed has the full length for the latter four functions
(define (xlink:seed-locators+resources seed)
  (list-ref seed 4))
(define (xlink:seed-arcs seed)
  (list-ref seed 5))
(define (xlink:seed-declared-labels seed)
  (list-ref seed 6))


;=========================================================================
; Here basic functions for special datatypes are collected

;------------------------------------------------
  2 . ' sxlink - arcs ' datatype

; Adds the arc defined by the XLink simple link to 'sxlink-arcs'
(define (xlink:add-simple
         xlink-values element position sxpointer sxlink-arcs)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values)))
    (if
     (not href)   ; the link is untraversable
     sxlink-arcs  ; no arc added
     (call-with-values
      (lambda ()
        (let ((lst (string-split href (list #\#) 2)))
          (cond
            ((= (length lst) 1)  ; no XPointer fragment identifier
             (values (car lst) #f))
            ((= (string-length (car lst)) 0)  ; addresses the same document
             (values #f (cadr lst)))
            (else
             (values (car lst) (cadr lst))))))
      (lambda (uri-ending fragment)
        (cons
         `(,(if (equal? arcrole xlink:linkbase-uri)
                'linkbase 'simple)
           (from
            (uri)  ; goes from this document
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer)))
           (to
            (uri ,@(if uri-ending (list uri-ending) '()))
            ,@(if fragment `((xpointer ,fragment)) '())
            ,@(if role `((role ,role)) '())
            ,@(if title `((title ,title)) '()))
           ,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())
           (declaration
            (uri)  ; in this document
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer))
            (position ,position)))
         sxlink-arcs))))))

; This function appends information to 'sxlink-arcs' according to
; 'locators+resources' and 'arcs' parameters.
; The function is called at the end-tag of an extended link element.
(define (xlink:add-extended
         locators+resources arcs sxlink-arcs declaration)
  (let (; like map, but applies the function to each pair of the arguments
        (map-join
         (lambda (func arg-lst1 arg-lst2)
           (let ((arg-lst1 (reverse arg-lst1)))
             (let iterate-second ((lst2 (reverse arg-lst2))
                                  (res '()))
               (if
                (null? lst2)  ; everyone processed
                res
                (let iterate-first ((lst1 arg-lst1)
                                    (res res))
                  (if
                   (null? lst1)  ; the iteration loop finished
                   (iterate-second (cdr lst2) res)
                   (iterate-first
                    (cdr lst1)
                    (cons (func (car lst1) (car lst2)) res)))))))))
        ; a stub for determining whether a locator-or-resouces is a local
  or remote one
        (resource?
         (lambda (locator-or-resource)
  Resource iff info contains subelement ' nodes
           (assq 'nodes (xlink:resource-data locator-or-resource)))))    
    (let loop ((arcs arcs)
               (sxlink-arcs sxlink-arcs))
      (if
       (null? arcs)  ; all arcs processed
       sxlink-arcs
       (loop
        (cdr arcs)
        (let ((arc-info (car arcs)))
          (append
           (map-join
            (lambda (starting ending)
              `(,(cond  ; determining arc name
                   ((xlink:arc-info-linkbase arc-info)                    
                    'linkbase)
                   ((and (resource? starting)
                         (not (resource? ending)))
                    'outbound)
                   ((and (not (resource? starting))
                         (resource? ending))
                    'inbound)
                   ((and (resource? starting) (resource? ending))
                    'local-to-local)
                   (else
                    'third-party))
                (from ,@(xlink:resource-data starting))
                (to ,@(xlink:resource-data ending))
                ,@(xlink:arc-info-data arc-info)
                ,declaration))
            (let ((from (xlink:arc-info-from arc-info)))
              (if
               (not from)  ; arc outgoes from every resource
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? from
                          (xlink:resource-label locator-or-resource)))
                locators+resources)))
            (let ((to (xlink:arc-info-to arc-info)))
              (if
               (not to)  ; arc comes to every resource
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? to
                          (xlink:resource-label locator-or-resource)))
                locators+resources))))
           sxlink-arcs)))))))

;------------------------------------------------
  3 . ' sxpointer ' datatype
; Reverse S-expression representation for XPointer ChildSeq for a currently
; processed element
   sxpointer : : = ( listof number )
  For example , ' ( 5 4 1 ) corresponds to " /1/4/5 "  

(define (xlink:sxpointer->childseq sxpointer)
  (apply
   string-append
   (map
    (lambda (num) (string-append "/" (number->string num)))
    (reverse sxpointer))))

; Forms sxpointer for the following sibling element of the current element
(define (xlink:sxpointer4sibling sxpointer)
  (cons (+ 1 (car sxpointer)) (cdr sxpointer)))

;------------------------------------------------
  5 . ' locators+resources ' datatype
; locators+resources - locator and resource elements defined within an
; extended link. They are temporarily stored in this parameter. This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  locators+resources = (list  locator-or-resource
;                              locator-or-resource
;                              ...)
;  locator-or-resource = (list  label  resource-data)
;  resource-data - whatever required to describe the resource in terms of
; the SXLink Specification

  Constructor
(define (xlink:make-locator-or-resource label resource-info)
  (list label resource-info))

  Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:resource-label locator-or-resource)
  (car locator-or-resource))
(define (xlink:resource-data locator-or-resource)
  (cadr locator-or-resource))

  If the following XLink constraint is fulfilled , adds information about the
  XLink locator element to ' locators+resources ' . Otherwise , displays an error
; message and doesn't add anything.
;  Constraint: Attributes on Locator Element
   The locator - type element must have the locator attribute ( see 5.4 Locator
;  Attribute (href)). The locator attribute (href) must have a value supplied.
(define (xlink:add-locator xlink-values position element locators+resources)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (title (xlink:values-title xlink-values))
        (label (xlink:values-label xlink-values)))
    (cond
      ((not href)
       (xlink:parser-error
        position "locator element doesn't have an xlink:href attribute")
       locators+resources)
      (else
       (let ((lst (string-split href (list #\#) 2)))
         (call-with-values
          (lambda ()
            (cond
              ((= (length lst) 1) (values (car lst) #f))
              ((= (string-length (car lst)) 0) (values #f (cadr lst)))
              (else (values (car lst) (cadr lst)))))
          (lambda (uri fragment)
            (cons
             (xlink:make-locator-or-resource
              label
              `((uri ,@(if uri (list uri) '()))
                ,@(if fragment `((xpointer ,fragment)) '())
                ,@(if role `((role ,role)) '())
                ,@(if title `((title ,title)) '())))
             locators+resources))))))))

; Adds information concerning XLink resource element to 'locators+resources'
(define (xlink:add-resource xlink-values element sxpointer locators+resources)
  (let ((role (xlink:values-role xlink-values))
        (label (xlink:values-label xlink-values))
        (title (xlink:values-title xlink-values)))
    (cons
     (xlink:make-locator-or-resource
      label
      `((uri)
        (nodes ,element)
        (xpointer ,(xlink:sxpointer->childseq sxpointer))
        ,@(if role `((role ,role)) '())
        ,@(if title `((title ,title)) '())))
     locators+resources)))

;------------------------------------------------
  6 . ' arcs ' datatype
  arcs - information about arce defined within an extended link . This info
; is converted into an 'sxlink-arcs' parameter when the end-tag for an
; extended link element is encountered
;  arcs = (list  arc-info
;                arc-info
;                ...)
;  arc-info = (list  from  to  linkbase  position  data)
;  linkbase - a boolean: whether a linkbase arc
   arc - data - whatever required to describe the arc in terms of the SXLink
  Specification

  Constructor
(define (xlink:make-arc-info from to linkbase position data)
  (list from to linkbase position data))

  Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:arc-info-from arc-info)
  (car arc-info))
(define (xlink:arc-info-to arc-info)
  (cadr arc-info))
(define (xlink:arc-info-linkbase arc-info)
  (list-ref arc-info 2))
(define (xlink:arc-info-position arc-info)
  (list-ref arc-info 3))
(define (xlink:arc-info-data arc-info)
  (list-ref arc-info 4))

; Adds arc information to 'arcs' datatype. A side effect - checks the following
  XLink constraint :
;  Constraint: No Arc Duplication
;  Each arc-type element must have a pair of from and to xlink-values that does
;  not  repeat the from and to xlink-values (respectively) for any other
;  arc-type element in the same extended link; that is, each pair in a link
;  must be unique.
(define (xlink:add-arc xlink-values position element arcs)
  (let ((arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values))
        (from (xlink:values-from xlink-values))
        (to (xlink:values-to xlink-values)))
    (let loop ((as arcs))
      (if
       (null? as)
       (cons
        (xlink:make-arc-info
         from to
         (equal? arcrole xlink:linkbase-uri)
         position
         `(,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if title `((title ,title)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())))
        arcs)
       (let ((from2 (xlink:arc-info-from (car as)))
             (to2 (xlink:arc-info-to (car as))))
         (when
             (and (or (not from) (not from2) (equal? from from2))
                  (or (not to) (not to2) (equal? to to2)))
           (xlink:parser-error position "duplicate arcs - xlink:from"
                        (if from (string-append "=" from) " - omitted")
                        ", xlink:to"
                        (if to (string-append "=" to) " - omitted")))
         (loop (cdr as)))))))

  XLink specification , 5.1.3 :
;  If no arc-type elements are provided in an extended link, then by extension
;  the missing from and to xlink-values are interpreted as standing for all the
;  labels in that link.
; Inserts such a default arc if 'arcs' are empty
(define (xlink:add-default-arc element arcs)
  (if (null? arcs)
      (list (xlink:make-arc-info
             #f #f #f
             0  ; position is dummy here, since it will never be used
  none of the attributes arcrole , title , show , actuate
             ))
      arcs))

;------------------------------------------------
  7 . ' declared - labels ' datatype
; declared-labels - labels declared within an extended link. This parameter
; is used for constraint checking
;  declared-labels = (list  label  label ...)
;  label - a string

; If an xlink:label attribute is presented in 'xlink-values', it's value is added
; to 'declared-labels'. Otherwise, 'declared-labels' remain unchainged
(define (xlink:add-declared-label xlink-values declared-labels)
  (let((label (xlink:values-label xlink-values)))
    (if(not label)
       declared-labels
       (cons label declared-labels))))

  The function checks the following XLink constraint
   Constraint : label , from , and to xlink - values
;  The value of a label, from, or to attribute must be an NCName. If a value 
;  is supplied for a from or to attribute, it must correspond to the same value
;  for some label attribute on a locator- or resource-type element that appears
;  as a direct child inside the same extended-type element as does the arc-type 
;  element. 
; Error message is displayed if some label was undeclared.
  The function always returns # t.
; It is called at the end-tag of an extended link element
(define (xlink:all-labels-declared arcs declared-labels)
  (let loop ((arcs arcs))
    (if
     (null? arcs)
     #t
     (let((arc-info (car arcs)))
       (let((from (xlink:arc-info-from arc-info))
            (to (xlink:arc-info-to arc-info))
            (position (xlink:arc-info-position arc-info)))       
         (when (and from (not (member from declared-labels)))
           (xlink:parser-error position "label not defined - xlink:from=" from))
         (when (and to (not (member to declared-labels)))
           (xlink:parser-error position "label not defined - xlink:to=" to))
         (loop (cdr arcs)))))))


;=========================================================================
; Some simple functions working with attributes
;  xlink-values = (list
                    type href role arcrole title show actuate label from to )

;------------------------------------------------
; Trivial constructor and accessor functions
; These functions are used as a level of abstraction

  Constructs a datatype ( just a list in a current implementation ) which
; contains xlink-values of all xlink-related attributes. For example, 'type'
; is the value of xlink:type attribute or #f if there is no such attribute.
; This datatype will be called 'xlink-values' in the latter text
(define (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
  (list type href role arcrole title show actuate label from to))

  Accessors
; NOTE: We don't apply teta-reduction for the sake of easier bug detection
(define (xlink:values-type xlink-values)
  (car xlink-values))
(define (xlink:values-href xlink-values)
  (cadr xlink-values))
(define (xlink:values-role xlink-values)
  (list-ref xlink-values 2))
(define (xlink:values-arcrole xlink-values)
  (list-ref xlink-values 3))
(define (xlink:values-title xlink-values)
  (list-ref xlink-values 4))
(define (xlink:values-show xlink-values)
  (list-ref xlink-values 5))
(define (xlink:values-actuate xlink-values)
  (list-ref xlink-values 6))
(define (xlink:values-label xlink-values)
  (list-ref xlink-values 7))
(define (xlink:values-from xlink-values)
  (list-ref xlink-values 8))
(define (xlink:values-to xlink-values)
  (list-ref xlink-values 9))

;------------------------------------------------
; Functions which read attributes

; The function is given a list called 'attributes' (in SSAX parser). This list
; has the form
;  attributes = (list  attribute  
;                      attribute
;                      ...)
;  attribute = (cons  (cons  namespace-prefix  attribute-name)
;                     attribute-value )
;           or (cons  attribute-name  attribute-value )
;  namespaces - defined in "ssax.scm"
  reads XLink attributes ' values and returns a ' xlink - values ' datatype
; (the result of 'xlink:construct-xlink-values' function)
(define (xlink:read-attributes attributes namespaces)
  (let loop ((attributes attributes)
             (type #f) (href #f) (role #f) (arcrole #f) (title #f) (show #f)
             (actuate #f) (label #f) (from #f) (to #f))
    (if(null? attributes)  ; the attribute list is over
       (xlink:construct-xlink-values
        type href role arcrole title show actuate label from to)
       (let ((attribute (car attributes)))                  
         (if
          (not (pair? (car attribute)))  ; attribute doesn't have namespace
          (loop (cdr attributes) 
                type href role arcrole title show actuate label from to)
          (let ((namespace-prefix (caar attribute))
                (attribute-name (cdar attribute))
                (attribute-value (cdr attribute)))
            (let ((namespace-uri
                   (let rpt ((ns namespaces))
                     (cond
                       ((null? ns) namespace-prefix)
                       ((equal? (cadar ns) namespace-prefix) (cddar ns))
                       (else (rpt (cdr ns)))))))
              (if
               (not (equal? namespace-uri xlink:namespace-uri))
               (loop (cdr attributes)
                     type href role arcrole title show actuate label from to)
               (case attribute-name
                 ((type) (loop (cdr attributes) attribute-value href role 
                               arcrole title show actuate label from to))
                 ((href) (loop (cdr attributes) type attribute-value role
                               arcrole title show actuate label from to))
                 ((role) (loop (cdr attributes) type href attribute-value 
                               arcrole title show actuate label from to))
                 ((arcrole)
                  (loop (cdr attributes) type href role attribute-value title
                        show actuate label from to))
                 ((title) (loop (cdr attributes) type href role arcrole
                                attribute-value show actuate label from to))
                 ((show) (loop (cdr attributes) type href role arcrole title
                               attribute-value actuate label from to))
                 ((actuate) (loop (cdr attributes) type href role arcrole
                                  title show attribute-value label from to))
                 ((label) (loop (cdr attributes) type href role arcrole title
                                show actuate attribute-value from to))
                 ((from) (loop (cdr attributes) type href role arcrole title
                               show actuate label attribute-value to))
                 ((to) (loop (cdr attributes) type href role arcrole title
                             show actuate label from attribute-value))
                 (else (loop (cdr attributes) type href role arcrole title
                             show actuate label from to)))))))))))

  Reads SXML element 's attributes
   element - an SXML node representing an element
;  ns-prefixes = (list  (list  prefix  namespace-uri)
;                       (list  prefix  namespace-uri)
;                       ...)
;  prefix - a symbol
;  namespace-uri - a string
; An 'xlink-values' datatype is returned
(define (xlink:read-SXML-attributes element ns-prefixes)
  (let ((attr-node ((select-kids (ntype?? '@)) element)))
    (if
     (null? attr-node)  ; no attributes
     (xlink:construct-xlink-values #f #f #f #f #f #f #f #f #f #f)
     (let loop ((attr-list (cdar attr-node))
                (type #f) (href #f) (role #f) (arcrole #f) (title #f)
                (show #f) (actuate #f) (label #f) (from #f) (to #f))
       (if
        (null? attr-list)
        (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
        (let ((attribute-name (symbol->string (caar attr-list)))
              (attribute-value (cadar attr-list)))
          (call-with-values
           (lambda ()
             (cond
               ((string-rindex attribute-name #\:)
                => (lambda (pos)
                     (values
                      (string->symbol (substring attribute-name 0 pos))
                      (string->symbol
                       (substring attribute-name (+ pos 1)
                                  (string-length attribute-name))))))
               (else
                (values #f attribute-name))))
           (lambda (prefix local)
             (if
              (not prefix)   ; this is a non-qualified name
              (loop (cdr attr-list)
                    type href role arcrole title show actuate label from to)
              (let ((namespace-uri
                     (cond
                       ((assoc prefix ns-prefixes)
                        => (lambda (pair)
                             (string->symbol (cadr pair))))
                       (else
                        prefix))))
                (if
                 (not (equal? namespace-uri xlink:namespace-uri))
                 (loop (cdr attr-list)
                       type href role arcrole title show actuate label from to)
                 (case local
                   ((type) (loop (cdr attr-list) attribute-value href role 
                                 arcrole title show actuate label from to))
                   ((href) (loop (cdr attr-list) type attribute-value role
                                 arcrole title show actuate label from to))
                   ((role) (loop (cdr attr-list) type href attribute-value
                                 arcrole title show actuate label from to))
                   ((arcrole)
                    (loop (cdr attr-list) type href role attribute-value title
                          show actuate label from to))
                   ((title) (loop (cdr attr-list) type href role arcrole
                                  attribute-value show actuate label from to))
                   ((show) (loop (cdr attr-list) type href role arcrole title
                                 attribute-value actuate label from to))
                   ((actuate) (loop (cdr attr-list) type href role arcrole title
                                    show attribute-value label from to))
                   ((label) (loop (cdr attr-list) type href role arcrole title
                                  show actuate attribute-value from to))
                   ((from) (loop (cdr attr-list) type href role arcrole title
                                 show actuate label attribute-value to))
                   ((to) (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from attribute-value))
                   (else (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from to))))))))))))))

;------------------------------------------------
; These functions check XLink constrains which limit some attributes' xlink-values

  A helper function which is used by the next one
;  value - a value of an attribute (#f if there is no such attribute)
;  valid-xlink-values - a list of xlink-values which are allowed for this attribute
;  attr-name - a string denotating a name of an attribute (for a message)
;  position - position within a file
  Function always returns # t.
; Side effects: function "cerr"s a message if 'value' is not #f and not within
; 'valid-xlink-values'
(define (xlink:check-helper value valid-xlink-values attr-name position)
  (cond
    ((not value) )  ; a value is #f - a correct situation
    ((not (member value valid-xlink-values))
     (xlink:parser-error position "unexpected attribute value - " 
                  attr-name "=" value))
    (else #t)))

   xlink - values = ( type href role arcrole show actuate label from to )
; where, for example, 'type' is the value of xlink:type attribute or #f if 
; there is no such attribute (this datatype is a result 
; of 'read-xlink-attributes' function)
;  position - position within a file
;
  The function checks the three similar XLink constraints :
   1 . Constraint : type Value
;  The value of the type attribute must be supplied. The value must be one of
;  "simple", "extended", "locator", "arc", "resource", "title", or "none".
   2 . Constraint : show Value
;  If a value is supplied for a show attribute, it must be one of the xlink-values
;  "new", "replace", "embed", "other", and "none".
   3 . Constraint : actuate Value
   If a value is supplied for an actuate attribute , it must be be one of the
;  xlink-values "onLoad", "onRequest", "other", and "none".
; 
; The result is always #t
; Side effects - error messages (printed by
; an 'xlink:check-helper' function above)
(define (xlink:check-type-show-actuate-constraints xlink-values position)
  (xlink:check-helper (xlink:values-type xlink-values)
                      '("simple" "extended" "locator" "arc" "resource"
                        "title" "none")
                      "xlink:type"
                      position)
  (xlink:check-helper (xlink:values-show xlink-values)
                      '("new" "replace" "embed" "other" "none")
                      "xlink:show"
                      position)
  (xlink:check-helper (xlink:values-actuate xlink-values)
                      '("onLoad" "onRequest" "other" "none")
                      "xlink:actuate"
                      position))
    

;=========================================================================
; Functions which perform starting and ending actions for XLink elements
; All these functions have the same signature:
;
; (smth-start position xlink-values xlink:seed)
;  position - position within a file
   xlink - values = ( list   type   href   role   arcrole   show   actuate   label   from   to )
; where, for example, 'type' is the value of xlink:type attribute or #f if 
; there is no such attribute
   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
;                      locators+resources  arcs  declared-labels)
; See a head comment for details
;
; (smth-end xlink:parent-seed xlink:seed element)
  element - the SXML presentation of the current element
;
; All the functions return a new 'xlink:seed'

;------------------------------------------------
; A general element
; It is the element which doesn't have any XLink meaning, but its descendants
; might have such a meaning

(define (xlink:general-start position xlink-values seed)
  (let((sxlink-arcs (xlink:seed-sxlink-arcs seed))       
       (sxpointer (xlink:seed-sxpointer seed))
       (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed
     'general sxlink-arcs (cons 1 sxpointer) stack)))

(define (xlink:general-end parent-seed seed element)
  (let ((mode (xlink:seed-mode parent-seed))
        (sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
        (stack (xlink:seed-stack parent-seed)))
    (xlink:make-small-seed mode sxlink-arcs sxpointer stack)))

;------------------------------------------------
; An element and all its descendants don't have any XLink meaning

(define (xlink:none-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:none-end parent-seed seed element)
  parent-seed)
  
;------------------------------------------------
; A simple-link element

(define (xlink:simple-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:simple-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:add-simple 
                             xlink-values element position
                             (xlink:seed-sxpointer parent-seed)
                             (xlink:seed-sxlink-arcs parent-seed)))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed)))
        (xlink:make-small-seed
         mode sxlink-arcs sxpointer stack)))))          

;------------------------------------------------
; An extended-link element

(define (xlink:extended-start position xlink-values seed)
  (let ((sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer (cons 1 (xlink:seed-sxpointer seed)))
        (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-full-seed 'extended sxlink-arcs sxpointer stack
                          '() '() '())))

(define (xlink:extended-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((locators+resources (xlink:seed-locators+resources seed))
            (arcs (xlink:add-default-arc element (xlink:seed-arcs seed)))
            (declared-labels (xlink:seed-declared-labels seed)))           
        (xlink:all-labels-declared arcs declared-labels)      
        (let ((mode (xlink:seed-mode parent-seed))
              (sxlink-arcs
               (xlink:add-extended
                locators+resources arcs (xlink:seed-sxlink-arcs seed)
                `(declaration
                  (uri)  ; declared in this document
                  (nodes ,element)
                  (xpointer ,(xlink:sxpointer->childseq
                              (xlink:seed-sxpointer parent-seed)))
                  (position ,position))))
              (sxpointer
               (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
              (stack (xlink:seed-stack parent-seed)))
          (xlink:make-small-seed mode sxlink-arcs sxpointer stack))))))

;------------------------------------------------
; A locator element

(define (xlink:locator-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))  

(define (xlink:locator-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources 
             (xlink:add-locator xlink-values position element
                                (xlink:seed-locators+resources parent-seed)))
            (arcs (xlink:seed-arcs parent-seed))
            (declared-labels 
             (xlink:add-declared-label 
              xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))

;------------------------------------------------
; A resource element

(define (xlink:resource-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:resource-end parent-seed seed element)
  (let((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let* ((mode (xlink:seed-mode parent-seed))
             (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
             (sxpointer
              (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
             (stack (xlink:seed-stack parent-seed))
             (locators+resources 
              (xlink:add-resource xlink-values element sxpointer
                                  (xlink:seed-locators+resources parent-seed)))
             (arcs (xlink:seed-arcs parent-seed))
             (declared-labels
              (xlink:add-declared-label
               xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))

;------------------------------------------------
; An arc element

(define (xlink:arc-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:arc-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources (xlink:seed-locators+resources parent-seed))           
            (arcs (xlink:add-arc xlink-values position element
                                 (xlink:seed-arcs parent-seed)))
            (declared-labels
             (xlink:seed-declared-labels parent-seed)))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))


;=========================================================================
; Miscellaneous utility functions

;------------------------------------------------
; Functions dealing with position

; Returns posiotion of a port
; NOTE: Specific for different Scheme implementations
(define (xlink:get-port-position port)
  (cond-expand         
   (bigloo
    (string-append "position " (number->string (input-port-position port))))
   (chicken
    (string-append
     "line " (number->string (receive (row col) (port-position port) row))))
   (gambit
    ; DL: was
    ;(string-append "line " (number->string (port-input-line-count port)))
    (string-append "position "
                   (number->string (input-port-byte-position port))))
   (guile
    (string-append "line " (number->string (port-line port))))
   (plt
    (string-append "position " (number->string (file-position port))))
   (else "unknown")))

; This function displays an error message. #t is returned
;  position - position within a file
;  text - a message to display
(define (xlink:parser-error position . text)
  (apply
   cerr
   (if
    (string=? position "unknown")
    (append (list nl "XLink error:" nl) text (list nl))
    (append (list nl "XLink error in " position ":" nl) text (list nl)))))

;------------------------------------------------
  Functions working on branches of an SXML tree

; Helper is used by the following functions in this section
;  action-on-branch ::= (lambda (elem content-nodeset) ...)
;  elem - SXML element that corresponds to the branch
;  content-nodeset - new content
; The lambda should return the new elem
(define (xlink:branch-helper action-on-branch)
  (lambda (document branch-lpath content-nodeset)
    (letrec
  Constructs a new branch if it does n't exist in a document
         (make-new-branch
          (lambda (lpath)
            (if (null? (cdr lpath))  ; lpath consists of a single member
                (cons (car lpath) content-nodeset)
                (list (car lpath) (make-new-branch (cdr lpath))))))
         ; Walks a document
         (tree-walk
          (lambda (elem lpath)
            (if
             (null? lpath)  ; we have reached the desired node
             (action-on-branch elem content-nodeset)
             (let loop ((foll-siblings elem)
                        (prec-siblings '()))
               (cond
                 ((null? foll-siblings)  ; no such branch
                  (cons*
                   (car elem)
                   (make-new-branch lpath)
                   (cdr elem)))
                 ((and (pair? (car foll-siblings))
                       (eq? (caar foll-siblings) (car lpath)))
                  ; match found
                  (append
                   (reverse prec-siblings)
                   (list
                    (tree-walk (car foll-siblings) (cdr lpath)))
                   (cdr foll-siblings)))
                 (else
                  (loop (cdr foll-siblings)
                        (cons (car foll-siblings) prec-siblings)))))))))
      (tree-walk document branch-lpath))))

; Replaces the content of the branch with a new content
;  document - SXML document
   branch - lpath : : = ( listof symbol )
;  branch-lpath - is like an sxpath location path. There must be no more than
  one branch in an SXML tree with this location path . If this branch does n't
  exist , it will be created as the first branch in a document
   content - nodeset : : = ( listof node )
;  content-nodeset - defines the content of the branch
(define xlink:replace-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (cons (car elem) content-nodeset))))

; Appends 'content-nodeset' to the content of the given branch
(define xlink:append-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (append elem content-nodeset))))

;------------------------------------------------
  Processing the document URI
; (borrowed from "xlink.scm")

  Given a document , returns its URI ( a string )
; #f is returned if there is no "@@/uri" subtree in the document
(define (xlink:get-uri doc)
  (let ((nodeset ((select-kids (ntype?? 'uri))
                  ((select-kids (ntype?? '@@)) doc))))
    (if (null? nodeset)  ; there is no "@@/uri" subtree
        #f
        (cadar nodeset))))

; Adds the URI of the document where the arcs were declared, to sxlink-arcs
; Returns modified sxlink-arcs
(define (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
  (letrec
      ((process-arc
  uri - alist : : = ( listof ( cons uri resolved - uri ) )
  association between the URI and the corresponding resolved one
        ; Returns: (values new-node new-uri-alist)
        (lambda (node uri-alist)
  a node is always an SXML element
            ((linkbase simple inbound outbound third-party local-to-local
              from to declaration)
             ; Recursive application to children
             (call-with-values
              (lambda () (process-nodeset (cdr node) uri-alist))
              (lambda (new-children new-uri-alist)
                (values (cons (car node) new-children)
                        new-uri-alist))))
            ((uri)
             (cond
  no URI is set
                (values `(uri ,uri) uri-alist))
               ((assoc (cadr node) uri-alist)
                => (lambda (pair)
                     (values `(uri ,(cdr pair)) uri-alist)))
               (else
                (let ((resolved-uri
                       (ar:resolve-uri-according-base uri (cadr node))))
                  (values `(uri ,resolved-uri)
                          (cons
                           (cons (cadr node) resolved-uri)
                           uri-alist))))))
            (else
             (values node uri-alist)))))
       ; Applies the previous function to a nodeset
       (process-nodeset
        (lambda (nodeset uri-alist)
          (let loop ((nset nodeset)
                     (res '())
                     (uri-alist uri-alist))
            (if
             (null? nset)
             (values (reverse res) uri-alist)
             (call-with-values
              (lambda () (process-arc (car nset) uri-alist))
              (lambda (new-node new-uri-alist)
                (loop (cdr nset)
                      (cons new-node res)
                      new-uri-alist))))))))
    (call-with-values
     (lambda () (process-nodeset sxlink-arcs '()))
     (lambda (new-sxlink-arcs dummy)
       new-sxlink-arcs))))
                 

;=========================================================================
  Core features of the parser

;------------------------------------------------
  Handler units for SSAX multi - parser
              
; This function is called by the NEW-LEVEL-SEED handler
; A new 'xlink:seed' is returned
(define (xlink:new-level-seed-handler port attributes namespaces seed)
  (let ((position (xlink:get-port-position port))
        (xlink-values (xlink:read-attributes attributes namespaces)))
    (xlink:check-type-show-actuate-constraints xlink-values position)
    (let((mode (xlink:seed-mode seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-start position xlink-values seed))
           ((extended) (xlink:extended-start position xlink-values seed))
           ((none) (xlink:none-start position xlink-values seed))
           (else (xlink:general-start position xlink-values seed))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-start position xlink-values seed))
           ((resource) (xlink:resource-start position xlink-values seed))
           ((arc) (xlink:arc-start position xlink-values seed))
           (else (xlink:none-start position xlink-values seed))))
        ((none) (xlink:none-start position xlink-values seed))
        (else 
         (xlink:parser-error position "internal processor error - mode=" 
                      mode)
         (xlink:none-start position xlink-values seed))))))
  
; This function is called by the FINISH-ELEMENT handler
; A new 'xlink:seed' is returned
(define (xlink:finish-element-handler parent-seed seed element)
  (let((xlink-values (cadar (xlink:seed-stack seed))))
    (let((mode (xlink:seed-mode parent-seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-end parent-seed seed element))
           ((extended) (xlink:extended-end parent-seed 
                                           seed element))
           ((none) (xlink:none-end parent-seed seed element))
           (else (xlink:general-end parent-seed seed element))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-end parent-seed 
                                         seed element))
           ((resource) (xlink:resource-end parent-seed 
                                           seed element))
           ((arc) (xlink:arc-end parent-seed seed element))
           (else (xlink:none-end parent-seed seed element))))
        ((none) (xlink:none-end parent-seed seed element))
        (else 
         (xlink:parser-error 0 "internal processor error - mode=" 
                      mode)
         (xlink:none-end parent-seed seed element))))))

; Constructs the member of an axuiliary list
(define (xlink:ending-action xlink:seed)
  (let ((sxlink-arcs (reverse (xlink:seed-sxlink-arcs xlink:seed))))    
    `(sxlink
      (declared-here ,@sxlink-arcs))))

;-------------------------------------------------
  The function which adds XLink - related information to the SXML document

   document - an SXML document
; The function emulates a 'fold-ts' operation.
  A new SXML document is returned . It contains an auxiliary list with an
; 'sxlink' subtree. If the source document already contains such a
; subtree, it will be replaced. Other subtrees in an auxiliary list will
; remain unchanged.
(define (SXML->SXML+xlink document)
  (letrec
      ((fold-ts
        (lambda (node ns-prefixes seed)
          (let ((xlink-values (xlink:read-SXML-attributes node ns-prefixes)))
            (let ((mode (xlink:seed-mode seed))
                  (type (xlink:values-type xlink-values))
                  (pos "unknown"))
              (let rpt
                ((kids ((select-kids (ntype?? '*)) node))
                 (new-seed
                  (case mode
                    ((general)
                     (case (if type (string->symbol type) type)
                       ((simple)
                        (xlink:simple-start pos xlink-values seed))
                       ((extended)
                        (xlink:extended-start pos xlink-values seed))
                       ((none)
                        (xlink:none-start pos xlink-values seed))
                       (else
                        (xlink:general-start pos xlink-values seed))))
                    ((extended)
                     (case (if type (string->symbol type) type)
                       ((locator)
                        (xlink:locator-start pos xlink-values seed))
                       ((resource)
                        (xlink:resource-start pos xlink-values seed))
                       ((arc)
                        (xlink:arc-start pos xlink-values seed))
                       (else
                        (xlink:none-start pos xlink-values seed))))
                    ((none)
                     (xlink:none-start pos xlink-values seed))
                    (else
                     (xlink:parser-error pos "internal processor error - mode=" mode)
                     (xlink:none-start pos xlink-values seed)))))
                (if
                 (not (null? kids))
                 (rpt (cdr kids)
                      (fold-ts (car kids) ns-prefixes new-seed))
                 (case mode
                   ((general)
                    (case (if type (string->symbol type) type)
                      ((simple) (xlink:simple-end seed new-seed node))
                      ((extended) (xlink:extended-end seed new-seed node))
                      ((none) (xlink:none-end seed new-seed node))
                      (else (xlink:general-end seed new-seed node))))
                   ((extended)
                    (case (if type (string->symbol type) type)
                      ((locator) (xlink:locator-end seed new-seed node))
                      ((resource) (xlink:resource-end seed new-seed node))
                      ((arc) (xlink:arc-end seed new-seed node))
                      (else (xlink:none-end seed new-seed node))))
                   ((none) (xlink:none-end seed new-seed node))
                   (else
                    (xlink:parser-error pos
                     "internal processor error - mode=" mode)
                    (xlink:none-end seed new-seed node))))))))))
  (let* ((ns-prefixes
          (let ((ns-node ((select-kids (ntype?? '*NAMESPACES*))
                          ((select-kids (ntype?? '@@)) document))))
            (if (null? ns-node)
                '()
                (cdar ns-node))))
         (sxlink-arcs
          (xlink:seed-sxlink-arcs
           (fold-ts ((select-kids (ntype?? '*)) document)
                    ns-prefixes
                    (xlink:make-small-seed 'general '() '(1) '()))))
         (uri (xlink:get-uri document)))
    (xlink:append-branch
     document
     '(@@ sxlink declared-here)
     (if uri  ; URI for the document supplied
         (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
         sxlink-arcs)))))

;-------------------------------------------------
  Adds SXLink arc information to SHTML document

(define (SHTML->SHTML+xlink document)
  (letrec
      ((tree-walk
  Returns (     )
        (lambda (node sxpointer)          
          (let loop
            ((sxlink-arcs
              (if
               (not (and (pair? node) (eq? (car node) 'a)))
               '()  ; it is not an <A> element
               (let ((href ((select-kids (ntype?? '*text*))
                            ((select-kids (ntype?? 'href))
                             ((select-kids (ntype?? '@)) node)))))
                 (if
  < A > does n't contain href attribute
                  '()
                  (call-with-values
                   (lambda ()
                     (let ((lst (string-split (car href) (list #\#) 2)))
                       (cond
                         ((null? lst)  ; (car href)=""  - the real situation
                          (values (car href) #f))
                         ((= (length lst) 1)  ; no anchor
                          (values (car lst) #f))
                         ((= (string-length (car lst)) 0)
                          (values #f (cadr lst)))
                         (else
                          (values (car lst) (cadr lst))))))
                   (lambda (uri-ending fragment)
                     `((simple
                        (from
                         (uri)  ; from this document
                         (nodes ,node)
                         (xpointer ,(xlink:sxpointer->childseq sxpointer)))
                        (to
                         (uri ,@(if uri-ending (list uri-ending) '()))
                         ,@(if fragment
                               `((xpointer
                                  ,(string-append
                                    "xpointer(descendant::*[a/@name='"
                                    fragment "'])")))
                               '()))
                        (declaration
                         (uri)
                         (nodes ,node)
                         (xpointer
                          ,(xlink:sxpointer->childseq sxpointer))))))
                   )))))
             (kids ((select-kids (ntype?? '*)) node))
             (kid-pos 1))
            (if (null? kids)  ; every child node processed
                sxlink-arcs
                (loop
                 (append sxlink-arcs
                         (tree-walk (car kids) (cons kid-pos sxpointer)))
                 (cdr kids)
                 (+ kid-pos 1)))))))
    (let ((sxlink-arcs (tree-walk document '()))
          (uri (xlink:get-uri document)))
      (xlink:append-branch
       document
       '(@@ sxlink declared-here)
       (if uri  ; URI for the document supplied
           (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
           sxlink-arcs)))))


 This software is in Public Domain.

 Please send bug reports and comments to:
       Dmitry Lizorkin


 'SSAX:XML->SXML+xlink' function is the core of the programme. This funcion
                      locators+resources  arcs  declared-labels)
 
  - 'general - there are no XLink elements among current element's ancestors.
 So, 'extended' or 'simple' elements are expected (others don't have any XLink
 semantical meaning)
  - 'extended - for elements that are direct children of an extended link
 element, i.e. 'locator', 'resource' or 'arc'
  - 'none - no XLink elements are expected niether in the current element
 nor in any of its descendants

  sxlink-arcs = (list  sxlink-arc
                          sxlink-arc
                          ...)
  sxlink-arc - as defined in the SXLink Specification

 processed element

 - new stack-element is added when the beginning of each element is processed
 - the stack-element is consumed at the finish-element (of the same element)
  stack = (list  stack-element
                 stack-element
                 ...)
  stack-element = (list  position  xlink-values)
  position - a position within a file
 where, for example, 'type' is the value of xlink:type attribute or #f if 
 there is no such attribute

 The other parameters of the seed are presented when an extended link is
 processed

 extended link. They are temporarily stored in this parameter. This info
 is converted into an 'sxlink-arcs' parameter when the end-tag for an
 extended link element is encountered
  locators+resources = (list  locator-or-resource
                              locator-or-resource
                              ...)
  locator-or-resource = (list  uri  fragment  role  label
                               position  element)
  label - a string representing the value of xlink:label attribute, or #f if
 this attribute was omitted 

 is converted into an 'sxlink-arcs' parameter when the end-tag for an
 extended link element is encountered
  arcs = (list  arc-info
                arc-info
                ...)
                    position  element)
  from - a string representing the value of xlink:from attribute, or #f if
 this attribute was omitted 
  to - the same for an xlink:to attribute

 is used for constraint checking
  declared-labels = (list  label  label ...)
  label - a string
 Some global constants
=========================================================================
 A 'seed' datatype
                      locators+resources  arcs  declared-labels)
------------------------------------------------
 They are introducted in order to control (possible) future modifications of
 a 'seed' list
 The similar function which makes a full-length seed
------------------------------------------------
=========================================================================
 Here basic functions for special datatypes are collected
------------------------------------------------
 Adds the arc defined by the XLink simple link to 'sxlink-arcs'
 the link is untraversable
 no arc added
 no XPointer fragment identifier
 addresses the same document
 goes from this document
 in this document
 This function appends information to 'sxlink-arcs' according to
 'locators+resources' and 'arcs' parameters.
 The function is called at the end-tag of an extended link element.
 like map, but applies the function to each pair of the arguments
 everyone processed
 the iteration loop finished
 a stub for determining whether a locator-or-resouces is a local
 all arcs processed
 determining arc name
 arc outgoes from every resource
 arc comes to every resource
------------------------------------------------
 Reverse S-expression representation for XPointer ChildSeq for a currently
 processed element
 Forms sxpointer for the following sibling element of the current element
------------------------------------------------
 locators+resources - locator and resource elements defined within an
 extended link. They are temporarily stored in this parameter. This info
 is converted into an 'sxlink-arcs' parameter when the end-tag for an
 extended link element is encountered
  locators+resources = (list  locator-or-resource
                              locator-or-resource
                              ...)
  locator-or-resource = (list  label  resource-data)
  resource-data - whatever required to describe the resource in terms of
 the SXLink Specification
 NOTE: We don't apply teta-reduction for the sake of easier bug detection
 message and doesn't add anything.
  Constraint: Attributes on Locator Element
  Attribute (href)). The locator attribute (href) must have a value supplied.
 Adds information concerning XLink resource element to 'locators+resources'
------------------------------------------------
 is converted into an 'sxlink-arcs' parameter when the end-tag for an
 extended link element is encountered
  arcs = (list  arc-info
                arc-info
                ...)
  arc-info = (list  from  to  linkbase  position  data)
  linkbase - a boolean: whether a linkbase arc
 NOTE: We don't apply teta-reduction for the sake of easier bug detection
 Adds arc information to 'arcs' datatype. A side effect - checks the following
  Constraint: No Arc Duplication
  Each arc-type element must have a pair of from and to xlink-values that does
  not  repeat the from and to xlink-values (respectively) for any other
  arc-type element in the same extended link; that is, each pair in a link
  must be unique.
  If no arc-type elements are provided in an extended link, then by extension
  the missing from and to xlink-values are interpreted as standing for all the
  labels in that link.
 Inserts such a default arc if 'arcs' are empty
 position is dummy here, since it will never be used
------------------------------------------------
 declared-labels - labels declared within an extended link. This parameter
 is used for constraint checking
  declared-labels = (list  label  label ...)
  label - a string
 If an xlink:label attribute is presented in 'xlink-values', it's value is added
 to 'declared-labels'. Otherwise, 'declared-labels' remain unchainged
  The value of a label, from, or to attribute must be an NCName. If a value 
  is supplied for a from or to attribute, it must correspond to the same value
  for some label attribute on a locator- or resource-type element that appears
  as a direct child inside the same extended-type element as does the arc-type 
  element. 
 Error message is displayed if some label was undeclared.
 It is called at the end-tag of an extended link element
=========================================================================
 Some simple functions working with attributes
  xlink-values = (list
------------------------------------------------
 Trivial constructor and accessor functions
 These functions are used as a level of abstraction
 contains xlink-values of all xlink-related attributes. For example, 'type'
 is the value of xlink:type attribute or #f if there is no such attribute.
 This datatype will be called 'xlink-values' in the latter text
 NOTE: We don't apply teta-reduction for the sake of easier bug detection
------------------------------------------------
 Functions which read attributes
 The function is given a list called 'attributes' (in SSAX parser). This list
 has the form
  attributes = (list  attribute  
                      attribute
                      ...)
  attribute = (cons  (cons  namespace-prefix  attribute-name)
                     attribute-value )
           or (cons  attribute-name  attribute-value )
  namespaces - defined in "ssax.scm"
 (the result of 'xlink:construct-xlink-values' function)
 the attribute list is over
 attribute doesn't have namespace
  ns-prefixes = (list  (list  prefix  namespace-uri)
                       (list  prefix  namespace-uri)
                       ...)
  prefix - a symbol
  namespace-uri - a string
 An 'xlink-values' datatype is returned
 no attributes
 this is a non-qualified name
------------------------------------------------
 These functions check XLink constrains which limit some attributes' xlink-values
  value - a value of an attribute (#f if there is no such attribute)
  valid-xlink-values - a list of xlink-values which are allowed for this attribute
  attr-name - a string denotating a name of an attribute (for a message)
  position - position within a file
 Side effects: function "cerr"s a message if 'value' is not #f and not within
 'valid-xlink-values'
 a value is #f - a correct situation
 where, for example, 'type' is the value of xlink:type attribute or #f if 
 there is no such attribute (this datatype is a result 
 of 'read-xlink-attributes' function)
  position - position within a file

  The value of the type attribute must be supplied. The value must be one of
  "simple", "extended", "locator", "arc", "resource", "title", or "none".
  If a value is supplied for a show attribute, it must be one of the xlink-values
  "new", "replace", "embed", "other", and "none".
  xlink-values "onLoad", "onRequest", "other", and "none".
 
 The result is always #t
 Side effects - error messages (printed by
 an 'xlink:check-helper' function above)
=========================================================================
 Functions which perform starting and ending actions for XLink elements
 All these functions have the same signature:

 (smth-start position xlink-values xlink:seed)
  position - position within a file
 where, for example, 'type' is the value of xlink:type attribute or #f if 
 there is no such attribute
                      locators+resources  arcs  declared-labels)
 See a head comment for details

 (smth-end xlink:parent-seed xlink:seed element)

 All the functions return a new 'xlink:seed'
------------------------------------------------
 A general element
 It is the element which doesn't have any XLink meaning, but its descendants
 might have such a meaning
------------------------------------------------
 An element and all its descendants don't have any XLink meaning
------------------------------------------------
 A simple-link element
------------------------------------------------
 An extended-link element
 declared in this document
------------------------------------------------
 A locator element
------------------------------------------------
 A resource element
------------------------------------------------
 An arc element
=========================================================================
 Miscellaneous utility functions
------------------------------------------------
 Functions dealing with position
 Returns posiotion of a port
 NOTE: Specific for different Scheme implementations
 DL: was
(string-append "line " (number->string (port-input-line-count port)))
 This function displays an error message. #t is returned
  position - position within a file
  text - a message to display
------------------------------------------------
 Helper is used by the following functions in this section
  action-on-branch ::= (lambda (elem content-nodeset) ...)
  elem - SXML element that corresponds to the branch
  content-nodeset - new content
 The lambda should return the new elem
 lpath consists of a single member
 Walks a document
 we have reached the desired node
 no such branch
 match found
 Replaces the content of the branch with a new content
  document - SXML document
  branch-lpath - is like an sxpath location path. There must be no more than
  content-nodeset - defines the content of the branch
 Appends 'content-nodeset' to the content of the given branch
------------------------------------------------
 (borrowed from "xlink.scm")
 #f is returned if there is no "@@/uri" subtree in the document
 there is no "@@/uri" subtree
 Adds the URI of the document where the arcs were declared, to sxlink-arcs
 Returns modified sxlink-arcs
 Returns: (values new-node new-uri-alist)
 Recursive application to children
 Applies the previous function to a nodeset
=========================================================================
------------------------------------------------
 This function is called by the NEW-LEVEL-SEED handler
 A new 'xlink:seed' is returned
 This function is called by the FINISH-ELEMENT handler
 A new 'xlink:seed' is returned
 Constructs the member of an axuiliary list
-------------------------------------------------
 The function emulates a 'fold-ts' operation.
 'sxlink' subtree. If the source document already contains such a
 subtree, it will be replaced. Other subtrees in an auxiliary list will
 remain unchanged.
 URI for the document supplied
-------------------------------------------------
 it is not an <A> element
 (car href)=""  - the real situation
 no anchor
 from this document
 every child node processed
 URI for the document supplied
  Parser for XML documents that contain XLink elements
  IT IS PROVIDED " AS IS " , WITHOUT WARRANTY OF ANY KIND .
            
  Returns an SXML presentation for a document plus additional information
  extracted from XLink markup ( described below )
  is a modified    ' SSAX : XML->SXML ' function .
  ' SSAX : XML->SXML+xlink ' has a complicated seed which consists of ten elements :
   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
  1 . mode = ' general , ' extended or ' none . They have the following meaning :
  2 .  - arcs - contains information extracted from XLink elements .
  3 . Reverse S - expression representation for XPointer ChildSeq for a currently
   sxpointer : : = ( listof number )
  For example , ' ( 5 4 1 ) corresponds to " /1/4/5 "  
  4 . stack - a list of stack - elements . This list has the following semantics :
   xlink - values = ( list   type   href   role   arcrole   show   actuate   label   from   to )
  5 . locators+resources - locator and resource elements defined within an
  6 . arcs - information about arce defined within an extended link . This info
   arc - info = ( list   arcrole   show   actuate   from   to
  7 . declared - labels - labels declared within an extended link . This parameter

(define xlink:namespace-uri ')
(define xlink:linkbase-uri "")

   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
  The last three parameters are optional . See a head comment for details

  Two constructors for a seed

  This function constructs a seed consisting only of six compulsory elements
(define (xlink:make-small-seed mode sxlink-arcs sxpointer stack)
  (list mode sxlink-arcs sxpointer stack))

(define (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)
  (list mode sxlink-arcs sxpointer stack
        locators+resources arcs declared-labels))

  Accessor functions

(define (xlink:seed-mode seed)
  (car seed))
(define (xlink:seed-sxlink-arcs seed)
  (cadr seed))
(define (xlink:seed-sxpointer seed)
  (list-ref seed 2))
(define (xlink:seed-stack seed)
  (list-ref seed 3))

  We assume that the seed has the full length for the latter four functions
(define (xlink:seed-locators+resources seed)
  (list-ref seed 4))
(define (xlink:seed-arcs seed)
  (list-ref seed 5))
(define (xlink:seed-declared-labels seed)
  (list-ref seed 6))



  2 . ' sxlink - arcs ' datatype

(define (xlink:add-simple
         xlink-values element position sxpointer sxlink-arcs)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values)))
    (if
     (call-with-values
      (lambda ()
        (let ((lst (string-split href (list #\#) 2)))
          (cond
             (values (car lst) #f))
             (values #f (cadr lst)))
            (else
             (values (car lst) (cadr lst))))))
      (lambda (uri-ending fragment)
        (cons
         `(,(if (equal? arcrole xlink:linkbase-uri)
                'linkbase 'simple)
           (from
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer)))
           (to
            (uri ,@(if uri-ending (list uri-ending) '()))
            ,@(if fragment `((xpointer ,fragment)) '())
            ,@(if role `((role ,role)) '())
            ,@(if title `((title ,title)) '()))
           ,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())
           (declaration
            (nodes ,element)
            (xpointer ,(xlink:sxpointer->childseq sxpointer))
            (position ,position)))
         sxlink-arcs))))))

(define (xlink:add-extended
         locators+resources arcs sxlink-arcs declaration)
        (map-join
         (lambda (func arg-lst1 arg-lst2)
           (let ((arg-lst1 (reverse arg-lst1)))
             (let iterate-second ((lst2 (reverse arg-lst2))
                                  (res '()))
               (if
                res
                (let iterate-first ((lst1 arg-lst1)
                                    (res res))
                  (if
                   (iterate-second (cdr lst2) res)
                   (iterate-first
                    (cdr lst1)
                    (cons (func (car lst1) (car lst2)) res)))))))))
  or remote one
        (resource?
         (lambda (locator-or-resource)
  Resource iff info contains subelement ' nodes
           (assq 'nodes (xlink:resource-data locator-or-resource)))))    
    (let loop ((arcs arcs)
               (sxlink-arcs sxlink-arcs))
      (if
       sxlink-arcs
       (loop
        (cdr arcs)
        (let ((arc-info (car arcs)))
          (append
           (map-join
            (lambda (starting ending)
                   ((xlink:arc-info-linkbase arc-info)                    
                    'linkbase)
                   ((and (resource? starting)
                         (not (resource? ending)))
                    'outbound)
                   ((and (not (resource? starting))
                         (resource? ending))
                    'inbound)
                   ((and (resource? starting) (resource? ending))
                    'local-to-local)
                   (else
                    'third-party))
                (from ,@(xlink:resource-data starting))
                (to ,@(xlink:resource-data ending))
                ,@(xlink:arc-info-data arc-info)
                ,declaration))
            (let ((from (xlink:arc-info-from arc-info)))
              (if
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? from
                          (xlink:resource-label locator-or-resource)))
                locators+resources)))
            (let ((to (xlink:arc-info-to arc-info)))
              (if
               locators+resources
               (filter
                (lambda (locator-or-resource)
                  (equal? to
                          (xlink:resource-label locator-or-resource)))
                locators+resources))))
           sxlink-arcs)))))))

  3 . ' sxpointer ' datatype
   sxpointer : : = ( listof number )
  For example , ' ( 5 4 1 ) corresponds to " /1/4/5 "  

(define (xlink:sxpointer->childseq sxpointer)
  (apply
   string-append
   (map
    (lambda (num) (string-append "/" (number->string num)))
    (reverse sxpointer))))

(define (xlink:sxpointer4sibling sxpointer)
  (cons (+ 1 (car sxpointer)) (cdr sxpointer)))

  5 . ' locators+resources ' datatype

  Constructor
(define (xlink:make-locator-or-resource label resource-info)
  (list label resource-info))

  Accessors
(define (xlink:resource-label locator-or-resource)
  (car locator-or-resource))
(define (xlink:resource-data locator-or-resource)
  (cadr locator-or-resource))

  If the following XLink constraint is fulfilled , adds information about the
  XLink locator element to ' locators+resources ' . Otherwise , displays an error
   The locator - type element must have the locator attribute ( see 5.4 Locator
(define (xlink:add-locator xlink-values position element locators+resources)
  (let ((href (xlink:values-href xlink-values))
        (role (xlink:values-role xlink-values))
        (title (xlink:values-title xlink-values))
        (label (xlink:values-label xlink-values)))
    (cond
      ((not href)
       (xlink:parser-error
        position "locator element doesn't have an xlink:href attribute")
       locators+resources)
      (else
       (let ((lst (string-split href (list #\#) 2)))
         (call-with-values
          (lambda ()
            (cond
              ((= (length lst) 1) (values (car lst) #f))
              ((= (string-length (car lst)) 0) (values #f (cadr lst)))
              (else (values (car lst) (cadr lst)))))
          (lambda (uri fragment)
            (cons
             (xlink:make-locator-or-resource
              label
              `((uri ,@(if uri (list uri) '()))
                ,@(if fragment `((xpointer ,fragment)) '())
                ,@(if role `((role ,role)) '())
                ,@(if title `((title ,title)) '())))
             locators+resources))))))))

(define (xlink:add-resource xlink-values element sxpointer locators+resources)
  (let ((role (xlink:values-role xlink-values))
        (label (xlink:values-label xlink-values))
        (title (xlink:values-title xlink-values)))
    (cons
     (xlink:make-locator-or-resource
      label
      `((uri)
        (nodes ,element)
        (xpointer ,(xlink:sxpointer->childseq sxpointer))
        ,@(if role `((role ,role)) '())
        ,@(if title `((title ,title)) '())))
     locators+resources)))

  6 . ' arcs ' datatype
  arcs - information about arce defined within an extended link . This info
   arc - data - whatever required to describe the arc in terms of the SXLink
  Specification

  Constructor
(define (xlink:make-arc-info from to linkbase position data)
  (list from to linkbase position data))

  Accessors
(define (xlink:arc-info-from arc-info)
  (car arc-info))
(define (xlink:arc-info-to arc-info)
  (cadr arc-info))
(define (xlink:arc-info-linkbase arc-info)
  (list-ref arc-info 2))
(define (xlink:arc-info-position arc-info)
  (list-ref arc-info 3))
(define (xlink:arc-info-data arc-info)
  (list-ref arc-info 4))

  XLink constraint :
(define (xlink:add-arc xlink-values position element arcs)
  (let ((arcrole (xlink:values-arcrole xlink-values))
        (title (xlink:values-title xlink-values))
        (show (xlink:values-show xlink-values))
        (actuate (xlink:values-actuate xlink-values))
        (from (xlink:values-from xlink-values))
        (to (xlink:values-to xlink-values)))
    (let loop ((as arcs))
      (if
       (null? as)
       (cons
        (xlink:make-arc-info
         from to
         (equal? arcrole xlink:linkbase-uri)
         position
         `(,@(if arcrole `((arcrole ,arcrole)) '())
           ,@(if title `((title ,title)) '())
           ,@(if show `((show ,show)) '())
           ,@(if actuate `((actuate ,actuate)) '())))
        arcs)
       (let ((from2 (xlink:arc-info-from (car as)))
             (to2 (xlink:arc-info-to (car as))))
         (when
             (and (or (not from) (not from2) (equal? from from2))
                  (or (not to) (not to2) (equal? to to2)))
           (xlink:parser-error position "duplicate arcs - xlink:from"
                        (if from (string-append "=" from) " - omitted")
                        ", xlink:to"
                        (if to (string-append "=" to) " - omitted")))
         (loop (cdr as)))))))

  XLink specification , 5.1.3 :
(define (xlink:add-default-arc element arcs)
  (if (null? arcs)
      (list (xlink:make-arc-info
             #f #f #f
  none of the attributes arcrole , title , show , actuate
             ))
      arcs))

  7 . ' declared - labels ' datatype

(define (xlink:add-declared-label xlink-values declared-labels)
  (let((label (xlink:values-label xlink-values)))
    (if(not label)
       declared-labels
       (cons label declared-labels))))

  The function checks the following XLink constraint
   Constraint : label , from , and to xlink - values
  The function always returns # t.
(define (xlink:all-labels-declared arcs declared-labels)
  (let loop ((arcs arcs))
    (if
     (null? arcs)
     #t
     (let((arc-info (car arcs)))
       (let((from (xlink:arc-info-from arc-info))
            (to (xlink:arc-info-to arc-info))
            (position (xlink:arc-info-position arc-info)))       
         (when (and from (not (member from declared-labels)))
           (xlink:parser-error position "label not defined - xlink:from=" from))
         (when (and to (not (member to declared-labels)))
           (xlink:parser-error position "label not defined - xlink:to=" to))
         (loop (cdr arcs)))))))


                    type href role arcrole title show actuate label from to )


  Constructs a datatype ( just a list in a current implementation ) which
(define (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
  (list type href role arcrole title show actuate label from to))

  Accessors
(define (xlink:values-type xlink-values)
  (car xlink-values))
(define (xlink:values-href xlink-values)
  (cadr xlink-values))
(define (xlink:values-role xlink-values)
  (list-ref xlink-values 2))
(define (xlink:values-arcrole xlink-values)
  (list-ref xlink-values 3))
(define (xlink:values-title xlink-values)
  (list-ref xlink-values 4))
(define (xlink:values-show xlink-values)
  (list-ref xlink-values 5))
(define (xlink:values-actuate xlink-values)
  (list-ref xlink-values 6))
(define (xlink:values-label xlink-values)
  (list-ref xlink-values 7))
(define (xlink:values-from xlink-values)
  (list-ref xlink-values 8))
(define (xlink:values-to xlink-values)
  (list-ref xlink-values 9))


  reads XLink attributes ' values and returns a ' xlink - values ' datatype
(define (xlink:read-attributes attributes namespaces)
  (let loop ((attributes attributes)
             (type #f) (href #f) (role #f) (arcrole #f) (title #f) (show #f)
             (actuate #f) (label #f) (from #f) (to #f))
       (xlink:construct-xlink-values
        type href role arcrole title show actuate label from to)
       (let ((attribute (car attributes)))                  
         (if
          (loop (cdr attributes) 
                type href role arcrole title show actuate label from to)
          (let ((namespace-prefix (caar attribute))
                (attribute-name (cdar attribute))
                (attribute-value (cdr attribute)))
            (let ((namespace-uri
                   (let rpt ((ns namespaces))
                     (cond
                       ((null? ns) namespace-prefix)
                       ((equal? (cadar ns) namespace-prefix) (cddar ns))
                       (else (rpt (cdr ns)))))))
              (if
               (not (equal? namespace-uri xlink:namespace-uri))
               (loop (cdr attributes)
                     type href role arcrole title show actuate label from to)
               (case attribute-name
                 ((type) (loop (cdr attributes) attribute-value href role 
                               arcrole title show actuate label from to))
                 ((href) (loop (cdr attributes) type attribute-value role
                               arcrole title show actuate label from to))
                 ((role) (loop (cdr attributes) type href attribute-value 
                               arcrole title show actuate label from to))
                 ((arcrole)
                  (loop (cdr attributes) type href role attribute-value title
                        show actuate label from to))
                 ((title) (loop (cdr attributes) type href role arcrole
                                attribute-value show actuate label from to))
                 ((show) (loop (cdr attributes) type href role arcrole title
                               attribute-value actuate label from to))
                 ((actuate) (loop (cdr attributes) type href role arcrole
                                  title show attribute-value label from to))
                 ((label) (loop (cdr attributes) type href role arcrole title
                                show actuate attribute-value from to))
                 ((from) (loop (cdr attributes) type href role arcrole title
                               show actuate label attribute-value to))
                 ((to) (loop (cdr attributes) type href role arcrole title
                             show actuate label from attribute-value))
                 (else (loop (cdr attributes) type href role arcrole title
                             show actuate label from to)))))))))))

  Reads SXML element 's attributes
   element - an SXML node representing an element
(define (xlink:read-SXML-attributes element ns-prefixes)
  (let ((attr-node ((select-kids (ntype?? '@)) element)))
    (if
     (xlink:construct-xlink-values #f #f #f #f #f #f #f #f #f #f)
     (let loop ((attr-list (cdar attr-node))
                (type #f) (href #f) (role #f) (arcrole #f) (title #f)
                (show #f) (actuate #f) (label #f) (from #f) (to #f))
       (if
        (null? attr-list)
        (xlink:construct-xlink-values
         type href role arcrole title show actuate label from to)
        (let ((attribute-name (symbol->string (caar attr-list)))
              (attribute-value (cadar attr-list)))
          (call-with-values
           (lambda ()
             (cond
               ((string-rindex attribute-name #\:)
                => (lambda (pos)
                     (values
                      (string->symbol (substring attribute-name 0 pos))
                      (string->symbol
                       (substring attribute-name (+ pos 1)
                                  (string-length attribute-name))))))
               (else
                (values #f attribute-name))))
           (lambda (prefix local)
             (if
              (loop (cdr attr-list)
                    type href role arcrole title show actuate label from to)
              (let ((namespace-uri
                     (cond
                       ((assoc prefix ns-prefixes)
                        => (lambda (pair)
                             (string->symbol (cadr pair))))
                       (else
                        prefix))))
                (if
                 (not (equal? namespace-uri xlink:namespace-uri))
                 (loop (cdr attr-list)
                       type href role arcrole title show actuate label from to)
                 (case local
                   ((type) (loop (cdr attr-list) attribute-value href role 
                                 arcrole title show actuate label from to))
                   ((href) (loop (cdr attr-list) type attribute-value role
                                 arcrole title show actuate label from to))
                   ((role) (loop (cdr attr-list) type href attribute-value
                                 arcrole title show actuate label from to))
                   ((arcrole)
                    (loop (cdr attr-list) type href role attribute-value title
                          show actuate label from to))
                   ((title) (loop (cdr attr-list) type href role arcrole
                                  attribute-value show actuate label from to))
                   ((show) (loop (cdr attr-list) type href role arcrole title
                                 attribute-value actuate label from to))
                   ((actuate) (loop (cdr attr-list) type href role arcrole title
                                    show attribute-value label from to))
                   ((label) (loop (cdr attr-list) type href role arcrole title
                                  show actuate attribute-value from to))
                   ((from) (loop (cdr attr-list) type href role arcrole title
                                 show actuate label attribute-value to))
                   ((to) (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from attribute-value))
                   (else (loop (cdr attr-list) type href role arcrole title show 
                               actuate label from to))))))))))))))


  A helper function which is used by the next one
  Function always returns # t.
(define (xlink:check-helper value valid-xlink-values attr-name position)
  (cond
    ((not (member value valid-xlink-values))
     (xlink:parser-error position "unexpected attribute value - " 
                  attr-name "=" value))
    (else #t)))

   xlink - values = ( type href role arcrole show actuate label from to )
  The function checks the three similar XLink constraints :
   1 . Constraint : type Value
   2 . Constraint : show Value
   3 . Constraint : actuate Value
   If a value is supplied for an actuate attribute , it must be be one of the
(define (xlink:check-type-show-actuate-constraints xlink-values position)
  (xlink:check-helper (xlink:values-type xlink-values)
                      '("simple" "extended" "locator" "arc" "resource"
                        "title" "none")
                      "xlink:type"
                      position)
  (xlink:check-helper (xlink:values-show xlink-values)
                      '("new" "replace" "embed" "other" "none")
                      "xlink:show"
                      position)
  (xlink:check-helper (xlink:values-actuate xlink-values)
                      '("onLoad" "onRequest" "other" "none")
                      "xlink:actuate"
                      position))
    

   xlink - values = ( list   type   href   role   arcrole   show   actuate   label   from   to )
   xlink : seed = ( list   mode   sxlink - arcs   sxpointer   stack
  element - the SXML presentation of the current element


(define (xlink:general-start position xlink-values seed)
  (let((sxlink-arcs (xlink:seed-sxlink-arcs seed))       
       (sxpointer (xlink:seed-sxpointer seed))
       (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed
     'general sxlink-arcs (cons 1 sxpointer) stack)))

(define (xlink:general-end parent-seed seed element)
  (let ((mode (xlink:seed-mode parent-seed))
        (sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
        (stack (xlink:seed-stack parent-seed)))
    (xlink:make-small-seed mode sxlink-arcs sxpointer stack)))


(define (xlink:none-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:none-end parent-seed seed element)
  parent-seed)
  

(define (xlink:simple-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:simple-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:add-simple 
                             xlink-values element position
                             (xlink:seed-sxpointer parent-seed)
                             (xlink:seed-sxlink-arcs parent-seed)))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed)))
        (xlink:make-small-seed
         mode sxlink-arcs sxpointer stack)))))          


(define (xlink:extended-start position xlink-values seed)
  (let ((sxlink-arcs (xlink:seed-sxlink-arcs seed))
        (sxpointer (cons 1 (xlink:seed-sxpointer seed)))
        (stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-full-seed 'extended sxlink-arcs sxpointer stack
                          '() '() '())))

(define (xlink:extended-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((locators+resources (xlink:seed-locators+resources seed))
            (arcs (xlink:add-default-arc element (xlink:seed-arcs seed)))
            (declared-labels (xlink:seed-declared-labels seed)))           
        (xlink:all-labels-declared arcs declared-labels)      
        (let ((mode (xlink:seed-mode parent-seed))
              (sxlink-arcs
               (xlink:add-extended
                locators+resources arcs (xlink:seed-sxlink-arcs seed)
                `(declaration
                  (nodes ,element)
                  (xpointer ,(xlink:sxpointer->childseq
                              (xlink:seed-sxpointer parent-seed)))
                  (position ,position))))
              (sxpointer
               (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
              (stack (xlink:seed-stack parent-seed)))
          (xlink:make-small-seed mode sxlink-arcs sxpointer stack))))))


(define (xlink:locator-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))  

(define (xlink:locator-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources 
             (xlink:add-locator xlink-values position element
                                (xlink:seed-locators+resources parent-seed)))
            (arcs (xlink:seed-arcs parent-seed))
            (declared-labels 
             (xlink:add-declared-label 
              xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))


(define (xlink:resource-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:resource-end parent-seed seed element)
  (let((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let* ((mode (xlink:seed-mode parent-seed))
             (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
             (sxpointer
              (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
             (stack (xlink:seed-stack parent-seed))
             (locators+resources 
              (xlink:add-resource xlink-values element sxpointer
                                  (xlink:seed-locators+resources parent-seed)))
             (arcs (xlink:seed-arcs parent-seed))
             (declared-labels
              (xlink:add-declared-label
               xlink-values (xlink:seed-declared-labels parent-seed))))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))


(define (xlink:arc-start position xlink-values seed)
  (let ((stack (cons (list position xlink-values) (xlink:seed-stack seed))))
    (xlink:make-small-seed 'none '() '() stack)))

(define (xlink:arc-end parent-seed seed element)
  (let ((stack-element (car (xlink:seed-stack seed))))
    (let ((position (car stack-element))
          (xlink-values (cadr stack-element)))
      (let ((mode (xlink:seed-mode parent-seed))
            (sxlink-arcs (xlink:seed-sxlink-arcs parent-seed))
            (sxpointer
             (xlink:sxpointer4sibling (xlink:seed-sxpointer parent-seed)))
            (stack (xlink:seed-stack parent-seed))
            (locators+resources (xlink:seed-locators+resources parent-seed))           
            (arcs (xlink:add-arc xlink-values position element
                                 (xlink:seed-arcs parent-seed)))
            (declared-labels
             (xlink:seed-declared-labels parent-seed)))
        (xlink:make-full-seed mode sxlink-arcs sxpointer stack
                              locators+resources arcs declared-labels)))))




(define (xlink:get-port-position port)
  (cond-expand         
   (bigloo
    (string-append "position " (number->string (input-port-position port))))
   (chicken
    (string-append
     "line " (number->string (receive (row col) (port-position port) row))))
   (gambit
    (string-append "position "
                   (number->string (input-port-byte-position port))))
   (guile
    (string-append "line " (number->string (port-line port))))
   (plt
    (string-append "position " (number->string (file-position port))))
   (else "unknown")))

(define (xlink:parser-error position . text)
  (apply
   cerr
   (if
    (string=? position "unknown")
    (append (list nl "XLink error:" nl) text (list nl))
    (append (list nl "XLink error in " position ":" nl) text (list nl)))))

  Functions working on branches of an SXML tree

(define (xlink:branch-helper action-on-branch)
  (lambda (document branch-lpath content-nodeset)
    (letrec
  Constructs a new branch if it does n't exist in a document
         (make-new-branch
          (lambda (lpath)
                (cons (car lpath) content-nodeset)
                (list (car lpath) (make-new-branch (cdr lpath))))))
         (tree-walk
          (lambda (elem lpath)
            (if
             (action-on-branch elem content-nodeset)
             (let loop ((foll-siblings elem)
                        (prec-siblings '()))
               (cond
                  (cons*
                   (car elem)
                   (make-new-branch lpath)
                   (cdr elem)))
                 ((and (pair? (car foll-siblings))
                       (eq? (caar foll-siblings) (car lpath)))
                  (append
                   (reverse prec-siblings)
                   (list
                    (tree-walk (car foll-siblings) (cdr lpath)))
                   (cdr foll-siblings)))
                 (else
                  (loop (cdr foll-siblings)
                        (cons (car foll-siblings) prec-siblings)))))))))
      (tree-walk document branch-lpath))))

   branch - lpath : : = ( listof symbol )
  one branch in an SXML tree with this location path . If this branch does n't
  exist , it will be created as the first branch in a document
   content - nodeset : : = ( listof node )
(define xlink:replace-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (cons (car elem) content-nodeset))))

(define xlink:append-branch
  (xlink:branch-helper
   (lambda (elem content-nodeset) (append elem content-nodeset))))

  Processing the document URI

  Given a document , returns its URI ( a string )
(define (xlink:get-uri doc)
  (let ((nodeset ((select-kids (ntype?? 'uri))
                  ((select-kids (ntype?? '@@)) doc))))
        #f
        (cadar nodeset))))

(define (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
  (letrec
      ((process-arc
  uri - alist : : = ( listof ( cons uri resolved - uri ) )
  association between the URI and the corresponding resolved one
        (lambda (node uri-alist)
  a node is always an SXML element
            ((linkbase simple inbound outbound third-party local-to-local
              from to declaration)
             (call-with-values
              (lambda () (process-nodeset (cdr node) uri-alist))
              (lambda (new-children new-uri-alist)
                (values (cons (car node) new-children)
                        new-uri-alist))))
            ((uri)
             (cond
  no URI is set
                (values `(uri ,uri) uri-alist))
               ((assoc (cadr node) uri-alist)
                => (lambda (pair)
                     (values `(uri ,(cdr pair)) uri-alist)))
               (else
                (let ((resolved-uri
                       (ar:resolve-uri-according-base uri (cadr node))))
                  (values `(uri ,resolved-uri)
                          (cons
                           (cons (cadr node) resolved-uri)
                           uri-alist))))))
            (else
             (values node uri-alist)))))
       (process-nodeset
        (lambda (nodeset uri-alist)
          (let loop ((nset nodeset)
                     (res '())
                     (uri-alist uri-alist))
            (if
             (null? nset)
             (values (reverse res) uri-alist)
             (call-with-values
              (lambda () (process-arc (car nset) uri-alist))
              (lambda (new-node new-uri-alist)
                (loop (cdr nset)
                      (cons new-node res)
                      new-uri-alist))))))))
    (call-with-values
     (lambda () (process-nodeset sxlink-arcs '()))
     (lambda (new-sxlink-arcs dummy)
       new-sxlink-arcs))))
                 

  Core features of the parser

  Handler units for SSAX multi - parser
              
(define (xlink:new-level-seed-handler port attributes namespaces seed)
  (let ((position (xlink:get-port-position port))
        (xlink-values (xlink:read-attributes attributes namespaces)))
    (xlink:check-type-show-actuate-constraints xlink-values position)
    (let((mode (xlink:seed-mode seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-start position xlink-values seed))
           ((extended) (xlink:extended-start position xlink-values seed))
           ((none) (xlink:none-start position xlink-values seed))
           (else (xlink:general-start position xlink-values seed))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-start position xlink-values seed))
           ((resource) (xlink:resource-start position xlink-values seed))
           ((arc) (xlink:arc-start position xlink-values seed))
           (else (xlink:none-start position xlink-values seed))))
        ((none) (xlink:none-start position xlink-values seed))
        (else 
         (xlink:parser-error position "internal processor error - mode=" 
                      mode)
         (xlink:none-start position xlink-values seed))))))
  
(define (xlink:finish-element-handler parent-seed seed element)
  (let((xlink-values (cadar (xlink:seed-stack seed))))
    (let((mode (xlink:seed-mode parent-seed))
         (type (xlink:values-type xlink-values)))
      (case mode
        ((general)
         (case (if type (string->symbol type) type)
           ((simple) (xlink:simple-end parent-seed seed element))
           ((extended) (xlink:extended-end parent-seed 
                                           seed element))
           ((none) (xlink:none-end parent-seed seed element))
           (else (xlink:general-end parent-seed seed element))))
        ((extended)
         (case (if type (string->symbol type) type)
           ((locator) (xlink:locator-end parent-seed 
                                         seed element))
           ((resource) (xlink:resource-end parent-seed 
                                           seed element))
           ((arc) (xlink:arc-end parent-seed seed element))
           (else (xlink:none-end parent-seed seed element))))
        ((none) (xlink:none-end parent-seed seed element))
        (else 
         (xlink:parser-error 0 "internal processor error - mode=" 
                      mode)
         (xlink:none-end parent-seed seed element))))))

(define (xlink:ending-action xlink:seed)
  (let ((sxlink-arcs (reverse (xlink:seed-sxlink-arcs xlink:seed))))    
    `(sxlink
      (declared-here ,@sxlink-arcs))))

  The function which adds XLink - related information to the SXML document

   document - an SXML document
  A new SXML document is returned . It contains an auxiliary list with an
(define (SXML->SXML+xlink document)
  (letrec
      ((fold-ts
        (lambda (node ns-prefixes seed)
          (let ((xlink-values (xlink:read-SXML-attributes node ns-prefixes)))
            (let ((mode (xlink:seed-mode seed))
                  (type (xlink:values-type xlink-values))
                  (pos "unknown"))
              (let rpt
                ((kids ((select-kids (ntype?? '*)) node))
                 (new-seed
                  (case mode
                    ((general)
                     (case (if type (string->symbol type) type)
                       ((simple)
                        (xlink:simple-start pos xlink-values seed))
                       ((extended)
                        (xlink:extended-start pos xlink-values seed))
                       ((none)
                        (xlink:none-start pos xlink-values seed))
                       (else
                        (xlink:general-start pos xlink-values seed))))
                    ((extended)
                     (case (if type (string->symbol type) type)
                       ((locator)
                        (xlink:locator-start pos xlink-values seed))
                       ((resource)
                        (xlink:resource-start pos xlink-values seed))
                       ((arc)
                        (xlink:arc-start pos xlink-values seed))
                       (else
                        (xlink:none-start pos xlink-values seed))))
                    ((none)
                     (xlink:none-start pos xlink-values seed))
                    (else
                     (xlink:parser-error pos "internal processor error - mode=" mode)
                     (xlink:none-start pos xlink-values seed)))))
                (if
                 (not (null? kids))
                 (rpt (cdr kids)
                      (fold-ts (car kids) ns-prefixes new-seed))
                 (case mode
                   ((general)
                    (case (if type (string->symbol type) type)
                      ((simple) (xlink:simple-end seed new-seed node))
                      ((extended) (xlink:extended-end seed new-seed node))
                      ((none) (xlink:none-end seed new-seed node))
                      (else (xlink:general-end seed new-seed node))))
                   ((extended)
                    (case (if type (string->symbol type) type)
                      ((locator) (xlink:locator-end seed new-seed node))
                      ((resource) (xlink:resource-end seed new-seed node))
                      ((arc) (xlink:arc-end seed new-seed node))
                      (else (xlink:none-end seed new-seed node))))
                   ((none) (xlink:none-end seed new-seed node))
                   (else
                    (xlink:parser-error pos
                     "internal processor error - mode=" mode)
                    (xlink:none-end seed new-seed node))))))))))
  (let* ((ns-prefixes
          (let ((ns-node ((select-kids (ntype?? '*NAMESPACES*))
                          ((select-kids (ntype?? '@@)) document))))
            (if (null? ns-node)
                '()
                (cdar ns-node))))
         (sxlink-arcs
          (xlink:seed-sxlink-arcs
           (fold-ts ((select-kids (ntype?? '*)) document)
                    ns-prefixes
                    (xlink:make-small-seed 'general '() '(1) '()))))
         (uri (xlink:get-uri document)))
    (xlink:append-branch
     document
     '(@@ sxlink declared-here)
         (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
         sxlink-arcs)))))

  Adds SXLink arc information to SHTML document

(define (SHTML->SHTML+xlink document)
  (letrec
      ((tree-walk
  Returns (     )
        (lambda (node sxpointer)          
          (let loop
            ((sxlink-arcs
              (if
               (not (and (pair? node) (eq? (car node) 'a)))
               (let ((href ((select-kids (ntype?? '*text*))
                            ((select-kids (ntype?? 'href))
                             ((select-kids (ntype?? '@)) node)))))
                 (if
  < A > does n't contain href attribute
                  '()
                  (call-with-values
                   (lambda ()
                     (let ((lst (string-split (car href) (list #\#) 2)))
                       (cond
                          (values (car href) #f))
                          (values (car lst) #f))
                         ((= (string-length (car lst)) 0)
                          (values #f (cadr lst)))
                         (else
                          (values (car lst) (cadr lst))))))
                   (lambda (uri-ending fragment)
                     `((simple
                        (from
                         (nodes ,node)
                         (xpointer ,(xlink:sxpointer->childseq sxpointer)))
                        (to
                         (uri ,@(if uri-ending (list uri-ending) '()))
                         ,@(if fragment
                               `((xpointer
                                  ,(string-append
                                    "xpointer(descendant::*[a/@name='"
                                    fragment "'])")))
                               '()))
                        (declaration
                         (uri)
                         (nodes ,node)
                         (xpointer
                          ,(xlink:sxpointer->childseq sxpointer))))))
                   )))))
             (kids ((select-kids (ntype?? '*)) node))
             (kid-pos 1))
                sxlink-arcs
                (loop
                 (append sxlink-arcs
                         (tree-walk (car kids) (cons kid-pos sxpointer)))
                 (cdr kids)
                 (+ kid-pos 1)))))))
    (let ((sxlink-arcs (tree-walk document '()))
          (uri (xlink:get-uri document)))
      (xlink:append-branch
       document
       '(@@ sxlink declared-here)
           (xlink:set-uri-for-sxlink-arcs uri sxlink-arcs)
           sxlink-arcs)))))
