Module: txpath

 Classic TXPath implementation based on sxpathlib, sxpath-ext and txp-parser

 This software is in Public Domain.
 IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.

 Please send bug reports and comments to:
   lisovsky@acm.org      Kirill Lisovsky
   lizorkin@hotbox.ru    Dmitry Lizorkin

 XPointer's points and ranges are NOT implemented

 Full XPath Core Function Library is supported. That is:
 4.1 Node Set Functions
    number last()
    number position()
    number count(node-set)
    node-set id(object)
    string local-name(node-set?)
    string namespace-uri(node-set?)
    string name(node-set?)
 4.2 String Functions
    string string(object?)
    string concat(string, string, string*)
    boolean starts-with(string, string)
    boolean contains(string, string)
    string substring-before(string, string)
    string substring-after(string, string)
    string substring(string, number, number?)
    number string-length(string?)
    string normalize-space(string?)
    string translate(string, string, string)
 4.3 Boolean Functions
    boolean boolean(object)
    boolean not(boolean)
    boolean true()
    boolean false()
    boolean lang(string)
 4.4 Number Functions
    number number(object?)
    number sum(node-set)
    number floor(number)
    number ceiling(number)
    number round(number)


Auxilliary
f: sxml:xpointer-runtime-error
Helper functions
f: sxml:xpath-nodeset-filter
f: sxml:arithmetic-eval

XPath Core Function Library
4.1 Node Set Functions
f: sxml:core-last
f: sxml:core-position
f: sxml:core-count
f: sxml:core-id
f: sxml:core-local-name
f: sxml:core-namespace-uri
f: sxml:core-name
4.2 String Functions
f: sxml:core-string
f: sxml:core-concat
f: sxml:core-starts-with
f: sxml:core-contains
f: sxml:core-substring-before
f: sxml:core-substring-after
f: sxml:core-substring
f: sxml:core-string-length
f: sxml:core-normalize-space
f: sxml:core-translate
4.3 Boolean Functions
f: sxml:core-boolean
f: sxml:core-not
f: sxml:core-true
f: sxml:core-false
f: sxml:core-lang
4.4 Number Functions
f: sxml:core-number
f: sxml:core-sum
f: sxml:core-floor
f: sxml:core-ceiling
f: sxml:core-round

Parameters for classic TXPath implementation
f: sxml:classic-params

Highest level API functions
'sxml:xpath' and 'sxml:xpointer' functions
f: sxml:api-helper0
f: sxml:classic-res
f: sxml:api-helper
f: sxml:xpath
f: sxml:xpointer
f: sxml:xpath-expr
f: sxml:xpath+root+vars
f: sxml:xpointer+root+vars
f: sxml:xpath+root
f: txpath
'sxml:xpath+index' and 'sxml:xpointer+index' functions
f: sxml:api-index-helper
f: sxml:xpath+index
f: sxml:xpointer+index

Auxilliary


sxml:xpointer-runtime-error

(define (sxml:xpointer-runtime-error . text)
... Full Code ... )
 Runtime errors handler (unbound variable, bad argument, etc).
 It may be re-defined (say, like a warning) without 'exit',  and evaluation will 
 be continued.
 In this case, a default value (usually empty nodeset or 0) is returned by 
 a sub-expression which caused an XPath/XPointer runtime error.



Helper functions


sxml:xpath-nodeset-filter

(define (sxml:xpath-nodeset-filter preds-list nodeset root-node var-binding)
... Full Code ... )
 Filter nodeset using preds-list as described in XPath rec. 2.4
 A helper for sxml:parse-step and sxml:parse-filter-expr


sxml:arithmetic-eval

(define (sxml:arithmetic-eval unary-expr-res-lst op-lst add-on)
... Full Code ... )
 A helper for arithmetic expressions
   sxml:parse-additive-expr and sxml:parse-multiplicative-expr 



XPath Core Function Library



4.1 Node Set Functions


sxml:core-last

(define (sxml:core-last)
... Full Code ... )
 last()


sxml:core-position

(define (sxml:core-position)
... Full Code ... )
 position()


sxml:core-count

(define (sxml:core-count arg-func)
... Full Code ... )
 count(node-set)


sxml:core-id

(define (sxml:core-id arg-func)
... Full Code ... )
 id(object)


sxml:core-local-name

(define (sxml:core-local-name . arg-func)
... Full Code ... )
 local-name(node-set?)


sxml:core-namespace-uri

(define (sxml:core-namespace-uri . arg-func)
... Full Code ... )
 namespace-uri(node-set?)


sxml:core-name

(define (sxml:core-name . arg-func)
... Full Code ... )
 name(node-set?)



4.2 String Functions


sxml:core-string

(define (sxml:core-string . arg-func)
... Full Code ... )
 string(object?)


sxml:core-concat

(define (sxml:core-concat . arg-func-lst)
... Full Code ... )
 concat(string, string, string*)


sxml:core-starts-with

(define (sxml:core-starts-with arg-func1 arg-func2)
... Full Code ... )
 starts-with(string, string)


sxml:core-contains

(define (sxml:core-contains arg-func1 arg-func2)
... Full Code ... )
 contains(string, string)


sxml:core-substring-before

(define (sxml:core-substring-before arg-func1 arg-func2)
... Full Code ... )
 substring-before(string, string)


sxml:core-substring-after

(define (sxml:core-substring-after arg-func1 arg-func2)
... Full Code ... )
 substring-after(string, string)


sxml:core-substring

(define (sxml:core-substring arg-func1 arg-func2 . arg-func3)
... Full Code ... )
 substring(string, number, number?)


sxml:core-string-length

