X-Git-Url: http://git.nguyen.vg/gitweb/?p=tatoo.git;a=blobdiff_plain;f=src%2Fxpath%2Fcompile.ml;fp=src%2Fxpath%2Fcompile.ml;h=783d7f182f449b3fafbdafd90d3f7c4c000c9ea2;hp=a84a50f3d1358770715c171f032a4a3cb45c2211;hb=e13f5deae217f945b44fa345ef4f0008e1780787;hpb=fadcbf2f6f9f33b844fd5e875a1bda4bed446a43 diff --git a/src/xpath/compile.ml b/src/xpath/compile.ml index a84a50f..783d7f1 100644 --- a/src/xpath/compile.ml +++ b/src/xpath/compile.ml @@ -14,7 +14,7 @@ (***********************************************************************) (* - Time-stamp: + Time-stamp: *) open Ast @@ -30,73 +30,119 @@ let ( ++ ) a b = Ata.SFormula.or_ a b let ( %% ) a b = Ata.SFormula.and_ a b let ( @: ) a b = StateSet.add a b +(* [compile_axis_test axis test q phi trans states] Takes an xpath + [axis] and node [test], a formula [phi], a list of [trans]itions + and a set of [states] and returns a formula [phi'], a new set of + transitions, and a new set of states such that [phi'] holds iff + there exists a node reachable through [axis]::[test] where [phi] + holds. +*) -let compile_axis_test ax tst inq trs sts = - match ax with - | Self -> - let outq = State.make () in - outq, - (inq, [ tst => (`Epsilon ** outq ) ]) :: trs, - outq @: sts +let compile_axis_test axis test phi trans states = + let q = State.make () in + let phi, trans, states = + match axis with + | Self -> + (`Epsilon ** q), + (q, [ test => phi ]) :: trans, + states - | Child -> - let outq = State.make () in - let outq' = State.make () in - outq', - (inq, [ QNameSet.any => (`Left ** outq)]) - :: (outq, [ tst => (`Epsilon ** outq'); - QNameSet.any => (`Right ** outq) ]) - :: trs, - outq @: (outq' @: sts) + | Child -> + (`Left ** q), + (q, [ test => phi; + QNameSet.any => (`Right ** q) ]) :: trans, + states - | Descendant | DescendantOrSelf -> - let dir = if ax = Descendant then `Left else `Epsilon in - let outq = State.make () in - let outq' = State.make () in - outq', - (inq, [ QNameSet.any => (dir ** outq)]) - :: (outq, [ tst => (`Epsilon ** outq'); - QNameSet.any => ((`Left ** outq) ++ (`Right ** outq)) - ]) - :: trs, - outq @: (outq' @: sts) + | Descendant self -> + (if self then (`Epsilon ** q) else (`Left ** q)), + (q, [ test => phi; + QNameSet.any => (`Left ** q) %% (`Right ** q) ]) :: trans, + states - | Parent -> - let outq = State.make () in - let outq' = State.make () in - let outq'' = State.make () in - let move = (`Up1 ** outq') ++ (`Up2 ** outq) in - outq'', - (inq, [QNameSet.any => move ]) - :: (outq, [ QNameSet.any => move ]) - :: (outq', [ tst => (`Epsilon ** outq'') ]) - :: trs, - outq @: (outq' @: (outq'' @: sts)) + | Parent -> + let q' = State.make () in + let move = (`Up1 ** q) ++ (`Up2 ** q') in + move, + (q, [ test => phi ]) + :: (q', [ QNameSet.any => move ]) :: trans, + (q' @: states) - | Ancestor | AncestorOrSelf -> - let outq = State.make () in - let outq' = State.make () in - let outq'' = State.make () in - let move = - (if ax = Ancestor then (`Up1 ** outq') - else (`Epsilon ** outq')) ++ (`Up1 ** outq) ++ (`Up2 ** outq) - in - outq'', - (inq, [QNameSet.any => move ]) - :: (outq, [ QNameSet.any => move ]) - :: (outq', [ tst => (`Epsilon ** outq'') ]) - :: trs, - outq @: (outq' @: (outq'' @: sts)) + | Ancestor self -> + let q' = State.make () in + let move = (`Up1 ** q) ++ (`Up2 ** q') in + (if self then (`Epsilon ** q) else move), + (q, [ test => phi; + QNameSet.any => move ]) + :: (q', [ QNameSet.any => move ]) :: trans, + (q' @: states) + + | FollowingSibling | PrecedingSibling -> + let move = + if axis = PrecedingSibling then + (`Up2 ** q) + else (`Right ** q) + in + move, + (q, [ test => phi; + QNameSet.any => move ]) :: trans, + states - | FollowingSibling | PrecedingSibling -> - let outq = State.make () in - let outq' = State.make () in - let dir = if ax = FollowingSibling then `Right else `Up2 in - outq', - (inq, [ QNameSet.any => (dir ** outq) ]) - :: (outq, [ tst => (`Epsilon ** outq'); - QNameSet.any => (dir ** outq) ]) - :: trs, - outq @: (outq' @: sts) + | Attribute -> + let q' = State.make () in + let test = if QNameSet.is_finite test then + QNameSet.fold (fun tag acc -> QNameSet.add (QName.add_attribute_prefix tag) acc) + test QNameSet.empty + else test + in + (`Left ** q), + (q, [ QNameSet.singleton QName.attribute_map => (`Left ** q') ]) + :: (q', [ test => phi; + QNameSet.any => (`Right ** q') ]) :: trans, + (q' @:states) + | _ -> assert false + + in + phi, trans, q @: states +;; +let rec compile_expr e trans states = + match e with + | Binop (e1, (And|Or as op), e2) -> + let phi1, trans1, states1 = compile_expr e1 trans states in + let phi2, trans2, states2 = compile_expr e2 trans1 states1 in + (if op = Or then phi1 ++ phi2 else phi1 %% phi2), + trans2, + states2 + | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" -> + let phi, trans0, states0 = compile_expr e0 trans states in + (Ata.SFormula.not_ phi), + trans0, + states0 + | Path p -> compile_path p trans states | _ -> assert false +and compile_path paths trans states = + List.fold_left (fun (aphi, atrans, astates) p -> + let phi, ntrans, nstates = compile_single_path p atrans astates in + (Ata.SFormula.or_ phi aphi), + ntrans, + nstates) (Ata.SFormula.false_,trans,states) paths + +and compile_single_path p trans states = + let steps = + match p with + | Absolute steps -> + (Ancestor false, QNameSet.singleton QName.document, [])::steps + | Relative steps -> steps + in + compile_step_list steps trans states +and compile_step_list l trans states = + match l with + [] -> Ata.SFormula.true_, trans, states + | (axis, test, elist) :: ll -> + let phi0, trans0, states0 = compile_step_list ll trans states in + let phi1, trans1, states1 = + compile_axis_test axis test phi0 trans0 states0 + in + List.fold_left (fun (aphi, atrans, astates) e -> + let ephi, etrans, estates = compile_expr e atrans astates in + aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist