Module: xpath-context

 Context-based XPath implementation

 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

 <nodeset> ::= ( <nodeset-member>* )
 <nodeset-member> ::= <node> | <context>
 <context> ::= ( *CONTEXT*  <node>  <ancestor>* )
 <node> - an SXML node (a context node)
 <ancestor>* - context node's parent, grandparent, grandgrandparent etc.

 A CONTEXT doesn't contain more ANCESTORs than actually required for
 evaluating the location path. This is achieved by means of an "intellectual"
 parsing of the location path. The number of ANCESTORs stored in the CONTEXT
 can differ for different path steps.


Basic operations over context
f: sxml:context-u?
f: sxml:context?
Accessors
f: sxml:context->node-u
f: sxml:context->ancestors-u
f: sxml:context->content-u
f: sxml:context->node
f: sxml:context->ancestors
f: sxml:context->content
f: draft:contextset->nodeset
Mutators
f: draft:make-context
f: draft:smart-make-context
f: draft:siblings->context-set
Operations on num-ancestors
f: draft:na+
f: draft:na-minus
f: draft:na-minus-nneg
f: draft:na-max
f: draft:na-min
f: draft:na>
f: draft:na>=

Misc helpers
f: draft:list-head
f: draft:list-last
f: draft:make-list
f: draft:signal-semantic-error
f: draft:top?
f: draft:remove-eq-duplicates
f: draft:reach-root
f: draft:recover-contextset
For sxpath: handling a procedure as a location step
f: draft:find-proper-context

XPath axes
f: draft:ancestor
f: draft:ancestor-or-self
f: draft:attribute
f: draft:child
f: draft:descendant
f: draft:descendant-or-self
f: draft:following
f: draft:following-sibling
f: draft:namespace
f: draft:parent
f: draft:preceding
f: draft:preceding-sibling
f: draft:self

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

XPath AST processing
f: draft:ast-axis-specifier
f: draft:ast-node-test
In this section, each function accepts 2 arguments
f: draft:ast-location-path
f: draft:ast-absolute-location-path
f: draft:ast-relative-location-path
f: draft:ast-step
f: draft:ast-step-list
f: draft:ast-predicate
f: draft:ast-predicate-list
f: draft:ast-expr
f: draft:ast-or-expr
f: draft:ast-and-expr
f: draft:ast-equality-expr
f: draft:ast-relational-expr
f: draft:ast-additive-expr
f: draft:ast-multiplicative-expr
f: draft:ast-union-expr
f: draft:ast-path-expr
f: draft:ast-filter-expr
f: draft:ast-variable-reference
f: draft:ast-literal
f: draft:ast-number
f: draft:ast-function-call
f: draft:ast-function-arguments
Section dedicated to XPointer AST
f: draft:ast-xpointer
f: draft:ast-child-seq
f: draft:ast-number-list
f: draft:ast-full-xptr

Highest level API functions
f: draft:arglist->ns+na
f: draft:api-helper
f: draft:xpath
f: draft:xpointer
f: draft:xpath-expr
f: draft:sxpath
f: txpath-with-context
f: txpath/c
f: sxpath-with-context
f: sxpath/c

Basic operations over context


sxml:context-u?

(define (sxml:context-u? node)
... Full Code ... )
 A fast however unsafe predicate
 Assumes that the 'node' provided is a pair


sxml:context?

(define (sxml:context? node)
... Full Code ... )
 Safer predicate



Accessors


sxml:context->node-u

(define sxml:context->node-u
... Full Code ... )
 Fast however unsafe accessors
 Assume that the argument is the proper context


sxml:context->ancestors-u

(define sxml:context->ancestors-u
... Full Code ... )


sxml:context->content-u

(define sxml:context->content-u
... Full Code ... )


sxml:context->node

(define (sxml:context->node context)
... Full Code ... )
 Safe accessors
 Can be applied to both a context and an ordinary node


sxml:context->ancestors

(define (sxml:context->ancestors context)
... Full Code ... )


sxml:context->content

(define (sxml:context->content context)
... Full Code ... )


draft:contextset->nodeset

(define (draft:contextset->nodeset obj)
... Full Code ... )
 Given a context-set, converts it to a nodeset



Mutators


draft:make-context

(define (draft:make-context node ancestors)
... Full Code ... )
 Constructor


draft:smart-make-context

(define (draft:smart-make-context node ancestors num-anc)
... Full Code ... )
 A smarter constructor
 Makes context only when required, with the 'num-anc' required


draft:siblings->context-set

(define (draft:siblings->context-set nodeset ancestors)
... Full Code ... )
 Provided a 'nodeset' of sibling nodes, wraps each into context
 If 'ancestors' is empty, keeps 'nodeset' unchanged



Operations on num-ancestors

 Complexity results from #f as a value for num-ancestors (which means that the
 number of ancestors is infinite)

draft:na+

(define (draft:na+ na1 na2)
... Full Code ... )


draft:na-minus

(define (draft:na-minus na value)
... Full Code ... )


draft:na-minus-nneg

(define (draft:na-minus-nneg na value)
... Full Code ... )
 Minus, with the result that is always non-negative


draft:na-max

(define (draft:na-max . na-lst)
... Full Code ... )


draft:na-min

(define (draft:na-min . na-lst)
... Full Code ... )


draft:na>

(define (draft:na> na1 na2)
... Full Code ... )


draft:na>=

(define (draft:na>= na1 na2)
... Full Code ... )



Misc helpers


draft:list-head

(define (draft:list-head lst k)
... Full Code ... )
 Similar to R5RS 'list-tail' but returns the new list consisting of the first
 'k' members of 'lst'
 If k>(length lst) or k=#f, lst is returned
 NOTE1: k=#f is used in this implementation to represent positive infinity
 NOTE2: Unless k=#f, the result is always a newly allocated list. This is the
  main methodological difference between this function and R5RS 'list-tail'


draft:list-last

(define (draft:list-last lst)
... Full Code ... )
 Returns the last member of the list
 It is an error for the list to be empty


draft:make-list

(define (draft:make-list value num)
... Full Code ... )
 Constructs the (listof value), whose length is num


draft:signal-semantic-error

(define (draft:signal-semantic-error . text)
... Full Code ... )
 Similar to txp:signal-semantic-error, but returns #f


draft:top?

(define (draft:top? node)
... Full Code ... )
 The top of the SXML document?


draft:remove-eq-duplicates

(define (draft:remove-eq-duplicates nodeset)
... Full Code ... )
 Removes eq duplicates from the nodeset


draft:reach-root

(define (draft:reach-root contextset)
... Full Code ... )
 Reaches the root of the root of the contextset
 Result: nodeset


draft:recover-contextset

(define (draft:recover-contextset nodeset root-node num-anc)
... Full Code ... )
 Recovers context for each node of the nodeset
 Context recovery is performed in its usual technique: searching from the
 root of the document. As a result, this function can be fairly slow.
 In this implementation, it is sometimes called after an XPath 'id' function,
 for location paths like  "id(name)/.."
 By nature of 'id-index', context is lost when we access elements by their
 ID. It may be a good idea to rework the structure of 'id-index' to make it
 more suitable for purposes of this context-based XPath implementation.
 A good news is that only a few elements are usually selected by XPath 'id'
 function, thus the overhead of searching from the root node might be
 acceptable in this case. 



For sxpath: handling a procedure as a location step


draft:find-proper-context

(define (draft:find-proper-context nodeset ancestors-set num-anc)
... Full Code ... )
 Makes a context-set from a nodeset supplied, with the num-anc required
  ancestors-set ::= (listof ancestors)
  ancestors ::= (listof node)
 Members of the nodeset are known to be descendants-or-selves of
 (map car ancestors-set)



XPath axes

 Implementation is based on the concept of context
 Compared to "general" SXPath, a new optional argument was added:
  NUM-ANCESTORS - number of node's ancestors that will be required later in
  the location path. For example, NUM-ANCESTORS=1 means that the node's parent
  only must be remembered in the CONTEXT, grandparents will not be required

draft:ancestor

(define (draft:ancestor test-pred? . num-ancestors)
... Full Code ... )
 Ancestor axis


draft:ancestor-or-self

(define (draft:ancestor-or-self test-pred? . num-ancestors)
... Full Code ... )
 Ancestor-or-self axis


draft:attribute

(define (draft:attribute test-pred? . num-ancestors)
... Full Code ... )
 Attribute axis
 Borrows much from draft:child


draft:child

(define (draft:child test-pred? . num-ancestors)
... Full Code ... )
 Child axis


draft:descendant

(define (draft:descendant test-pred? . num-ancestors)
... Full Code ... )
 Descendant axis


draft:descendant-or-self

(define (draft:descendant-or-self test-pred? . num-ancestors)
... Full Code ... )
 Descendant-or-self axis


draft:following

(define (draft:following test-pred? . num-ancestors)
... Full Code ... )
 Following axis


draft:following-sibling

(define (draft:following-sibling test-pred? . num-ancestors)
... Full Code ... )
 Following-sibling axis


draft:namespace

(define (draft:namespace test-pred? . num-ancestors)
... Full Code ... )
 Namespace axis
 Borrows much from draft:child


draft:parent

(define (draft:parent test-pred? . num-ancestors)
... Full Code ... )
 Parent axis


draft:preceding

(define (draft:preceding test-pred? . num-ancestors)
... Full Code ... )
 Preceding axis


draft:preceding-sibling

(define (draft:preceding-sibling test-pred? . num-ancestors)
... Full Code ... )
 Preceding-sibling axis


draft:self

(define (draft:self test-pred? . num-ancestors)
... Full Code ... )
 Self axis
 num-ancestors is not used here



XPath Core Function Library



4.1 Node Set Functions


draft:core-last

(define (draft:core-last num-anc)
... Full Code ... )
 last()


draft:core-position

(define (draft:core-position num-anc)
... Full Code ... )
 position()


draft:core-count

(define (draft:core-count num-anc arg-func)
... Full Code ... )
 count(node-set)