(define (sxml:core-string-length . arg-func)
... Full Code ... )
 string-length(string?)


sxml:core-normalize-space

(define (sxml:core-normalize-space . arg-func)
... Full Code ... )
 normalize-space(string?)


sxml:core-translate

(define (sxml:core-translate arg-func1 arg-func2 arg-func3)
... Full Code ... )
 translate(string, string, string)



4.3 Boolean Functions


sxml:core-boolean

(define (sxml:core-boolean arg-func)
... Full Code ... )
 boolean(object)


sxml:core-not

(define (sxml:core-not arg-func)
... Full Code ... )
 not(boolean)


sxml:core-true

(define (sxml:core-true)
... Full Code ... )
 true()


sxml:core-false

(define (sxml:core-false)
... Full Code ... )
 false()


sxml:core-lang

(define (sxml:core-lang arg-func)
... Full Code ... )
 lang(string)



4.4 Number Functions


sxml:core-number

(define (sxml:core-number . arg-func)
... Full Code ... )
 number(object?)


sxml:core-sum

(define (sxml:core-sum arg-func)
... Full Code ... )
 sum(node-set)


sxml:core-floor

(define (sxml:core-floor arg-func)
... Full Code ... )
 floor(number)


sxml:core-ceiling

(define (sxml:core-ceiling arg-func)
... Full Code ... )
 ceiling(number)


sxml:core-round

(define (sxml:core-round arg-func)
... Full Code ... )
 round(number)



Parameters for classic TXPath implementation


sxml:classic-params

(define sxml:classic-params
... Full Code ... )



Highest level API functions



'sxml:xpath' and 'sxml:xpointer' functions

  xpath-string - an XPath location path (a string)
  ns-binding - declared namespace prefixes (an optional argument)
  ns-binding = (list  (prefix . uri)
                      (prefix . uri)
                      ...)
  prefix - a symbol
  uri - a string

 The returned result:   (lambda (node . var-binding) ...)  
                   or   #f
  #f - signals of a parse error (error message is printed as a side effect
 during parsing)
  (lambda (node . var-binding) ...)  - an SXPath function
  node - a node (or a node-set) of the SXML document
  var-binding - XPath variable bindings (an optional argument)
  var-binding = (list  (var-name . value)
                       (var-name . value)
                       ...)
  var-name - (a symbol) a name of a variable
  value - its value. The value can have the following type: boolean, number,
 string, nodeset. NOTE: a node must be represented as a singleton nodeset
 
 Administrative SXPath variables:
  *root* - if presented in the 'var-binding', its value (a node or a nodeset)
 specifies the root of the SXML document

sxml:api-helper0

(define (sxml:api-helper0 parse-proc)
... Full Code ... )


sxml:classic-res

(define sxml:classic-res
... Full Code ... )


sxml:api-helper

(define (sxml:api-helper parse-proc)
... Full Code ... )


sxml:xpath

(define sxml:xpath
... Full Code ... )


sxml:xpointer

(define sxml:xpointer
... Full Code ... )


sxml:xpath-expr

(define sxml:xpath-expr
... Full Code ... )


sxml:xpath+root+vars

(define sxml:xpath+root+vars
... Full Code ... )
 Some (deprecated!) aliases for backward compatibility
 which will be eventually removed


sxml:xpointer+root+vars

(define sxml:xpointer+root+vars
... Full Code ... )


sxml:xpath+root

(define sxml:xpath+root
... Full Code ... )


txpath

(define txpath
... Full Code ... )



'sxml:xpath+index' and 'sxml:xpointer+index' functions

 NOTE: THESE FUNCTIONS ARE JUST STUBS NOW, BECAUSE THEY ALWAYS RETURN #t
 FOR 'index-required'. THESE FUNCTIONS ARE INCLUDED HERE FOR THE SAKE OF
 BACKWARD COMPATIBILITY ONLY.

  xpath-string - an XPath location path (a string)
  ns-binding - declared namespace prefixes (an optional argument)
  ns-binding = (list  (prefix . uri)
                      (prefix . uri)
                      ...)
  prefix - a symbol
  uri - a string

 The returned result:   (cons (lambda (node . id-index) ...)  
                              index-required )
                   or   #f
  #f - signals of a parse error (error message is printed as a side effect
 during parsing)
  (lambda (node) ...)  - an SXPath function
  node - a root node of the SXML document
  index-required - a boolean value: whether an id-index is required

sxml:api-index-helper

(define (sxml:api-index-helper parse-proc)
... Full Code ... )


sxml:xpath+index

(define sxml:xpath+index
... Full Code ... )


sxml:xpointer+index

(define sxml:xpointer+index
... Full Code ... )


Code

sxml:xpointer-runtime-error

Index
 Runtime errors handler (unbound variable, bad argument, etc).
 It may be re-defined (say, like a warning) without 'exit',  and evaluation will 
 be continued.
 In this case, a default value (usually empty nodeset or 0) is returned by 
 a sub-expression which caused an XPath/XPointer runtime error.
(define (sxml:xpointer-runtime-error . text)
  (apply cerr (append (list "XPath/XPointer runtime error: ") text (list nl)))
  (exit -1))

sxml:classic-params