draft:core-id

(define (draft:core-id num-anc arg-func)
... Full Code ... )
 id(object)


draft:core-local-name

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


draft:core-namespace-uri

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


draft:core-name

(define (draft:core-name num-anc . arg-func)
... Full Code ... )
 name(node-set?)



4.2 String Functions


draft:core-string

(define (draft:core-string num-anc . arg-func)
... Full Code ... )
 string(object?)


draft:core-concat

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


draft:core-starts-with

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


draft:core-contains

(define (draft:core-contains num-anc arg-func1 arg-func2)
... Full Code ... )
 contains(string, string)


draft:core-substring-before

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


draft:core-substring-after

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


draft:core-substring

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


draft:core-string-length

(define (draft:core-string-length num-anc . arg-func)
... Full Code ... )
 string-length(string?)


draft:core-normalize-space

(define (draft:core-normalize-space num-anc . arg-func)
... Full Code ... )
 normalize-space(string?)


draft:core-translate

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



4.3 Boolean Functions


draft:core-boolean

(define (draft:core-boolean num-anc arg-func)
... Full Code ... )
 boolean(object)


draft:core-not

(define (draft:core-not num-anc arg-func)
... Full Code ... )
 not(boolean)


draft:core-true

(define (draft:core-true num-anc)
... Full Code ... )
 true()


draft:core-false

(define (draft:core-false num-anc)
... Full Code ... )
 false()


draft:core-lang

(define (draft:core-lang num-anc arg-func)
... Full Code ... )
 lang(string)



4.4 Number Functions


draft:core-number

(define (draft:core-number num-anc . arg-func)
... Full Code ... )
 number(object?)


draft:core-sum

(define (draft:core-sum num-anc arg-func)
... Full Code ... )
 sum(node-set)


draft:core-floor

(define (draft:core-floor num-anc arg-func)
... Full Code ... )
 floor(number)


draft:core-ceiling

(define (draft:core-ceiling num-anc arg-func)
... Full Code ... )
 ceiling(number)


draft:core-round

(define (draft:core-round num-anc arg-func)
... Full Code ... )
 round(number)



XPath AST processing

 AST is considered to be properly formed

draft:ast-axis-specifier

(define (draft:ast-axis-specifier op num-anc)
... Full Code ... )
 {5} <AxisSpecifier> ::= (axis-specifier  <AxisName> )
 {6} <AxisName> ::= (ancestor)
                    | (ancestor-or-self)
                    | (attribute)
                    | (child)
                    | (descendant)
                    | (descendant-or-self)
                    | (following)
                    | (following-sibling)
                    | (namespace)
                    | (parent)
                    | (preceding)
                    | (preceding-sibling)
                    | (self)
                    | (arc)  ; the following 3 are added by SXLink
                    | (traverse)
                    | (traverse-arc)
 Returns:  (list lambda num-ancestors pass-vars?)
  pass-vars? - a boolean: whether var-bindings must be passed to the axis


draft:ast-node-test

(define (draft:ast-node-test op)
... Full Code ... )
 {7} <NodeTest> ::= (node-test (*))
                    | (node-test (namespace-uri  <String> ))
                    | (node-test (namespace-uri  <String> )?
                                 (local-name  <String> ))
                    | (node-test (comment))
                    | (node-test (text))
                    | (node-test (pi <String>? ))
                    | (node-test (point))
                    | (node-test (range))
 + added by sxpath native syntax:
                    | (node-test (equal?  <SXML-node> ))
                    | (node-test (eq?  <SXML-node> ))
                    | (node-test (names  <String>+ ))
                    | (node-test (not-names  <String>+ ))s



In this section, each function accepts 2 arguments

  op - S-expression which represents the operation
  num-anc - how many ancestors are required in the context after that
            operation
 and returns either #f, which signals of a semantic error, or
  (cons (lambda (nodeset position+size var-binding) ...)
        num-anc-it-requires)
  position+size - the same to what was called 'context' in TXPath-1  

draft:ast-location-path

(define (draft:ast-location-path op num-anc)
... Full Code ... )
 {1} <LocationPath> ::= <RelativeLocationPath>
                        | <AbsoluteLocationPath>


draft:ast-absolute-location-path

(define (draft:ast-absolute-location-path op num-anc)
... Full Code ... )
 {2} <AbsoluteLocationPath> ::= (absolute-location-path  <Step>* )


draft:ast-relative-location-path

(define (draft:ast-relative-location-path op num-anc)
... Full Code ... )
 {3} <RelativeLocationPath> ::= (relative-location-path  <Step>+ )


draft:ast-step

(define (draft:ast-step op num-anc)
... Full Code ... )
 {4} <Step> ::= (step  <AxisSpecifier> <NodeTest> <Predicate>* )
                | (range-to  (expr <Expr>)  <Predicate>* )


draft:ast-step-list

(define (draft:ast-step-list step-lst num-anc)
... Full Code ... )
 {4a} ( <Step>+ )
 Returns (cons (listof step-impl) num-anc) or #f


draft:ast-predicate

(define (draft:ast-predicate op num-anc)
... Full Code ... )
 {8} <Predicate> ::= (predicate  <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for Predicates


draft:ast-predicate-list

(define (draft:ast-predicate-list op-lst num-anc)
... Full Code ... )
 {8a} ( <Predicate>+ )
 Returns (cons (listof pred-impl) num-anc) or #f
 NOTE: num-anc is dummy here, since it is always 0 for Predicates


draft:ast-expr

(define (draft:ast-expr op num-anc)
... Full Code ... )
 {9} <Expr> ::= <OrExpr>
                | <AndExpr>
                | <EqualityExpr>
                | <RelationalExpr>
                | <AdditiveExpr>
                | <MultiplicativeExpr>
                | <UnionExpr>
                | <PathExpr>
                | <FilterExpr>
                | <VariableReference>
                | <Literal>
                | <Number>
                | <FunctionCall>
                | <LocationPath>


draft:ast-or-expr

(define (draft:ast-or-expr op num-anc)
... Full Code ... )
 {10} <OrExpr> ::= (or <Expr> <Expr>+ )
 NOTE: num-anc is dummy here, since it is always 0 for OrExpr


draft:ast-and-expr

(define (draft:ast-and-expr op num-anc)
... Full Code ... )
 {11} <AndExpr> ::= (and <Expr> <Expr>+ )
 NOTE: num-anc is dummy here, since it is always 0 for AndExpr


draft:ast-equality-expr

(define (draft:ast-equality-expr op num-anc)
... Full Code ... )
 {12} <EqualityExpr> ::= (=  <Expr> <Expr> )
                         | (!=  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for EqualityExpr


draft:ast-relational-expr

(define (draft:ast-relational-expr op num-anc)
... Full Code ... )
 {13} <RelationalExpr> ::= (<  <Expr> <Expr> )
                           | (>  <Expr> <Expr> )
                           | (<=  <Expr> <Expr> )
                           | (>=  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for RelationalExpr


draft:ast-additive-expr

(define (draft:ast-additive-expr op num-anc)
... Full Code ... )
 {14} <AdditiveExpr> ::= (+  <Expr> <Expr> )
                         | (-  <Expr> <Expr>? )
 NOTE: num-anc is dummy here, since it is always 0 for AdditiveExpr


draft:ast-multiplicative-expr

(define (draft:ast-multiplicative-expr op num-anc)
... Full Code ... )
 {15} <MultiplicativeExpr> ::= (*  <Expr> <Expr> )
                               | (div  <Expr> <Expr> )
                               | (mod  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for MultiplicativeExpr


draft:ast-union-expr

(define (draft:ast-union-expr op num-anc)
... Full Code ... )
 {16} <UnionExpr> ::= (union-expr  <Expr> <Expr>+ )


draft:ast-path-expr

(define (draft:ast-path-expr op num-anc)
... Full Code ... )
 {17} <PathExpr> ::= (path-expr  <FilterExpr> <Step>+ )


draft:ast-filter-expr

(define (draft:ast-filter-expr op num-anc)
... Full Code ... )
 {18} <FilterExpr> ::= (filter-expr (primary-expr  <Expr> )
                                    <Predicate>* )


draft:ast-variable-reference

(define (draft:ast-variable-reference op num-anc)
... Full Code ... )
 {19} <VariableReference> ::= (variable-reference  <String> )


draft:ast-literal

(define (draft:ast-literal op num-anc)
... Full Code ... )
 {20} <Literal> ::= (literal  <String> )


draft:ast-number

(define (draft:ast-number op num-anc)
... Full Code ... )
 {21} <Number> :: (number  <Number> )


draft:ast-function-call

(define (draft:ast-function-call op num-anc)
... Full Code ... )
 {22} <FunctionCall> ::= (function-call (function-name  <String> )
                                        (argument  <Expr> )* )


draft:ast-function-arguments

(define (draft:ast-function-arguments op-lst)
... Full Code ... )
 {22a} ( (argument  <Expr> )* )
 na-lst - number of ancestors required for each of the arguments
 Returns: (listof expr-impl) or #f



Section dedicated to XPointer AST


draft:ast-xpointer

(define (draft:ast-xpointer op num-anc)
... Full Code ... )
 {25} <XPointer> ::= <ChildSeq>
                     | <FullXPtr>
                     | <Expr>


draft:ast-child-seq

(define (draft:ast-child-seq op num-anc)
... Full Code ... )
 {26} <ChildSeq> ::= (child-seq (name  <String> ))
                     | (child-seq (name  <String> )?
                                  (number  <Number> )+ )


draft:ast-number-list

(define (draft:ast-number-list number-lst num-anc)
... Full Code ... )
 {26a} ( (number  <Number> )+ )
 Returns (cons (listof sxpath-converter) num-anc) or #f


draft:ast-full-xptr

(define (draft:ast-full-xptr op num-anc)
... Full Code ... )
 {27} <FullXPtr> ::= (full-xptr  <Expr> <Expr>+ )



Highest level API functions

 xpath-string - an XPath location path (a string)
 ns+na - can contain 'ns-binding' and/or 'num-ancestors' and/or none of them
 ns-binding - declared namespace prefixes (an optional argument)
  ns-binding ::= (listof (prefix . uri))
  prefix - a symbol
  uri - a string
 num-ancestors - number of ancestors required for resulting nodeset. Can
  generally be omitted and is than defaulted to 0, which denotes a _usual_
  nodeset. If a negative number, this signals that all ancestors should be
  remembered in the context

 Returns: (lambda (nodeset position+size var-binding) ...)
 position+size - the same to what was called 'context' in TXPath-1
 var-binding - XPath variable bindings (an optional argument)
  var-binding = (listof (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

draft:arglist->ns+na

(define (draft:arglist->ns+na arglst)
... Full Code ... )
 Given a list of arguments, returns
  (values ns-binding num-anc)


draft:api-helper

(define (draft:api-helper grammar-parser ast-parser)
... Full Code ... )
 Helper for constructing several highest-level API functions


draft:xpath

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


draft:xpointer

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


draft:xpath-expr

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


draft:sxpath

(define draft:sxpath
... Full Code ... )


txpath-with-context

(define txpath-with-context
... Full Code ... )
 Aliases


txpath/c

(define txpath/c
... Full Code ... )


sxpath-with-context

(define sxpath-with-context
... Full Code ... )


sxpath/c

(define sxpath/c
... Full Code ... )


Code

sxml:context-u?

Index
 A fast however unsafe predicate
 Assumes that the 'node' provided is a pair
(define (sxml:context-u? node)
  (eq? (car node) '*CONTEXT*))

sxml:context?

Index
 Safer predicate
(define (sxml:context? node)
  (and (pair? node) (eq? (car node) '*CONTEXT*)))

draft:list-head

Index
 Similar to R5RS 'list-tail' but returns the new list consisting of the first
 'k' members of 'lst'
 If k>(length lst) or k=#f, lst is returned
 NOTE1: k=#f is used in this implementation to represent positive infinity
 NOTE2: Unless k=#f, the result is always a newly allocated list. This is the
  main methodological difference between this function and R5RS 'list-tail'
(define (draft:list-head lst k)
  (letrec
      ((list-head
        (lambda (lst k)
          (if (or (null? lst) (zero? k))
              '()
              (cons (car lst) (list-head (cdr lst) (- k 1)))))))
    (if k
        (list-head lst k)
        lst)))

draft:list-last

Index
 Returns the last member of the list
 It is an error for the list to be empty
(define (draft:list-last lst)
  (if (null? (cdr lst))
      (car lst)
      (draft:list-last (cdr lst))))

draft:make-list

Index
 Constructs the (listof value), whose length is num
(define (draft:make-list value num)
  (if (= num 0)
      '()
      (cons value (draft:make-list value (- num 1)))))

draft:signal-semantic-error

Index
 Similar to txp:signal-semantic-error, but returns #f
(define (draft:signal-semantic-error . text)
  (apply txp:signal-semantic-error text)
  #f)

draft:top?

Index
 The top of the SXML document?
(define (draft:top? node)
  (and (pair? node) (eq? (car node) '*TOP*)))

draft:remove-eq-duplicates

Index
 Removes eq duplicates from the nodeset
(define (draft:remove-eq-duplicates nodeset)
  (cond
    ((null? nodeset) nodeset)
    ((memq (car nodeset) (cdr nodeset))
     (draft:remove-eq-duplicates (cdr nodeset)))
    (else
     (cons (car nodeset) (draft:remove-eq-duplicates (cdr nodeset))))))

draft:reach-root

Index
 Reaches the root of the root of the contextset
 Result: nodeset
(define (draft:reach-root contextset)
  (let ((nodeset (map
                  (lambda (node)
                    (if
                     (sxml:context? node)
                     (draft:list-last (sxml:context->ancestors-u node))
                     node))
                  contextset)))
    (if (or (null? nodeset) (null? (car nodeset)))  ; (length nodeset)<=1
        nodeset
        (draft:remove-eq-duplicates nodeset))))

draft:recover-contextset

Index
 Recovers context for each node of the nodeset
 Context recovery is performed in its usual technique: searching from the
 root of the document. As a result, this function can be fairly slow.
 In this implementation, it is sometimes called after an XPath 'id' function,
 for location paths like  "id(name)/.."
 By nature of 'id-index', context is lost when we access elements by their
 ID. It may be a good idea to rework the structure of 'id-index' to make it
 more suitable for purposes of this context-based XPath implementation.
 A good news is that only a few elements are usually selected by XPath 'id'
 function, thus the overhead of searching from the root node might be
 acceptable in this case. 
(define (draft:recover-contextset nodeset root-node num-anc)
  (map
   (lambda (node)
     (draft:smart-make-context
      node
      (((sxml:ancestor (lambda (x) #t)) root-node) node)
      num-anc))
   nodeset))

draft:ancestor

Index
 Ancestor axis
(define (draft:ancestor test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (sxml:context? node)
             (let loop ((ancs-to-view (sxml:context->ancestors-u node))
                        (res '()))
               (cond
                 ((null? ancs-to-view)  ; processed everyone
                  (reverse res)  ; reverse document order required
                  )
                 ((test-pred? (car ancs-to-view))  ; can add it to result
                  (loop
                   (cdr ancs-to-view)
                   (cons
                    (draft:smart-make-context
                     (car ancs-to-view) (cdr ancs-to-view) num-anc)
                    res)))
                 (else  ; current node doesn't satisfy the predicate
                  (loop (cdr ancs-to-view) res))))
             '()  ; no ancestors
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:ancestor-or-self

Index
 Ancestor-or-self axis
(define (draft:ancestor-or-self test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (cond
              ((sxml:context? node)
               (let loop ((ancs-to-view (sxml:context->content-u node))
                          (res '()))
                 (cond
                   ((null? ancs-to-view)  ; processed everyone
                    (reverse res)  ; reverse document order required
                    )
                   ((test-pred? (car ancs-to-view))  ; can add it to result
                    (loop
                     (cdr ancs-to-view)
                     (cons
                      (draft:smart-make-context
                       (car ancs-to-view) (cdr ancs-to-view) num-anc)
                      res)))
                   (else  ; current node doesn't satisfy the predicate
                    (loop (cdr ancs-to-view) res)))))
              ; ordinary SXML node
              ((test-pred? node)  ; satisfies the predicate
               (list node))
              (else
               '())))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:attribute

Index
 Attribute axis
 Borrows much from draft:child
(define (draft:attribute test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (cond
              ((not (pair? node)) '())   ; no attributes
              ; (car node) is always a symbol
              ((sxml:context-u? node)  ; a context node
               (draft:siblings->context-set
                ((sxml:filter test-pred?)
                 (sxml:attr-list (sxml:context->node-u node)))
                (draft:list-head (sxml:context->content-u node) num-anc)))
              (else  ; an ordinary node, and is a pair
               (draft:siblings->context-set
                ((sxml:filter test-pred?) (sxml:attr-list node))
                (draft:list-head (list node) num-anc)))))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))  

draft:child

Index
 Child axis
(define (draft:child test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (cond
              ((not (pair? node)) '())   ; no children
              ; (car node) is always a symbol
              ((sxml:context-u? node)  ; a context node
               (draft:siblings->context-set
                ((select-kids test-pred?) (sxml:context->node-u node))
                (draft:list-head (sxml:context->content-u node) num-anc)))
              ; an ordinary node, and is a pair
              ((memq (car node) '(*PI* *COMMENT* *ENTITY*))
               '())
              (else
               (draft:siblings->context-set
                ((sxml:filter test-pred?) (cdr node))  ; like in 'select-kids'
                (draft:list-head (list node) num-anc)))))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:descendant

Index
 Descendant axis
(define (draft:descendant test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (child (draft:child sxml:node? num-anc))
         (this-axis
          (lambda (node)  ; not a nodeset                        
            (let rpt ((res '())
                      (more (child node)))
              (if (null? more)
                  (reverse res)
                  (rpt
                   (if (test-pred? (sxml:context->node (car more)))
                       (cons (car more) res)
                       res)
                   (append (child (car more)) (cdr more))))))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:descendant-or-self

Index
 Descendant-or-self axis
(define (draft:descendant-or-self test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (child (draft:child sxml:node? num-anc))
         (this-axis
          (lambda (node)  ; not a nodeset                        
            (let rpt ((res '())
                      (more (list node)))
              (if (null? more)
                  (reverse res)
                  (rpt
                   (if (test-pred? (sxml:context->node (car more)))
                       (cons (car more) res)
                       res)
                   (append (child (car more)) (cdr more))))))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:following

Index
 Following axis
(define (draft:following test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (descend (draft:descendant-or-self test-pred? num-anc))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (sxml:context? node)
             (let loop ((curr-node (sxml:context->node-u node))
                        (ancs-to-view (sxml:context->ancestors-u node))
                        (res '()))
               (if
                (null? ancs-to-view)  ; processed everyone                 
                res
                (loop
                 (car ancs-to-view)
                 (cdr ancs-to-view)
                 (append
                  res
                  (descend
                   (draft:siblings->context-set
                    (cond
                       ((memq curr-node
                        (cdr  ; parent is an element => cdr gives its children
                         (car ancs-to-view)))
                        => cdr)
                       (else  ; curr-node is an attribute node
                        ((select-kids sxml:node?) (car ancs-to-view))))
                     (draft:list-head ancs-to-view num-anc)))))))
             '()  ; no following members
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:following-sibling

Index
 Following-sibling axis
(define (draft:following-sibling test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (and (sxml:context? node)                  
                  (not (null? (sxml:context->ancestors-u node))))
             (cond
               ((memq (sxml:context->node-u node)
                      (cdr  ; parent is an element => cdr gives its children
                       (car (sxml:context->ancestors-u node))))
                => (lambda (foll-siblings)
                     (draft:siblings->context-set
                      ((sxml:filter test-pred?) (cdr foll-siblings))
                      (draft:list-head
                       (sxml:context->ancestors-u node) num-anc))))
               (else  ; no following siblings
                '()))
             '()  ; no parent => no siblings
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:namespace

Index
 Namespace axis
 Borrows much from draft:child
(define (draft:namespace test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (cond
              ((not (pair? node)) '())   ; no namespaces
              ; (car node) is always a symbol
              ((sxml:context-u? node)  ; a context node
               (draft:siblings->context-set
                ((sxml:filter test-pred?)
                 (sxml:ns-list (sxml:context->node-u node)))
                (draft:list-head (sxml:context->content-u node) num-anc)))
              (else  ; an ordinary node, and is a pair
               (draft:siblings->context-set
                ((sxml:filter test-pred?) (sxml:ns-list node))
                (draft:list-head (list node) num-anc)))))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:parent

Index
 Parent axis
(define (draft:parent test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (and (sxml:context? node)
                  (not (null? (sxml:context->ancestors-u node)))
                  (test-pred? (car (sxml:context->ancestors-u node))))
             (draft:smart-make-context
              (car (sxml:context->ancestors-u node))
              (cdr (sxml:context->ancestors-u node))
              num-anc)
             '()  ; no parent
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:preceding

Index
 Preceding axis
(define (draft:preceding test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (descend (draft:descendant-or-self test-pred? num-anc))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (sxml:context? node)
             (let loop ((curr-node (sxml:context->node-u node))
                        (ancs-to-view (sxml:context->ancestors-u node))                        
                        (to-descend '()))
               (cond
                 ((null? ancs-to-view)  ; processed everyone
                  (map-union
                   (lambda (node) (reverse (descend node)))
                   to-descend))
                 ((memq curr-node
                        (reverse
                         ((select-kids sxml:node?)
                          (car ancs-to-view))))
                  => (lambda (prec-siblings)
                       (loop
                        (car ancs-to-view)
                        (cdr ancs-to-view)
                        (append
                         to-descend
                         (draft:siblings->context-set
                           (cdr prec-siblings)
                           (draft:list-head ancs-to-view num-anc))))))
                 (else  ; no preceding siblings
                  (loop (car ancs-to-view)
                        (cdr ancs-to-view)
                        to-descend))))
             '()  ; no preceding members
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:preceding-sibling

Index
 Preceding-sibling axis
(define (draft:preceding-sibling test-pred? . num-ancestors)
  (let* ((num-anc (if (null? num-ancestors) 0 (car num-ancestors)))
         (this-axis
          (lambda (node)  ; not a nodeset
            (if
             (and (sxml:context? node)                  
                  (not (null? (sxml:context->ancestors-u node))))
             (cond
               ((memq (sxml:context->node-u node)
                      (reverse
                       (cdr  ; parent is an element => cdr gives its children
                        (car (sxml:context->ancestors-u node)))))
                => (lambda (prec-siblings)
                     (draft:siblings->context-set
                      ((sxml:filter test-pred?) (cdr prec-siblings))
                      (draft:list-head
                       (sxml:context->ancestors-u node) num-anc))))
               (else  ; no preceding siblings
                '()))
             '()  ; no parent => no siblings
             ))))
    (lambda (node)   ; node or nodeset
      (if (nodeset? node)
          (map-union this-axis node)
          (this-axis node)))))

draft:self

Index
 Self axis
 num-ancestors is not used here
(define (draft:self test-pred? . num-ancestors)
  (sxml:filter
   (lambda (node) (test-pred? (sxml:context->node node)))))

draft:ast-axis-specifier

Index
 {5} <AxisSpecifier> ::= (axis-specifier  <AxisName> )
 {6} <AxisName> ::= (ancestor)
                    | (ancestor-or-self)
                    | (attribute)
                    | (child)
                    | (descendant)
                    | (descendant-or-self)
                    | (following)
                    | (following-sibling)
                    | (namespace)
                    | (parent)
                    | (preceding)
                    | (preceding-sibling)
                    | (self)
                    | (arc)  ; the following 3 are added by SXLink
                    | (traverse)
                    | (traverse-arc)
 Returns:  (list lambda num-ancestors pass-vars?)
  pass-vars? - a boolean: whether var-bindings must be passed to the axis
(define (draft:ast-axis-specifier op num-anc)
  (if
   (not (eq? (car op) 'axis-specifier))
   (draft:signal-semantic-error "not an AxisSpecifier - " op)
   (case (caadr op)  ; AxisName
     ((ancestor)
      (list draft:ancestor #f #f))
     ((ancestor-or-self)
      (list draft:ancestor-or-self #f #f))
     ((attribute)
      (list draft:attribute (draft:na-minus-nneg num-anc 1) #f))
     ((child)
      (list draft:child (draft:na-minus-nneg num-anc 1) #f))
     ((descendant)
      (list draft:descendant (draft:na-minus-nneg num-anc 1) #f))
     ((descendant-or-self)
      (list draft:descendant-or-self num-anc #f))
     ((following)
      (list draft:following #f #f))
     ((following-sibling)
      (list draft:following-sibling (draft:na-max num-anc 1) #f))
     ((namespace)
      (list draft:namespace (draft:na-minus-nneg num-anc 1) #f))
     ((parent)
      (list draft:parent (draft:na+ num-anc 1) #f))
     ((preceding)
      (list draft:preceding #f #f))
     ((preceding-sibling)
      (list draft:preceding-sibling (draft:na-max num-anc 1) #f))
     ((self)
      (list draft:self num-anc #f))
     ((arc)
      (list xlink:axis-arc #f #f))
     ((traverse)
      (list xlink:axis-traverse #f #t))
     ((traverse-arc)
      (list xlink:axis-traverse-arc #f #t))
     (else
      (draft:signal-semantic-error "unknown AxisName - " op)))))

draft:ast-node-test

Index
 {7} <NodeTest> ::= (node-test (*))
                    | (node-test (namespace-uri  <String> ))
                    | (node-test (namespace-uri  <String> )?
                                 (local-name  <String> ))
                    | (node-test (comment))
                    | (node-test (text))
                    | (node-test (pi <String>? ))
                    | (node-test (point))
                    | (node-test (range))
 + added by sxpath native syntax:
                    | (node-test (equal?  <SXML-node> ))
                    | (node-test (eq?  <SXML-node> ))
                    | (node-test (names  <String>+ ))
                    | (node-test (not-names  <String>+ ))s
(define (draft:ast-node-test op)
  (if
   (not (eq? (car op) 'node-test))
   (draft:signal-semantic-error "not an NodeTest - " op)
   (case (caadr op)  ; NodeTest name
     ((*)
      (ntype?? '*))
     ((namespace-uri)
      (cond
        ((= (length op) 2)  ; NodeTest in the form of prefix:*
         (ntype-namespace-id?? (cadadr op)))
        ((eq? (caaddr op) 'local-name)
         (ntype?? (string->symbol
                   (string-append (cadadr op) ":" (cadr (caddr op))))))
        (else
         (draft:signal-semantic-error "improper QName NodeTest - " op))))
     ((local-name)      
      (ntype?? (string->symbol (cadadr op))))
     ((comment)
      (ntype?? '*COMMENT*))
     ((text)
      (ntype?? '*text*))
     ((pi)
      (if (= (length (cadr op)) 2)  ; PI target supplied
          (let ((target (string->symbol (cadadr op))))
            (lambda (node)
              (and (pair? node)
                   (eq? (car node) '*PI*)
                   (equal? (cadr node) target))))
          (lambda (node)
            (and (pair? node) (eq? (car node) '*PI*)))))
     ((node) sxml:node?)
     ((point)
      (draft:signal-semantic-error
       "point() NodeTest is not supported by this implementation"))
     ((range)
      (draft:signal-semantic-error
       "range() NodeTest is not supported by this implementation"))
     ((equal?)
      (node-equal? (cadadr op)))
     ((eq?)
      (node-eq? (cadadr op)))
     ((names)
      (ntype-names?? (cdadr op)))
     ((not-names)
      (sxml:complement (ntype-names?? (cdadr op))))
     (else
      (draft:signal-semantic-error "unknown NodeTest - " op)))))

draft:arglist->ns+na

Index
 Given a list of arguments, returns
  (values ns-binding num-anc)
(define (draft:arglist->ns+na arglst)
  (let loop ((arglst arglst)
             (ns-binding '())
             (num-anc 0))
    (cond
      ((null? arglst) (values ns-binding num-anc))
      ((pair? (car arglst))
       (loop (cdr arglst) (car arglst) num-anc))
      ((number? (car arglst))
       (loop (cdr arglst) ns-binding
             (if (negative? (car arglst)) #f (car arglst))))
      (else
       (loop (cdr arglst) ns-binding num-anc)))))

draft:api-helper

Index
 Helper for constructing several highest-level API functions
(define (draft:api-helper grammar-parser ast-parser)
  (lambda (xpath-string . ns+na)
    (call-with-values
     (lambda () (draft:arglist->ns+na ns+na))
     (lambda (ns-binding num-anc)
       (and-let*
        ((ast (grammar-parser xpath-string ns-binding))
         (impl-lst (ast-parser ast num-anc)))
        (let ((res (car impl-lst)))
          (lambda (node . var-binding)
            ((if (and num-anc (zero? num-anc))
                 draft:contextset->nodeset
                 (lambda (x) x))             
             (res (as-nodeset node) (cons 1 1)
                  ;(xlink:add-docs-to-vars
                  ; node
                  (if (null? var-binding)
                      var-binding (car var-binding))
                  ; )
                  )))))))))

draft:xpath

Index
(define draft:xpath (draft:api-helper txp:xpath->ast draft:ast-location-path))

draft:xpointer

Index
(define draft:xpointer (draft:api-helper txp:xpointer->ast draft:ast-xpointer))

draft:xpath-expr

Index
(define draft:xpath-expr (draft:api-helper txp:expr->ast draft:ast-expr))

draft:sxpath

Index
(define draft:sxpath (draft:api-helper txp:sxpath->ast draft:ast-expr))

txpath-with-context

Index
 Aliases
(define txpath-with-context draft:xpath)

txpath/c

Index
(define txpath/c draft:xpath)

sxpath-with-context

Index
(define sxpath-with-context draft:sxpath)

sxpath/c

Index
(define sxpath/c draft:sxpath)

sxml:context->node-u

Index
 Fast however unsafe accessors
 Assume that the argument is the proper context
(define sxml:context->node-u cadr)

sxml:context->ancestors-u

Index
(define sxml:context->ancestors-u cddr)

sxml:context->content-u

Index
(define sxml:context->content-u cdr)

sxml:context->node

Index
 Safe accessors
 Can be applied to both a context and an ordinary node
(define (sxml:context->node context)
  (if (sxml:context? context) (cadr context) context))

sxml:context->ancestors

Index
(define (sxml:context->ancestors context)
  (if (sxml:context? context) (cddr context) '()))

sxml:context->content

Index
(define (sxml:context->content context)
  (if (sxml:context? context) (cdr context) (list context)))

draft:contextset->nodeset

Index
 Given a context-set, converts it to a nodeset
(define (draft:contextset->nodeset obj)
  (if (nodeset? obj)
      (map sxml:context->node obj)
      obj))

draft:make-context

Index
 Constructor
(define (draft:make-context node ancestors)
  (cons '*CONTEXT* (cons node ancestors)))

draft:smart-make-context

Index
 A smarter constructor
 Makes context only when required, with the 'num-anc' required
(define (draft:smart-make-context node ancestors num-anc)
  (if
   (or (and num-anc (zero? num-anc))
       (null? ancestors))
   node  ; no need for context construction
   (cons '*CONTEXT*
         (cons node
               (draft:list-head ancestors num-anc)))))

draft:siblings->context-set

Index
 Provided a 'nodeset' of sibling nodes, wraps each into context
 If 'ancestors' is empty, keeps 'nodeset' unchanged
(define (draft:siblings->context-set nodeset ancestors)
  (if (null? ancestors)
      nodeset
      (map
       (lambda (node) (draft:make-context node ancestors))
       nodeset)))

draft:na+

Index
(define (draft:na+ na1 na2)
  (if
   (or (not na1) (not na2)) ; either argument is infinite
   #f
   (+ na1 na2)))

draft:na-minus

Index
(define (draft:na-minus na value)
  (if (not na) na (- na value)))

draft:na-minus-nneg

Index
 Minus, with the result that is always non-negative
(define (draft:na-minus-nneg na value)
  (cond
    ((not na) na)
    ((< (- na value) 0) 0)
    (else (- na value))))

draft:na-max

Index
(define (draft:na-max . na-lst)
  (cond
    ((null? na-lst) 0)
    ((member #f na-lst) #f)
    (else (apply max na-lst))))

draft:na-min

Index
(define (draft:na-min . na-lst)
  (if
   (null? na-lst) 0
   (let ((num-lst (filter (lambda (x) x) na-lst)))
     (if (null? num-lst) #f  ; all na-lst consists of #f
         (apply min num-lst)))))

draft:na>

Index
(define (draft:na> na1 na2)
  (cond
   ((not na2) ; second argument in infinite
    #f)
   ((not na1) ; first argument is infinite
    #t)
   (else  ; niether argument is infinite
    (> na1 na2))))

draft:na>=

Index
(define (draft:na>= na1 na2)
  (cond
   ((not na2) ; second argument in infinite
    (not na1))  
   ((not na1) ; first argument is infinite
    #t)
   (else  ; niether argument is infinite
    (>= na1 na2))))

draft:find-proper-context

Index
 Makes a context-set from a nodeset supplied, with the num-anc required
  ancestors-set ::= (listof ancestors)
  ancestors ::= (listof node)
 Members of the nodeset are known to be descendants-or-selves of
 (map car ancestors-set)
(define (draft:find-proper-context nodeset ancestors-set num-anc)
  (map
   (lambda (node)
     (if
      (sxml:context? node)  ; already a context
      node  ; nothing to be done  
      (let loop ((this-level ancestors-set)
                 (next-level '()))
        (if
         (null? this-level)  ; this level fully analyzed
         (if (null? next-level)  ; failed to find
             node
             (loop next-level '()))
         (let ((ancestors (car this-level)))
           (if
            (eq? node (car ancestors))  ; proper ancestors found
            (draft:make-context
             node
             (draft:list-head (cdr ancestors) num-anc))
            (loop (cdr this-level)
                  (append
                   (map
                    (lambda (n) (cons n ancestors))
                    ((sxml:child sxml:node?) (car ancestors)))
                   (map
                    (lambda (n) (cons n ancestors))
                    ((sxml:attribute (lambda (x) #t)) (car ancestors)))
                   next-level))))))))
   nodeset))

draft:core-last

Index
 last()
(define (draft:core-last num-anc)
  (lambda (nodeset position+size var-binding)
    (cdr position+size)))

draft:core-position

Index
 position()
(define (draft:core-position num-anc)
  (lambda (nodeset position+size var-binding)
    (car position+size)))

draft:core-count

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

draft:core-id

Index
 id(object)
(define (draft:core-id num-anc arg-func) 
  (lambda (nodeset position+size var-binding)    
    (let* ((root-node (draft:reach-root nodeset))
           (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
       (let ((res ((sxml:id (cdar id-nset))  ; implemented in "sxpath-ext.scm"
                   (draft:contextset->nodeset
                    (arg-func nodeset position+size var-binding)))))
         (if (and num-anc (zero? num-anc))  ; no ancestors required
             res
             (draft:recover-contextset res root-node num-anc)))))))

draft:core-local-name

Index
 local-name(node-set?)
(define (draft:core-local-name num-anc . arg-func)  ; optional argument 
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (let ((nodeset (draft:contextset->nodeset nodeset)))
          (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 position+size var-binding)          
          (let ((obj
                 (draft:contextset->nodeset
                  (func nodeset position+size 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))))))))))

draft:core-namespace-uri

Index
 namespace-uri(node-set?)
(define (draft:core-namespace-uri num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (let ((nodeset (draft:contextset->nodeset nodeset)))
          (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 position+size var-binding)          
          (let ((obj
                 (draft:contextset->nodeset
                  (func nodeset position+size 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 ""))))))))))

draft:core-name

Index
 name(node-set?)
(define (draft:core-name num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (let ((nodeset (draft:contextset->nodeset nodeset)))
          (cond
            ((null? nodeset) "")
            ((not (pair? (car nodeset))) "")  ; no name
            (else
             (symbol->string (caar nodeset))))))
      (let ((func (car arg-func)))
        (lambda (nodeset position+size var-binding)          
          (let ((obj
                 (draft:contextset->nodeset
                  (func nodeset position+size 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)))))))))

draft:core-string

Index
 string(object?)
(define (draft:core-string num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (sxml:string
         (draft:contextset->nodeset nodeset)))
      (let ((func (car arg-func)))
        (lambda (nodeset position+size var-binding)
          (sxml:string
           (draft:contextset->nodeset
            (func nodeset position+size var-binding)))))))

draft:core-concat

Index
 concat(string, string, string*)
(define (draft:core-concat num-anc . arg-func-lst)
  (lambda (nodeset position+size var-binding)
    (apply
     string-append
     (map
      (lambda (f)
        (sxml:string
         (draft:contextset->nodeset
          (f nodeset position+size var-binding))))
      arg-func-lst))))

draft:core-starts-with

Index
 starts-with(string, string)
(define (draft:core-starts-with num-anc arg-func1 arg-func2)
  (lambda (nodeset position+size var-binding)
    (let ((str1 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func1 nodeset position+size var-binding))))
          (str2 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func2 nodeset position+size var-binding)))))
      (string-prefix? str2 str1))))

draft:core-contains

Index
 contains(string, string)
(define (draft:core-contains num-anc arg-func1 arg-func2)
  (lambda (nodeset position+size var-binding)
    (let ((str1 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func1 nodeset position+size var-binding))))
          (str2 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func2 nodeset position+size var-binding)))))
      (if (substring? str2 str1) #t #f)  ; must return a boolean
      )))

draft:core-substring-before

Index
 substring-before(string, string)
(define (draft:core-substring-before num-anc arg-func1 arg-func2)
  (lambda (nodeset position+size var-binding)
    (let* ((str1 (sxml:string
                  (draft:contextset->nodeset
                   (arg-func1 nodeset position+size var-binding))))
           (str2 (sxml:string
                  (draft:contextset->nodeset
                   (arg-func2 nodeset position+size var-binding))))
           (pos (substring? str2 str1)))
      (if (not pos)  ; STR1 doesn't contain STR2
          ""
          (substring str1 0 pos)))))

draft:core-substring-after

Index
 substring-after(string, string)
(define (draft:core-substring-after num-anc arg-func1 arg-func2)
  (lambda (nodeset position+size var-binding)
    (let* ((str1 (sxml:string
                  (draft:contextset->nodeset
                   (arg-func1 nodeset position+size var-binding))))
           (str2 (sxml:string
                  (draft:contextset->nodeset
                   (arg-func2 nodeset position+size var-binding))))
           (pos (substring? str2 str1)))
      (if
       (not pos)  ; STR1 doesn't contain STR2
       ""
       (substring
        str1 (+ pos (string-length str2)) (string-length str1))))))

draft:core-substring

Index
 substring(string, number, number?)
(define (draft:core-substring num-anc arg-func1 arg-func2 . arg-func3)
  (if (null? arg-func3)  ; no third argument supplied
      (lambda (nodeset position+size var-binding)
        (let ((str (sxml:string
                    (draft:contextset->nodeset
                     (arg-func1 nodeset position+size var-binding))))
              (num1 (sxml:number
                     (draft:contextset->nodeset
                      (arg-func2 nodeset position+size 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 position+size var-binding)
          (let ((str (sxml:string
                      (draft:contextset->nodeset
                       (arg-func1 nodeset position+size var-binding))))
                (num1 (sxml:number
                       (draft:contextset->nodeset
                        (arg-func2 nodeset position+size var-binding))))
                (num2 (sxml:number
                       (draft:contextset->nodeset
                        (arg-func3 nodeset position+size 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)))))))))

draft:core-string-length

Index
 string-length(string?)
(define (draft:core-string-length num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (string-length
         (sxml:string (draft:contextset->nodeset nodeset))))
      (let ((func (car arg-func)))
        (lambda (nodeset position+size var-binding)
          (string-length
           (sxml:string
            (draft:contextset->nodeset
             (func nodeset position+size var-binding))))))))

draft:core-normalize-space

Index
 normalize-space(string?)
(define (draft:core-normalize-space num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (let rpt ((src (string-split
                        (sxml:string (draft:contextset->nodeset 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 position+size var-binding)
          (let rpt ((src (string-split
                          (sxml:string
                           (draft:contextset->nodeset
                            (func nodeset position+size 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))))))))))

draft:core-translate

Index
 translate(string, string, string)
(define (draft:core-translate num-anc arg-func1 arg-func2 arg-func3)
  (lambda (nodeset position+size var-binding)    
    (let ((str1 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func1 nodeset position+size var-binding))))
          (str2 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func2 nodeset position+size var-binding))))
          (str3 (sxml:string
                 (draft:contextset->nodeset
                  (arg-func3 nodeset position+size 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)))))))))

draft:core-boolean

Index
 boolean(object)
(define (draft:core-boolean num-anc arg-func)
  (lambda (nodeset position+size var-binding)
    (sxml:boolean
     (arg-func nodeset position+size var-binding))))

draft:core-not

Index
 not(boolean)
(define (draft:core-not num-anc arg-func)
  (lambda (nodeset position+size var-binding)
    (not (sxml:boolean 
          (arg-func nodeset position+size var-binding)))))

draft:core-true

Index
 true()
(define (draft:core-true num-anc)
  (lambda (nodeset position+size var-binding) #t))

draft:core-false

Index
 false()
(define (draft:core-false num-anc)
  (lambda (nodeset position+size var-binding) #f))

draft:core-lang

Index
 lang(string)
(define (draft:core-lang num-anc arg-func)
  (lambda (nodeset position+size var-binding)    
    (let ((arg (sxml:string
                (draft:contextset->nodeset
                 (arg-func nodeset position+size var-binding))))
          (lng
           ((draft:child (ntype?? '*text*))
            ((draft:attribute (ntype?? 'xml:lang))
             ((draft:ancestor-or-self (lambda (x) #t))
              (car nodeset)  ; context-node = (car nodeset)
              )))))
      (and (not (null? lng))
           (or (string-ci=? arg (car lng))
               (string-prefix-ci? (string-append arg "-") (car lng)))))))       

draft:core-number

Index
 number(object?)
(define (draft:core-number num-anc . arg-func)  ; optional argument
  (if (null? arg-func)  ; no argument supplied
      (lambda (nodeset position+size var-binding)
        (sxml:number (draft:contextset->nodeset nodeset)))
      (let ((func (car arg-func)))
        (lambda (nodeset position+size var-binding)
          (sxml:number
           (draft:contextset->nodeset
            (func nodeset position+size var-binding)))))))

draft:core-sum

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

draft:core-floor

Index
 floor(number)
(define (draft:core-floor num-anc arg-func)
  (lambda (nodeset position+size var-binding)
    (inexact->exact
     (floor (sxml:number
             (draft:contextset->nodeset
              (arg-func nodeset position+size var-binding)))))))

draft:core-ceiling

Index
 ceiling(number)
(define (draft:core-ceiling num-anc arg-func)
  (lambda (nodeset position+size var-binding)
    (inexact->exact
     (ceiling (sxml:number
               (draft:contextset->nodeset
                (arg-func nodeset position+size var-binding)))))))

draft:core-round

Index
 round(number)
(define (draft:core-round num-anc arg-func)
  (lambda (nodeset position+size var-binding)
    (inexact->exact
     (round (sxml:number
             (draft:contextset->nodeset
              (arg-func nodeset position+size var-binding)))))))

draft:ast-location-path

Index
 {1} <LocationPath> ::= <RelativeLocationPath>
                        | <AbsoluteLocationPath>
(define (draft:ast-location-path op num-anc)
  (case (car op)
    ((absolute-location-path)
     (draft:ast-absolute-location-path op num-anc))
    ((relative-location-path)
     (draft:ast-relative-location-path op num-anc))
    (else
     (draft:signal-semantic-error "improper LocationPath - " op))))

draft:ast-absolute-location-path

Index
 {2} <AbsoluteLocationPath> ::= (absolute-location-path  <Step>* )
(define (draft:ast-absolute-location-path op num-anc)
  (cond
    ((not (eq? (car op) 'absolute-location-path))
     (draft:signal-semantic-error "not an AbsoluteLocationPath - " op))
    ((null? (cdr op))  ; no Steps
     (cons
      (lambda (nodeset position+size var-binding)
        (draft:reach-root nodeset))
      #f))
    (else
     (and-let*
      ((steps-res (draft:ast-step-list (cdr op) num-anc)))
      (cons
       (if
        (null? (cdar steps-res))  ; only a single step
        (let ((step-impl (caar steps-res)))
          (lambda (nodeset position+size var-binding)
            (step-impl
             (draft:reach-root nodeset) position+size var-binding)))
        (let ((converters (car steps-res)))
          (lambda (nodeset position+size var-binding)
            (let rpt ((nset (draft:reach-root nodeset))
                      (fs converters))
              (if (null? fs)
                  nset
                  (rpt ((car fs) nset position+size var-binding)
                       (cdr fs)))))))
       #f)))))

draft:ast-relative-location-path

Index
 {3} <RelativeLocationPath> ::= (relative-location-path  <Step>+ )
(define (draft:ast-relative-location-path op num-anc)
  (if
   (not (eq? (car op) 'relative-location-path))
   (draft:signal-semantic-error "not a RelativeLocationPath - " op)
   (and-let*
    ((steps-res (draft:ast-step-list (cdr op) num-anc)))
    (cons
     (if
      (null? (cdar steps-res))  ; only a single step
      (caar steps-res)
      (let ((converters (car steps-res)))
        (lambda (nodeset position+size var-binding)
          (let rpt ((nset nodeset)
                    (fs converters))
            (if (null? fs)
                nset
                (rpt ((car fs) nset position+size var-binding)
                     (cdr fs)))))))
     (cdr steps-res)))))

draft:ast-step

Index
 {4} <Step> ::= (step  <AxisSpecifier> <NodeTest> <Predicate>* )
                | (range-to  (expr <Expr>)  <Predicate>* )
(define (draft:ast-step op num-anc)
  (cond
    ((eq? (car op) 'range-to)
     (draft:signal-semantic-error "range-to function not implemented"))
    ((eq? (car op) 'filter-expr)  ; can be produced by sxpath
     (draft:ast-filter-expr op num-anc))
    ((eq? (car op) 'lambda-step)  ; created by sxpath
     (cons
      (let ((proc (cadr op)))
        (if
         (and num-anc (zero? num-anc))  ; no ancestors required
         (lambda (node position+size var-binding)
           (proc (draft:contextset->nodeset (as-nodeset node))
                 var-binding))
         (lambda (node position+size var-binding)
           (draft:find-proper-context
            (proc (draft:contextset->nodeset (as-nodeset node))
                  var-binding)
            (append
             (map sxml:context->content (as-nodeset node))
             (apply append   ; nodes that can be obtained through var values
                    (map
                     (lambda (pair)
                       (if (nodeset? (cdr pair))
                           (map sxml:context->content (cdr pair))
                           '()))
                     var-binding)))
            num-anc))))
      num-anc))
    ((eq? (car op) 'step)
     (if
      (null? (cdddr op))  ; no Predicates
      (and-let*
       ((axis-lst (draft:ast-axis-specifier (cadr op) num-anc))
        (ntest (draft:ast-node-test (caddr op))))
       (let ((axis ((car axis-lst) ntest num-anc)))
         (cons
          (if (caddr axis-lst)  ; var-binding is to be passed
              (lambda (nodeset position+size var-binding)
                (axis nodeset var-binding))
              (lambda (nodeset position+size var-binding)
                (axis nodeset)))
          (cadr axis-lst))))
      (and-let*
       ((preds-res (draft:ast-predicate-list (cdddr op) 0))
        (axis-lst (draft:ast-axis-specifier
                   (cadr op) (draft:na-max num-anc (cdr preds-res))))
        (ntest (draft:ast-node-test (caddr op))))
       (let ((axis ((car axis-lst)
                    ntest (draft:na-max num-anc (cdr preds-res))))
             (pred-impl-lst (car preds-res)))
         (cons
          (if
           (caddr axis-lst)  ; variables are to be passed to the axis
           (lambda (nodeset position+size var-binding)
             (map-union
              (lambda (node)
                (let loop ((nset (axis node var-binding))
                           (preds pred-impl-lst))
                  (if
                   (null? preds)
                   nset
                   (loop ((car preds) nset position+size var-binding)
                         (cdr preds)))))
              nodeset))
           (lambda (nodeset position+size var-binding)
             (map-union
              (lambda (node)
                (let loop ((nset (axis node))
                           (preds pred-impl-lst))
                  (if
                   (null? preds)
                   nset
                   (loop ((car preds) nset position+size var-binding)
                         (cdr preds)))))
              nodeset)))
          (cadr axis-lst))))))
    (else
     (draft:signal-semantic-error "not a Step - " op))))

draft:ast-step-list

Index
 {4a} ( <Step>+ )
 Returns (cons (listof step-impl) num-anc) or #f
(define (draft:ast-step-list step-lst num-anc)
  (let loop ((steps-to-view (reverse step-lst))
             (res-lst '())
             (num-anc num-anc))
    (if
     (null? steps-to-view)  ; everyone processed
     (cons res-lst num-anc)
     (and-let*
      ((step-res (draft:ast-step (car steps-to-view) num-anc)))
      (loop
       (cdr steps-to-view)
       (cons (car step-res) res-lst)
       (cdr step-res))))))

draft:ast-predicate

Index
 {8} <Predicate> ::= (predicate  <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for Predicates
(define (draft:ast-predicate op num-anc)
  (if
   (not (eq? (car op) 'predicate))
   (draft:signal-semantic-error "not an Predicate - " op)
   (and-let*
    ((expr-res (draft:ast-expr (cadr op) 0)))
    (let ((pred (car expr-res)))
      (cons
       (lambda (nodeset position+size var-binding)         
         (if
          (null? nodeset)  ; already empty
          nodeset  ; nothing to filter
          (let ((size (length nodeset)))  ; context size              
            (let loop ((nset nodeset)
                       (res '())
                       (pos 1))
              (if
               (null? nset)
               (reverse res)
               (let ((value (pred (list (car nset))
                                  (cons pos size)
                                  var-binding)))
                 (loop (cdr nset)
                       (if (if (number? value)
                               (= value pos)
                               (sxml:boolean value))
                           (cons (car nset) res)
                           res)
                       (+ pos 1))))))))
       (cdr expr-res))))))

draft:ast-predicate-list

Index
 {8a} ( <Predicate>+ )
 Returns (cons (listof pred-impl) num-anc) or #f
 NOTE: num-anc is dummy here, since it is always 0 for Predicates
(define (draft:ast-predicate-list op-lst num-anc)  
  (let ((pred-res-lst
         (map
          (lambda (op) (draft:ast-predicate op 0))
          op-lst)))
    (if
     (member #f pred-res-lst)  ; error detected
     #f
     (cons
      (map car pred-res-lst)
      (apply draft:na-max (map cdr pred-res-lst))))))

draft:ast-expr

Index
 {9} <Expr> ::= <OrExpr>
                | <AndExpr>
                | <EqualityExpr>
                | <RelationalExpr>
                | <AdditiveExpr>
                | <MultiplicativeExpr>
                | <UnionExpr>
                | <PathExpr>
                | <FilterExpr>
                | <VariableReference>
                | <Literal>
                | <Number>
                | <FunctionCall>
                | <LocationPath>
(define (draft:ast-expr op num-anc)
  (case (car op)
    ((or)
     (draft:ast-or-expr op num-anc))
    ((and)
     (draft:ast-and-expr op num-anc))
    ((= !=)
     (draft:ast-equality-expr op num-anc))
    ((< > <= >=)
     (draft:ast-relational-expr op num-anc))
    ((+ -)
     (draft:ast-additive-expr op num-anc))
    ((* div mod)
     (draft:ast-multiplicative-expr op num-anc))
    ((union-expr)
     (draft:ast-union-expr op num-anc))
    ((path-expr)
     (draft:ast-path-expr op num-anc))
    ((filter-expr)
     (draft:ast-filter-expr op num-anc))
    ((variable-reference)
     (draft:ast-variable-reference op num-anc))
    ((literal)
     (draft:ast-literal op num-anc))
    ((number)
     (draft:ast-number op num-anc))
    ((function-call)
     (draft:ast-function-call op num-anc))
    ((absolute-location-path)
     (draft:ast-absolute-location-path op num-anc))
    ((relative-location-path)
     (draft:ast-relative-location-path op num-anc))
    (else
     (draft:signal-semantic-error "unknown Expr - " op))))

draft:ast-or-expr

Index
 {10} <OrExpr> ::= (or <Expr> <Expr>+ )
 NOTE: num-anc is dummy here, since it is always 0 for OrExpr
(define (draft:ast-or-expr op num-anc)
  (let ((expr-res-lst
         (map
          (lambda (expr) (draft:ast-expr expr 0))
          (cdr op))))
    (if
     (member #f expr-res-lst)  ; error detected
     #f
     (let ((expr-impls (map car expr-res-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (let rpt ((fs expr-impls))
          (cond
            ((null? fs) #f)
            ((sxml:boolean ((car fs) nodeset position+size var-binding)) #t)
            (else (rpt (cdr fs))))))
      (apply draft:na-max (map cdr expr-res-lst)))))))

draft:ast-and-expr

Index
 {11} <AndExpr> ::= (and <Expr> <Expr>+ )
 NOTE: num-anc is dummy here, since it is always 0 for AndExpr
(define (draft:ast-and-expr op num-anc)
  (let ((expr-res-lst
         (map
          (lambda (expr) (draft:ast-expr expr 0))
          (cdr op))))
    (if
     (member #f expr-res-lst)  ; error detected
     #f
     (let ((expr-impls (map car expr-res-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (let rpt ((fs expr-impls))
          (cond
            ((null? fs) #t)
            ((not
              (sxml:boolean ((car fs) nodeset position+size var-binding)))
             #f)
            (else (rpt (cdr fs))))))
      (apply draft:na-max (map cdr expr-res-lst)))))))

draft:ast-equality-expr

Index
 {12} <EqualityExpr> ::= (=  <Expr> <Expr> )
                         | (!=  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for EqualityExpr
(define (draft:ast-equality-expr op num-anc)
  (and-let*
   ((left-lst (draft:ast-expr (cadr op) 0))
    (right-lst (draft:ast-expr (caddr op) 0)))
   (let ((cmp-op (cadr (assq (car op) `((= ,sxml:equal?)
                                        (!= ,sxml:not-equal?)))))
         (left (car left-lst))
         (right (car right-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (cmp-op
         (draft:contextset->nodeset
          (left nodeset position+size var-binding))
         (draft:contextset->nodeset
          (right nodeset position+size var-binding))))
      (draft:na-max (cdr left-lst) (cdr right-lst))))))

draft:ast-relational-expr

Index
 {13} <RelationalExpr> ::= (<  <Expr> <Expr> )
                           | (>  <Expr> <Expr> )
                           | (<=  <Expr> <Expr> )
                           | (>=  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for RelationalExpr
(define (draft:ast-relational-expr op num-anc)
  (and-let*
   ((left-lst (draft:ast-expr (cadr op) 0))
    (right-lst (draft:ast-expr (caddr op) 0)))
   (let ((cmp-op
          (sxml:relational-cmp
           (cadr (assq (car op) `((< ,<) (> ,>) (<= ,<=) (>= ,>=))))))
         (left (car left-lst))
         (right (car right-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (cmp-op
         (draft:contextset->nodeset
          (left nodeset position+size var-binding))
         (draft:contextset->nodeset
          (right nodeset position+size var-binding))))
      (draft:na-max (cdr left-lst) (cdr right-lst))))))

draft:ast-additive-expr

Index
 {14} <AdditiveExpr> ::= (+  <Expr> <Expr> )
                         | (-  <Expr> <Expr>? )
 NOTE: num-anc is dummy here, since it is always 0 for AdditiveExpr
(define (draft:ast-additive-expr op num-anc)
  (let ((expr-res-lst
         (map
          (lambda (expr) (draft:ast-expr expr 0))
          (cdr op))))
    (if
     (member #f expr-res-lst)  ; error detected
     #f
     (let ((add-op (cadr (assq (car op) `((+ ,+) (- ,-)))))
           (expr-impls (map car expr-res-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (apply
         add-op
         (map
          (lambda (expr)
            (sxml:number
             (draft:contextset->nodeset
              (expr nodeset position+size var-binding))))
          expr-impls)))
      (apply draft:na-max (map cdr expr-res-lst)))))))

draft:ast-multiplicative-expr

Index
 {15} <MultiplicativeExpr> ::= (*  <Expr> <Expr> )
                               | (div  <Expr> <Expr> )
                               | (mod  <Expr> <Expr> )
 NOTE: num-anc is dummy here, since it is always 0 for MultiplicativeExpr
(define (draft:ast-multiplicative-expr op num-anc)
  (and-let*
   ((left-lst (draft:ast-expr (cadr op) 0))
    (right-lst (draft:ast-expr (caddr op) 0)))
   (let ((mul-op
          (cadr (assq (car op) `((* ,*) (div ,/) (mod ,remainder)))))
         (left (car left-lst))
         (right (car right-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (mul-op
         (sxml:number
          (draft:contextset->nodeset
           (left nodeset position+size var-binding)))
         (sxml:number
          (draft:contextset->nodeset
           (right nodeset position+size var-binding)))))
      (draft:na-max (cdr left-lst) (cdr right-lst))))))

draft:ast-union-expr

Index
 {16} <UnionExpr> ::= (union-expr  <Expr> <Expr>+ )
(define (draft:ast-union-expr op num-anc)
  (let ((expr-res-lst
         (map
          (lambda (expr) (draft:ast-expr expr 0))
          (cdr op))))
    (if
     (member #f expr-res-lst)  ; error detected
     #f
     (let ((expr-impls (map car expr-res-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (let rpt ((res '())
                  (fs expr-impls))
          (if
           (null? fs)
           res
           (let ((nset ((car fs) nodeset position+size var-binding)))
             (rpt
              (append 
               res
               (cond
                 ((not (nodeset? nset))
                  (sxml:xpointer-runtime-error 
                   "expected - nodeset instead of " nset)
                  '())
                 (else nset)))
              (cdr fs))))))
      (apply draft:na-max (map cdr expr-res-lst)))))))

draft:ast-path-expr

Index
 {17} <PathExpr> ::= (path-expr  <FilterExpr> <Step>+ )
(define (draft:ast-path-expr op num-anc)
  (and-let*
    ((steps-res (draft:ast-step-list (cddr op) num-anc))
     (filter-lst (draft:ast-filter-expr (cadr op) (cdr steps-res))))
    (let ((init-impl (car filter-lst))
          (converters (car steps-res)))
      (cons       
        (lambda (nodeset position+size var-binding)
          (let ((nset
                 (init-impl nodeset position+size var-binding)))
            (let rpt ((nset 
                       (cond
                         ((nodeset? nset) nset)
                         (else
                          (sxml:xpointer-runtime-error 
                           "expected - nodeset instead of " nset)
                          '())))
                      (fs converters))
              (if (null? fs)
                  nset
                  (rpt ((car fs) nset position+size var-binding)
                       (cdr fs))))))
        (cdr filter-lst)))))

draft:ast-filter-expr

Index
 {18} <FilterExpr> ::= (filter-expr (primary-expr  <Expr> )
                                    <Predicate>* )
(define (draft:ast-filter-expr op num-anc)
  (cond
    ((not (eq? (car op) 'filter-expr))
     (draft:signal-semantic-error "not an FilterExpr - " op))
    ((not (eq? (caadr op) 'primary-expr))
     (draft:signal-semantic-error "not an PrimaryExpr - " (cadr op)))
    ((null? (cddr op))  ; no Predicates
     (draft:ast-expr (cadadr op) num-anc))
    (else
     (and-let*
       ((preds-res (draft:ast-predicate-list (cddr op) 0))
        (expr-lst (draft:ast-expr
                   (cadadr op) (draft:na-max num-anc (cdr preds-res)))))
       (let ((expr-impl (car expr-lst))
             (pred-impl-lst (car preds-res)))
         (cons
          (lambda (nodeset position+size var-binding)
            (let ((prim-res (expr-impl nodeset position+size var-binding)))              
              (let loop ((nset (cond
                                 ((nodeset? prim-res) prim-res)
                                 (else 
                                  (sxml:xpointer-runtime-error 
                                   "expected - nodeset instead of " prim-res)
                                  '())))
                         (preds pred-impl-lst))
                (if
                 (null? preds)
                 nset
                 (loop ((car preds) nset position+size var-binding)
                       (cdr preds))))))
            (cdr expr-lst)))))))     

draft:ast-variable-reference

Index
 {19} <VariableReference> ::= (variable-reference  <String> )
(define (draft:ast-variable-reference op num-anc)
  (let ((name (string->symbol (cadr op))))
    (cons
     (lambda (nodeset position+size var-binding)
       (cond
         ((assoc name var-binding)
          => cdr)
         (else
          (sxml:xpointer-runtime-error "unbound variable - " name)
          '())))
     0)))

draft:ast-literal

Index
 {20} <Literal> ::= (literal  <String> )
(define (draft:ast-literal op num-anc)
  (let ((literal (cadr op)))
    (cons
     (lambda (nodeset position+size var-binding) literal)
     0)))

draft:ast-number

Index
 {21} <Number> :: (number  <Number> )
(define (draft:ast-number op num-anc)
  (let ((number (cadr op)))
    (cons
     (lambda (nodeset position+size var-binding) number)
     0)))

draft:ast-function-call

Index
 {22} <FunctionCall> ::= (function-call (function-name  <String> )
                                        (argument  <Expr> )* )
(define (draft:ast-function-call op num-anc)
  (let ((core-alist
         ; (list fun-name min-num-args max-num-args na4res impl)
         `((last 0 0 0 ,draft:core-last)
           (position 0 0 0 ,draft:core-position)
           (count 1 1 0 ,draft:core-count)
           (id 1 1 #f ,draft:core-id)
           (local-name 0 1 0 ,draft:core-local-name)
           (namespace-uri 0 1 0 ,draft:core-namespace-uri)
           (name 0 1 0 ,draft:core-name)
           (string 0 1 0 ,draft:core-string)
           (concat 2 -1 0 ,draft:core-concat)
           (starts-with 2 2 0 ,draft:core-starts-with)
           (contains 2 2 0 ,draft:core-contains)
           (substring-before 2 2 0 ,draft:core-substring-before)
           (substring-after 2 2 0 ,draft:core-substring-after)
           (substring 2 3 0 ,draft:core-substring)
           (string-length 0 1 0 ,draft:core-string-length)
           (normalize-space 0 1 0 ,draft:core-normalize-space)
           (translate 3 3 0 ,draft:core-translate)
           (boolean 1 1 0 ,draft:core-boolean)
           (not 1 1 0 ,draft:core-not)
           (true 0 0 0 ,draft:core-true)
           (false 0 0 0 ,draft:core-false)
           (lang 1 1 #f ,draft:core-lang)
           (number 0 1 0 ,draft:core-number)
           (sum 1 1 0 ,draft:core-sum)
           (floor 1 1 0 ,draft:core-floor)
           (ceiling 1 1 0 ,draft:core-ceiling)
           (round 1 1 0 ,draft:core-round))))
    (cond
      ((not (eq? (caadr op) 'function-name))
       (draft:signal-semantic-error "not an FunctionName - " (cadr op)))
      ((assq (string->symbol (cadadr op)) core-alist)       
       => (lambda (description)  ; Core function found
            (cond
              ((< (length (cddr op)) (cadr description))
               (draft:signal-semantic-error
                "too few arguments for the Core Function call - "
                (cadadr op)))
              ((and (>= (caddr description) 0)
                    (> (length (cddr op)) (caddr description)))
               (draft:signal-semantic-error
                "too many arguments for the Core Function call - "
                (cadadr op)))
              (else  ; correct number of arguments
               (and-let*
                ((args-impl (draft:ast-function-arguments (cddr op))))
                (cons
                 ; Producing a function implementation
                 (apply (list-ref description 4) num-anc args-impl)
                 (list-ref description 3)))))))
           (else  ; function definition not found
            (draft:signal-semantic-error
             "function call to an unknown function - " (cadadr op))))))

draft:ast-function-arguments

Index
 {22a} ( (argument  <Expr> )* )
 na-lst - number of ancestors required for each of the arguments
 Returns: (listof expr-impl) or #f
(define (draft:ast-function-arguments op-lst)
  (let ((arg-res-lst
         (map
          (lambda (op)
            (if
             (not (eq? (car op) 'argument))
             (draft:signal-semantic-error "not an Argument - " op)
             (draft:ast-expr (cadr op) 0)))
          op-lst)))
    (if
     (member #f arg-res-lst)  ; semantic error detected
     #f
     (map car arg-res-lst))))

draft:ast-xpointer

Index
 {25} <XPointer> ::= <ChildSeq>
                     | <FullXPtr>
                     | <Expr>
(define (draft:ast-xpointer op num-anc)    
  (case (car op)
    ((child-seq)
     (draft:ast-child-seq op num-anc))
    ((full-xptr)
     (draft:ast-full-xptr op num-anc))
    (else
     (draft:ast-expr op num-anc))))

draft:ast-child-seq

Index
 {26} <ChildSeq> ::= (child-seq (name  <String> ))
                     | (child-seq (name  <String> )?
                                  (number  <Number> )+ )
(define (draft:ast-child-seq op num-anc)
  (if
   (eq? (caadr op) 'name)
   (and-let*
    ((numbers-res (draft:ast-number-list (cddr op) num-anc)))
    (let ((id-value (cadadr op))
          (converters (car numbers-res))
          (num-ancestors (cdr numbers-res)))
      (cons
       (lambda (nodeset position+size var-binding)
         (let* ((root-node (draft:reach-root nodeset))
                (id-nset ((sxml:child (ntype?? 'id-index))
                          ((sxml:child (ntype?? '@@)) root-node))))
           (if
            (null? id-nset)  ; no id-index
            '()
            (let ((nd (sxml:lookup id-value (cdar id-nset))))
              (if (not nd)
                  '()
                  (let rpt ((nset 
                             (if (and num-ancestors (zero? num-ancestors))
                                 (list nd)
                                 (draft:recover-contextset
                                  (list nd) root-node num-ancestors)))
                            (fs converters))
                    (if (null? fs)
                        nset
                        (rpt ((car fs) nset) (cdr fs)))))))))
       #f)))
   (and-let*
    ((numbers-res (draft:ast-number-list (cdr op) num-anc)))
    (let ((converters (car numbers-res)))
      (cons
       (lambda (nodeset position+size var-binding)
         (let ((child-seq-impl
                (lambda (node)
                  (let rpt ((nset nodeset) (fs converters))
                    (if (null? fs)
                        nset
                        (rpt ((car fs) nset) (cdr fs)))))))
           (if (nodeset? nodeset)
               (map-union child-seq-impl nodeset)
               (child-seq-impl nodeset))))
       (cdr numbers-res))))))

draft:ast-number-list

Index
 {26a} ( (number  <Number> )+ )
 Returns (cons (listof sxpath-converter) num-anc) or #f
(define (draft:ast-number-list number-lst num-anc)
  (let loop ((to-view (reverse number-lst))
             (res-lst '())
             (num-anc num-anc))
    (cond
      ((null? to-view)  ; everyone processed
       (cons res-lst num-anc))
      ((not (eq? (caar to-view) 'number))
       (draft:signal-semantic-error "not an Number - " (car to-view)))
      (else       
       (loop
        (cdr to-view)        
        (cons (draft:child (ntype?? '*) num-anc)
              (cons (node-pos (cadar to-view))
                    res-lst))
        (draft:na-minus-nneg num-anc 1))))))

draft:ast-full-xptr

Index
 {27} <FullXPtr> ::= (full-xptr  <Expr> <Expr>+ )
(define (draft:ast-full-xptr op num-anc)
  (let ((expr-res-lst
         (map
          (lambda (expr) (draft:ast-expr expr 0))
          (cdr op))))
    (if
     (member #f expr-res-lst)  ; error detected
     #f
     (let ((expr-impls (map car expr-res-lst)))
     (cons
      (lambda (nodeset position+size var-binding)
        (let rpt ((fs expr-impls))
          (if (null? fs)
              '()
              (let ((nset ((car fs) nodeset position+size var-binding)))
                (if (null? nset)
                    (rpt (cdr fs))
                    nset)))))        
      (apply draft:na-max (map cdr expr-res-lst)))))))