Index
(define sxml:classic-params
  `(
    ; For XPath axes, the result is returned in the form of the pair
    ; (cons  (lambda ...)  root-node-required)  
    ;  (lambda ...) - one of the axis functions
    ;  root-node-required - a boolean value
    ; If root-node-required = #t, lambda's signature is
    ;  (lambda (test-pred?)
    ;   (lambda (root-node)
    ;    (lambda (nodeset) ... )))
    ; otherwise
    ;  (lambda (test-pred?)
    ;   (lambda (nodeset) ... ))
    (axis
     ((ancestor
       ,(lambda (add-on) (cons sxml:ancestor #t)))
      (ancestor-or-self
       ,(lambda (add-on) (cons sxml:ancestor-or-self #t)))
      (attribute
       ,(lambda (add-on) (cons sxml:attribute #f)))
      (child
       ,(lambda (add-on) (cons sxml:child #f)))
      (descendant
       ,(lambda (add-on) (cons sxml:descendant #f)))
      (descendant-or-self
       ,(lambda (add-on) (cons sxml:descendant-or-self #f)))
      (following
       ,(lambda (add-on) (cons sxml:following #t)))
      (following-sibling
       ,(lambda (add-on) (cons sxml:following-sibling #t)))
      (namespace
       ,(lambda (add-on) (cons sxml:namespace #f)))
      (parent
       ,(lambda (add-on) (cons sxml:parent #t)))
      (preceding
       ,(lambda (add-on) (cons sxml:preceding #t)))
      (preceding-sibling
       ,(lambda (add-on) (cons sxml:preceding-sibling #t)))
      (self
       ,(lambda (add-on) (cons sxml:filter #f)))))
    
    ; For NodeTests, the result is
    ;  (lambda (node) ...)  - a node test function
    ; or 'txp:semantic-error (namely, for point and range)
    (node-test
     ((star
       ,(lambda (add-on) (ntype?? '*)))
      (uri+star
       ,(lambda (uri add-on) (ntype-namespace-id?? uri)))
      (qname
       ,(lambda (uri local-name add-on)
          (if (not uri)
              (ntype?? (string->symbol local-name))
              (ntype?? (string->symbol (string-append uri ":" local-name))))))
      (comment
       ,(lambda (add-on) (ntype?? '*COMMENT*)))
      (text
       ,(lambda (add-on) (ntype?? '*text*)))
      (processing-instruction
       ,(lambda (literal-string add-on)
          (if (not literal-string)  ; no literal provided
              (lambda (node)
                (and (pair? node) (eq? (car node) '*PI*)))
              (let ((literal (string->symbol literal-string)))
                (lambda (node)
                  (and (pair? node)
                       (eq? (car node) '*PI*)
                       (equal? (cadr node) literal)))))))
      (node
       ,(lambda (add-on) sxml:node?))
      (point
       ,(lambda (add-on)
          (txp:signal-semantic-error
           "point() NodeTest is not supported by this implementation")))
      (range
       ,(lambda (add-on)
          (txp:signal-semantic-error
           "range() NodeTest is not supported by this implementation")))))
    
    ;-------------
    ; The remaining parameter values return the following
    ; (lambda (nodeset root-node context var-binding) - an SXPath-like
    ; function (it transforms a nodeset into a new nodeset)
    ;  nodeset - a current set of nodes
    ;  root-node - the root of a document (a singleton nodeset)
    ;  context - the context of the node; list of two elements - (position size)
    ;  position - context position (a number)
    ;  size - context size (a number)
    
    ; Parse step implementation
    (step
     ((common
       ,(lambda (axis-res node-test-res predicate-res-lst add-on)
          (let ((axis (car axis-res))
                (root-node-required (cdr axis-res)))
            (if
             (null? predicate-res-lst)
             (lambda (nodeset root-node context var-binding)
               (if root-node-required
                   (((axis node-test-res) root-node) nodeset)
                   ((axis node-test-res) nodeset)))
             (lambda (nodeset root-node context var-binding)
               (map-union
                (lambda (node)
                  (sxml:xpath-nodeset-filter 
                   predicate-res-lst
                   ((if root-node-required
                        ((axis node-test-res) root-node)
                        (axis node-test-res))
                    node)
                   root-node var-binding))
                nodeset))))))
      (range-to
       ,(lambda (expr-res predicate-res-lst add-on)
          (txp:signal-semantic-error "range-to function not implemented")))))
    
    ; Relative location path implementation
    (relative-lpath
     ,(lambda (step-res-lst add-on)
        (if
         (null? (cdr step-res-lst))  ; the only step
         (car step-res-lst)
         (lambda (nodeset root-node context var-binding)
           (let rpt ((nset nodeset)
                     (fs step-res-lst))
             (if (null? fs)
                 nset
                 (rpt ((car fs) nset root-node context var-binding)
                      (cdr fs))))))))
    
    ; Location path implementation
    (location-path
     ((bare-slash
       ,(lambda (add-on)
          (lambda (nodeset root-node context var-binding) root-node)))       
      (slash
       ,(lambda (relative-lpath-res add-on)
          (lambda (nodeset root-node context var-binding)
            (relative-lpath-res root-node root-node context var-binding))))
      (double-slash
       ,(lambda (relative-lpath-res add-on)
          (lambda (nodeset root-node context var-binding)
            (relative-lpath-res
             ((sxml:descendant-or-self sxml:node?) root-node)
             root-node context var-binding))))))
    
    ; Predicate implementation
    ; Note that (according to specification) a Predicate must return a number
    ; or a boolean value. However, the return value type is not checked in this
    ; function. This is performed in functions that use 'parse-predicate'
    (predicate
     ,(lambda (expr-res add-on) expr-res))  ; similar to identity function
    
    ; Variable reference implementation
    (variable-ref
     ,(lambda (var-name-string add-on)
        (let ((name (string->symbol var-name-string)))
          (lambda (nodeset root-node context var-binding)
            (cond
              ((assoc name var-binding)
               => cdr)
              (else
               (sxml:xpointer-runtime-error "unbound variable - " name)
               '()))))))
    
    ; Function call implementation
    (function-call
     ,(lambda (fun-name-string arg-res-lst add-on)
        (let ((core-alist
               ; (list fun-name min-num-args max-num-args impl)
               `((last 0 0 ,sxml:core-last)
                 (position 0 0 ,sxml:core-position)
                 (count 1 1 ,sxml:core-count)
                 (id 1 1 ,sxml:core-id)
                 (local-name 0 1 ,sxml:core-local-name)
                 (namespace-uri 0 1 ,sxml:core-namespace-uri)
                 (name 0 1 ,sxml:core-name)
                 (string 0 1 ,sxml:core-string)
                 (concat 2 -1 ,sxml:core-concat)
                 (starts-with 2 2 ,sxml:core-starts-with)
                 (contains 2 2 ,sxml:core-contains)
                 (substring-before 2 2 ,sxml:core-substring-before)
                 (substring-after 2 2 ,sxml:core-substring-after)
                 (substring 2 3 ,sxml:core-substring)
                 (string-length 0 1 ,sxml:core-string-length)
                 (normalize-space 0 1 ,sxml:core-normalize-space)
                 (translate 3 3 ,sxml:core-translate)
                 (boolean 1 1 ,sxml:core-boolean)
                 (not 1 1 ,sxml:core-not)
                 (true 0 0 ,sxml:core-true)
                 (false 0 0 ,sxml:core-false)
                 (lang 1 1 ,sxml:core-lang)
                 (number 0 1 ,sxml:core-number)
                 (sum 1 1 ,sxml:core-sum)
                 (floor 1 1 ,sxml:core-floor)
                 (ceiling 1 1 ,sxml:core-ceiling)
                 (round 1 1 ,sxml:core-round))))
          (cond
           ((assq (string->symbol fun-name-string) core-alist)
            => (lambda (quad)  ; Core function found
                 (cond
                   ((< (length arg-res-lst) (cadr quad))
                    (txp:signal-semantic-error
                     "too few arguments for the Core Function call - "
                     fun-name-string))
                   ((and (> (caddr quad) 0)
                         (> (length arg-res-lst) (caddr quad)))
                    (txp:signal-semantic-error
                     "too many arguments for the Core Function call - "
                     fun-name-string))
                   (else  ; correct number of arguments
                    ; Producing a function implementation
                    (apply (cadddr quad) arg-res-lst)))))
           (else  ; function definition not found
            (txp:signal-semantic-error
             "function call to an unknown function - " fun-name-string))))))
    
    ; Primary expression
    (primary-expr
     ((literal
       ,(lambda (literal add-on)
          (lambda (nodeset root-node context var-binding) literal)))
      (number
       ,(lambda (number add-on)
          (lambda (nodeset root-node context var-binding) number)))))

    ; Filter expression
    (filter-expr
     ,(lambda (primary-expr-res predicate-res-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let ((nodeset
                 (primary-expr-res nodeset root-node context var-binding)))
            (sxml:xpath-nodeset-filter
             predicate-res-lst
             (cond
               ((nodeset? nodeset) nodeset)
               (else 
                (sxml:xpointer-runtime-error 
                 "expected - nodeset instead of " nodeset)
                '()))
             root-node var-binding)))))
    
    ; Path expression
    (path-expr
     ((slash
       ,(lambda (filter-expr-res relative-lpath-res add-on)
          (lambda (nodeset root-node context var-binding)
            (let ((nset
                   (filter-expr-res nodeset root-node context var-binding)))
              (let ((nset 
                     (cond
                       ((nodeset? nset) nset)
                       (else 
                        (sxml:xpointer-runtime-error 
                         "expected - nodeset instead of " nset)
                        '()))))
                (relative-lpath-res nset root-node context var-binding))))))
      (double-slash
       ,(lambda (filter-expr-res relative-lpath-res add-on)
          (lambda (nodeset root-node context var-binding)
            (let ((nset
                   (filter-expr-res nodeset root-node context var-binding)))
              (let ((nset 
                     (cond
                       ((nodeset? nset) nset)
                       (else 
                        (sxml:xpointer-runtime-error 
                         "expected - nodeset instead of " nset)
                        '()))))
                (let ((nset ((sxml:descendant-or-self sxml:node?) nset)))
                  (relative-lpath-res
                   nset root-node context var-binding)))))))))
    
    ; Union expression
    (union-expr
     ,(lambda (path-expr-res-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let rpt ((res '())
                    (fs path-expr-res-lst))
            (if
             (null? fs)
             res
             (let ((nset ((car fs) nodeset root-node context var-binding)))
               (rpt
                (append 
                 res
                 (cond
                   ((not (nodeset? nset))
                    (sxml:xpointer-runtime-error 
                     "expected - nodeset instead of " nset)
                    '())
                   (else nset)))
                (cdr fs))))))))
    
    ; Unary expression
    (unary-expr
     ,(lambda (union-expr-res num-minuses add-on)
        (if (even? num-minuses)
            (lambda (nodeset root-node context var-binding)
              (sxml:number
               (union-expr-res nodeset root-node context var-binding)))
            (lambda (nodeset root-node context var-binding)
              (- (sxml:number
                  (union-expr-res nodeset root-node context var-binding)))))))
    
    ; Different operations
    (operations
     ((* ,(lambda (add-on) *))
      (div ,(lambda (add-on) /))
      (mod ,(lambda (add-on) remainder))
      (+ ,(lambda (add-on) +))
      (- ,(lambda (add-on) -))
      (< ,(lambda (add-on) (sxml:relational-cmp <)))
      (> ,(lambda (add-on) (sxml:relational-cmp >)))
      (<= ,(lambda (add-on) (sxml:relational-cmp <=)))
      (>= ,(lambda (add-on) (sxml:relational-cmp >=)))
      (= ,(lambda (add-on) sxml:equal?))
      (!= ,(lambda (add-on) sxml:not-equal?))))
    
    ; Additive and multiplicative expressions
    (mul-expr ,sxml:arithmetic-eval)
    (add-expr ,sxml:arithmetic-eval)
    
    ; Relational expression
    (relational-expr
     ,(lambda (additive-expr-res-lst cmp-op-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let rpt ((res ((car additive-expr-res-lst)
                          nodeset root-node context var-binding))
                    (fs (cdr additive-expr-res-lst))
                    (ops cmp-op-lst))
            (if (null? fs)
                res
                (rpt ((car ops)
                      res
                      ((car fs) nodeset root-node context var-binding))
                     (cdr fs)
                     (cdr ops)))))))        
    
    ; Equality expression
    (equality-expr
     ,(lambda (relational-expr-res-lst cmp-op-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let rpt ((res ((car relational-expr-res-lst)
                          nodeset root-node context var-binding))
                    (fs (cdr relational-expr-res-lst))
                    (ops cmp-op-lst))
            (if (null? fs)
                res
                (rpt ((car ops) 
                      res 
                      ((car fs) nodeset root-node context var-binding))
                     (cdr fs)
                     (cdr ops)))))))
    
    ; And-expression
    ; Note that according to 3.4 in XPath specification, the right operand
    ; is not evaluated if the left operand evaluates to false
    (and-expr
     ,(lambda (equality-expr-res-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let rpt ((fs equality-expr-res-lst))
            (cond
              ((null? fs) #t)
              ((not (sxml:boolean
                     ((car fs) nodeset root-node context var-binding))) #f)
              (else (rpt (cdr fs))))))))
    
    ; Or-expression
    (or-expr
     ,(lambda (and-expr-res-lst add-on)    
        (lambda (nodeset root-node context var-binding)
          (let rpt ((fs and-expr-res-lst))
            (cond
              ((null? fs) #f)
              ((sxml:boolean
                ((car fs) nodeset root-node context var-binding)) #t)
              (else (rpt (cdr fs))))))))
    
    ; Full XPointer
    (full-xptr
     ,(lambda (expr-res-lst add-on)
        (lambda (nodeset root-node context var-binding)
          (let rpt ((fs expr-res-lst))
            (if (null? fs)
                '()
                (let ((nset ((car fs) nodeset root-node context var-binding)))
                  (if (null? nset)
                      (rpt (cdr fs))
                      nset)))))))
    
    ; XPointer child sequence
    (child-seq
     ((with-name
      ,(lambda (name-string number-lst add-on)
         (let ((funcs
                 (apply append
                        (map
                         (lambda (num)
                           (list (sxml:child (ntype?? '*)) (node-pos num)))
                         number-lst))))
           (lambda (nodeset root-node context var-binding)
             (let ((id-nset ((sxml:child (ntype?? 'id-index))
                             ((sxml:child (ntype?? '@@)) root-node))))
               (if
                (null? id-nset)  ; no id-index
                '()
                (let ((nd (sxml:lookup name-string (cdar id-nset))))
                  (if (not nd)
                      '()
                      (let rpt ((nset (list nd))
                                (fs funcs))
                        (if (null? fs)
                            nset
                            (rpt ((car fs) nset) (cdr fs))))))))))))
      (without-name
       ,(lambda (number-lst add-on)
          (let ((funcs
                 (apply append
                        (map
                         (lambda (num)
                           (list (sxml:child (ntype?? '*)) (node-pos num)))
                         number-lst))))
            (lambda (nodeset root-node context var-binding)
              (if (nodeset? nodeset)
                  (let rpt ((nodeset nodeset) (res '()))
                    (if (null? nodeset)
                        res
                        (let rpt2 ((nset (list (car nodeset))) 
                                   (fs funcs))
                          (if (null? fs)
                              (rpt (cdr nodeset) (append res nset))
                              (rpt2 ((car fs) nset) (cdr fs))))))
                  (let rpt ((nodeset nodeset) (fs funcs))
                    (if (null? fs)
                        nodeset
                        (rpt ((car fs) nodeset) (cdr fs)))))))))))                
    ))

sxml:xpath-nodeset-filter

Index
 Filter nodeset using preds-list as described in XPath rec. 2.4
 A helper for sxml:parse-step and sxml:parse-filter-expr
(define (sxml:xpath-nodeset-filter preds-list nodeset root-node var-binding)
  (let rpt ((nodeset nodeset)
	    (ps preds-list))
    (if (null? ps) 
      nodeset
      (let lab ((nset nodeset)
		(res '())
		(pos 1)) 
	(if (null? nset)
	  (rpt (reverse res) (cdr ps))
	  (let* ((size (length nodeset))
		 (val ((car ps) 
		       (list (car nset)) 
		       root-node 
		       (cons pos size) 
		       var-binding)))
	    (lab (cdr nset)
		 (if (if (number? val)
		       (= val pos)
		       (sxml:boolean val))
		   (cons (car nset) res)
		   res)
		 (+ pos 1))))))))

sxml:arithmetic-eval

Index
 A helper for arithmetic expressions
   sxml:parse-additive-expr and sxml:parse-multiplicative-expr 
(define (sxml:arithmetic-eval unary-expr-res-lst op-lst add-on)
  (lambda (nodeset root-node context var-binding)
    (let rpt
      ((res (sxml:number
             ((car unary-expr-res-lst) nodeset root-node context var-binding)))
       (fs (cdr unary-expr-res-lst))
       (ops op-lst))
    (if (null? fs)
        res
        (rpt ((car ops)
              res
              (sxml:number ((car fs) nodeset root-node context var-binding)))
             (cdr fs)
             (cdr ops))))))

sxml:core-last

Index
 last()
(define (sxml:core-last)
  (lambda (nodeset root-node context var-binding)
    (cdr context)))

sxml:core-position

Index
 position()
(define (sxml:core-position)
  (lambda (nodeset root-node context var-binding)
    (car context)))

sxml:core-count

Index
 count(node-set)
(define (sxml:core-count arg-func)
  (lambda (nodeset root-node context var-binding)
    (let ((res (arg-func nodeset root-node context var-binding)))
      (cond
        ((nodeset? res) (length res))
        (else
         (sxml:xpointer-runtime-error
          "count() function - an argument is not a nodeset")
         0)))))

sxml:core-id

Index
 id(object)
(define (sxml:core-id arg-func)
  (lambda (nodeset root-node context var-binding)
    (let* ((id-nset ((sxml:child (ntype?? 'id-index))
                     ((sxml:child (ntype?? '@@)) root-node))))
      (if
       (null? id-nset)  ; no id-index
       '()  ; ID function returns an empty nodeset
       ((sxml:id (cdar id-nset))  ; implemented in "sxpath-ext.scm"
        (arg-func nodeset root-node context var-binding))))))

sxml:core-local-name

Index
 local-name(node-set?)
(define (sxml:core-local-name . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (cond
          ((null? nodeset) "")
          ((not (pair? (car nodeset))) "")  ; no name
          (else
           (let ((name (symbol->string (caar nodeset))))
             (cond
               ((string-rindex name #\:)
                => (lambda (pos)
                     (substring name (+ pos 1) (string-length name))))
               (else  ; a NCName
                name))))))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (let ((obj (func nodeset root-node context var-binding)))
            (cond
              ((null? obj) "")  ; an empty nodeset
              ((not (nodeset? obj))
               (sxml:xpointer-runtime-error
                "NAME function - an argument is not a nodeset")              
               "")
              ((not (pair? (car obj))) "")  ; no name
              (else
               (let ((name (symbol->string (caar obj))))
                 (cond
                   ((string-rindex name #\:)
                    => (lambda (pos)
                         (substring
                          name (+ pos 1) (string-length name))))
                   (else  ; a NCName
                    name))))))))))

sxml:core-namespace-uri

Index
 namespace-uri(node-set?)
(define (sxml:core-namespace-uri . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (cond
          ((null? nodeset) "")
          ((not (pair? (car nodeset))) "")  ; no name
          (else
           (let ((name (symbol->string (caar nodeset))))
             (cond
               ((string-rindex name #\:)
                => (lambda (pos)
                     (substring name 0 pos)))
               (else ""))))))  ; a NCName
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (let ((obj (func nodeset root-node context var-binding)))
            (cond
              ((null? obj) "")  ; an empty nodeset
              ((not (nodeset? obj))
               (sxml:xpointer-runtime-error
                "NAME function - an argument is not a nodeset")
               "")
              ((not (pair? (car obj))) "")  ; no name
              (else
               (let ((name (symbol->string (caar obj))))
                 (cond
                   ((string-rindex name #\:)
                    => (lambda (pos)
                         (substring name 0 pos)))
                   (else ""))))))))))

sxml:core-name

Index
 name(node-set?)
(define (sxml:core-name . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (cond
          ((null? nodeset) "")
          ((not (pair? (car nodeset))) "")  ; no name
          (else
           (symbol->string (caar nodeset)))))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (let ((obj (func nodeset root-node context var-binding)))
            (cond
              ((null? obj) "")  ; an empty nodeset
              ((not (nodeset? obj))
               (sxml:xpointer-runtime-error
                "NAME function - an argument is not a nodeset")
               "")
              ((not (pair? (car obj))) "")  ; no name
              (else
               (symbol->string (caar obj)))))))))

sxml:core-string

Index
 string(object?)
(define (sxml:core-string . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (sxml:string nodeset))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (sxml:string 
           (func nodeset root-node context var-binding))))))

sxml:core-concat

Index
 concat(string, string, string*)
(define (sxml:core-concat . arg-func-lst)
  (lambda (nodeset root-node context var-binding)
    (apply
     string-append
     (map
      (lambda (f)
        (sxml:string (f nodeset root-node context var-binding)))
      arg-func-lst))))

sxml:core-starts-with

Index
 starts-with(string, string)
(define (sxml:core-starts-with arg-func1 arg-func2)
  (lambda (nodeset root-node context var-binding)
    (let ((str1 (sxml:string
                 (arg-func1 nodeset root-node context var-binding)))
          (str2 (sxml:string
                 (arg-func2 nodeset root-node context var-binding))))
      (string-prefix? str2 str1))))

sxml:core-contains

Index
 contains(string, string)
(define (sxml:core-contains arg-func1 arg-func2)
  (lambda (nodeset root-node context var-binding)
    (let ((str1 (sxml:string
                 (arg-func1 nodeset root-node context var-binding)))
          (str2 (sxml:string
                 (arg-func2 nodeset root-node context var-binding))))
      (if (substring? str2 str1) #t #f)  ; must return a boolean
      )))

sxml:core-substring-before

Index
 substring-before(string, string)
(define (sxml:core-substring-before arg-func1 arg-func2)
  (lambda (nodeset root-node context var-binding)
    (let* ((str1 (sxml:string
                  (arg-func1 nodeset root-node context var-binding)))
           (str2 (sxml:string
                  (arg-func2 nodeset root-node context var-binding)))
           (pos (substring? str2 str1)))
      (if (not pos)  ; STR1 doesn't contain STR2
          ""
          (substring str1 0 pos)))))

sxml:core-substring-after

Index
 substring-after(string, string)
(define (sxml:core-substring-after arg-func1 arg-func2)
  (lambda (nodeset root-node context var-binding)
    (let* ((str1 (sxml:string
                  (arg-func1 nodeset root-node context var-binding)))
           (str2 (sxml:string
                  (arg-func2 nodeset root-node context var-binding)))
           (pos (substring? str2 str1)))
      (if
       (not pos)  ; STR1 doesn't contain STR2
       ""
       (substring
        str1 (+ pos (string-length str2)) (string-length str1))))))

sxml:core-substring

Index
 substring(string, number, number?)
(define (sxml:core-substring arg-func1 arg-func2 . arg-func3)
  (if (null? arg-func3)  ; no third argument supplied
      (lambda (nodeset root-node context var-binding)
        (let ((str (sxml:string
                    (arg-func1 nodeset root-node context var-binding)))
              (num1 (sxml:number
                     (arg-func2 nodeset root-node context var-binding))))
          (let ((len (string-length str))
                (start (- (inexact->exact (round num1)) 1)))
            (if (> start len)
                ""
                (substring str (if (< start 0) 0 start) len)))))
      (let ((arg-func3 (car arg-func3)))
        (lambda (nodeset root-node context var-binding)
          (let ((str (sxml:string
                      (arg-func1 nodeset root-node context var-binding)))
                (num1 (sxml:number
                       (arg-func2 nodeset root-node context var-binding)))
                (num2 (sxml:number
                       (arg-func3 nodeset root-node context var-binding))))
            (let* ((len (string-length str))
                   (start (- (inexact->exact (round num1)) 1))
                   (fin (+ start (inexact->exact (round num2)))))
              (if (or (> start len) (< fin 0) (< fin start))
                  ""
                  (substring str
                             (if (< start 0) 0 start)
                             (if (> fin len) len fin)))))))))

sxml:core-string-length

Index
 string-length(string?)
(define (sxml:core-string-length . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (string-length (sxml:string nodeset)))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (string-length
           (sxml:string
            (func nodeset root-node context var-binding)))))))

sxml:core-normalize-space

Index
 normalize-space(string?)
(define (sxml:core-normalize-space . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (let rpt ((src (string-split (sxml:string nodeset) sxml:whitespace))
                  (res '()))
          (cond
            ((null? src)
             (apply string-append (reverse res)))
            ((= (string-length (car src)) 0)  ; empty string
             (rpt (cdr src) res))
            ((null? res)
             (rpt (cdr src) (cons (car src) res)))
            (else
             (rpt (cdr src) (cons (car src) (cons " " res)))))))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (let rpt ((src (string-split
                          (sxml:string
                           (func nodeset root-node context var-binding))
                          sxml:whitespace))
                    (res '()))
            (cond
              ((null? src)
               (apply string-append (reverse res)))
              ((= (string-length (car src)) 0)  ; empty string
               (rpt (cdr src) res))
              ((null? res)
               (rpt (cdr src) (cons (car src) res)))
              (else
               (rpt (cdr src) (cons (car src) (cons " " res))))))))))

sxml:core-translate

Index
 translate(string, string, string)
(define (sxml:core-translate arg-func1 arg-func2 arg-func3)
  (lambda (nodeset root-node context var-binding)
    (let ((str1 (sxml:string
                 (arg-func1 nodeset root-node context var-binding)))
          (str2 (sxml:string
                 (arg-func2 nodeset root-node context var-binding)))
          (str3 (sxml:string
                 (arg-func3 nodeset root-node context var-binding))))
      (let ((alist
             (let while ((lst2 (string->list str2))
                         (lst3 (string->list str3))
                         (alist '()))
               (cond
                 ((null? lst2) (reverse alist))
                 ((null? lst3)
                  (append
                   (reverse alist)
                   (map
                    (lambda (ch) (cons ch #f))
                    lst2)))
                 (else
                  (while
                   (cdr lst2)
                   (cdr lst3)
                   (cons (cons (car lst2) (car lst3)) alist)))))))
        (let rpt ((lst1 (string->list str1))
                  (res '()))
          (cond
            ((null? lst1) (list->string (reverse res)))
            ((assoc (car lst1) alist)
             => (lambda (pair)
                  (if (cdr pair)
                      (rpt (cdr lst1) (cons (cdr pair) res))
                      (rpt (cdr lst1) res))))
            (else
             (rpt (cdr lst1) (cons (car lst1) res)))))))))

sxml:core-boolean

Index
 boolean(object)
(define (sxml:core-boolean arg-func)
  (lambda (nodeset root-node context var-binding)
    (sxml:boolean 
     (arg-func nodeset root-node context var-binding))))

sxml:core-not

Index
 not(boolean)
(define (sxml:core-not arg-func)
  (lambda (nodeset root-node context var-binding)
    (not (sxml:boolean 
          (arg-func nodeset root-node context var-binding)))))

sxml:core-true

Index
 true()
(define (sxml:core-true)
  (lambda (nodeset root-node context var-binding) #t))

sxml:core-false

Index
 false()
(define (sxml:core-false)
  (lambda (nodeset root-node context var-binding) #f))

sxml:core-lang

Index
 lang(string)
(define (sxml:core-lang arg-func)
  (lambda (nodeset root-node context var-binding)
    (if
     (null? nodeset)
     #f
     (let ((arg (sxml:string
                 (arg-func nodeset root-node context var-binding)))
           (context-node (car nodeset)))
       (let rpt ((pairs
                  (map
                   (lambda (node) (cons node #f))
                   root-node)))
         (if
          (null? pairs)  ; context node not found
          #f
          (let* ((lng
                  ((sxml:child (ntype?? '*text*))
                   ((sxml:attribute (ntype?? 'xml:lang))
                    (caar pairs))))
                 (lng (if (null? lng) (cdar pairs) (car lng))))
            (if
             (eq? context-node (caar pairs)) ; context node found
             (and
              lng
              (or (string-ci=? arg lng)
                  (string-prefix-ci? (string-append arg "-") lng)))
             (rpt
              (append
               (map
                (lambda (node) (cons node lng))
                ((sxml:attribute (ntype?? '*)) (caar pairs)))
               (map
                (lambda (node) (cons node lng))
                ((sxml:child sxml:node?) (caar pairs)))
               (cdr pairs)))))))))))

sxml:core-number

Index
 number(object?)
(define (sxml:core-number . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset root-node context var-binding)
        (sxml:number nodeset))
      (let ((func (car arg-func)))
        (lambda (nodeset root-node context var-binding)
          (sxml:number 
           (func nodeset root-node context var-binding))))))

sxml:core-sum

Index
 sum(node-set)
(define (sxml:core-sum arg-func)
  (lambda (nodeset root-node context var-binding)
    (let ((res (arg-func nodeset root-node context var-binding)))
      (cond
        ((nodeset? res)
         (apply +
                (map
                 (lambda (node)
                   (sxml:number (sxml:string-value node)))
                 res)))
        (else
         (sxml:xpointer-runtime-error
          "SUM function - an argument is not a nodeset")
         0)))))

sxml:core-floor

Index
 floor(number)
(define (sxml:core-floor arg-func)
  (lambda (nodeset root-node context var-binding)
    (inexact->exact
     (floor (sxml:number 
             (arg-func nodeset root-node context var-binding))))))

sxml:core-ceiling

Index
 ceiling(number)
(define (sxml:core-ceiling arg-func)
  (lambda (nodeset root-node context var-binding)
    (inexact->exact
     (ceiling (sxml:number
               (arg-func nodeset root-node context var-binding))))))

sxml:core-round

Index
 round(number)
(define (sxml:core-round arg-func)
  (lambda (nodeset root-node context var-binding)
    (inexact->exact
     (round (sxml:number
             (arg-func nodeset root-node context var-binding))))))

sxml:api-helper0

Index
(define (sxml:api-helper0 parse-proc)
  (lambda (xpath-string . ns-binding)
    (let ((res (parse-proc
                xpath-string
                (if (null? ns-binding) ns-binding (car ns-binding))
                '())))
      (if (txp:error? res)  ; error detected
          #f
          (lambda (node . var-binding)
            (let ((node (as-nodeset node)))
              (if
               (null? var-binding)  ; no variables supplied
               (res node node (cons 1 1) '())
               (let ((var-binding (car var-binding)))
                 (res
                  node
                  (cond ((assq '*root* var-binding)
                         => (lambda (pair) (as-nodeset (cdr pair))))
                        (else node))
                  (cons 1 1)
                  var-binding)))))))))

sxml:classic-res

Index
(define sxml:classic-res (txp:parameterize-parser sxml:classic-params))

sxml:api-helper

Index
(define (sxml:api-helper parse-proc)
  (lambda (xpath-string . ns-binding)
    (let ((res (parse-proc
                xpath-string
                (if (null? ns-binding) ns-binding (car ns-binding))
                '())))
      (if (txp:error? res)  ; error detected
          #f
          (lambda (node . var-binding)
            (let ((node (as-nodeset node)))
              (if
               (null? var-binding)  ; no variables supplied
               (res node node (cons 1 1) '())
               (let ((var-binding (car var-binding)))
                 (res
                  node
                  (cond ((assq '*root* var-binding)
                         => (lambda (pair) (as-nodeset (cdr pair))))
                        (else node))
                  (cons 1 1)
                  var-binding)))))))))

sxml:xpath

Index
(define sxml:xpath
  (sxml:api-helper (cadr (assq 'xpath sxml:classic-res))))

sxml:xpointer

Index
(define sxml:xpointer
  (sxml:api-helper (cadr (assq 'xpointer sxml:classic-res))))

sxml:xpath-expr

Index
(define sxml:xpath-expr
  (sxml:api-helper (cadr (assq 'expr sxml:classic-res))))

sxml:xpath+root+vars

Index
 Some (deprecated!) aliases for backward compatibility
 which will be eventually removed
(define sxml:xpath+root+vars sxml:xpath)

sxml:xpointer+root+vars

Index
(define sxml:xpointer+root+vars sxml:xpointer)

sxml:xpath+root

Index
(define sxml:xpath+root sxml:xpath)

txpath

Index
(define txpath sxml:xpath)

sxml:api-index-helper

Index
(define (sxml:api-index-helper parse-proc)
  (lambda (xpath-string . ns-binding)
    (let ((res (parse-proc
                xpath-string
                (if (null? ns-binding) ns-binding (car ns-binding))
                '())))
      (if (txp:error? res)  ; error detected
          #f
          (cons
           (lambda (node)
             (let ((node (as-nodeset node)))
               (res node node (cons 1 1) '())))
           #t)))))

sxml:xpath+index

Index
(define sxml:xpath+index
  (sxml:api-index-helper (cadr (assq 'xpath sxml:classic-res))))

sxml:xpointer+index

Index
(define sxml:xpointer+index
  (sxml:api-index-helper (cadr (assq 'xpointer sxml:classic-res))))