(******************************************************************************)
INCLUDE "debug.ml";;
#load "pa_extend.cmo";;
-
+let contains = ref None
module Ast =
struct
(* The steps are in reverse order !!!! *)
| [ "." ; p = top_pred -> [(Self,TagSet.node,p)] ]
| [ ".." ; p = top_pred -> [(Parent,TagSet.star,p)] ]
+| [ "contains"; "(" ; s = STRING ; ")";p=top_pred -> [
+ let _ = contains := Some(s) in (Child,TagSet.singleton Tag.pcdata, p)]
+ ]
+| [ "contains_full"; "(" ; s = STRING ; ")";p=top_pred -> [
+ let _ = contains := Some(s) in (Descendant,TagSet.singleton Tag.pcdata, p)]
+ ]
| [ test = test; p = top_pred -> [(Child,test, p)] ]
| [ att = ATT ; p = top_pred ->
match att with
tr_parent_loop : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
tr : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
tr_aux : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
+ mutable entry_points : (Tag.t*Ptset.t) list;
+ mutable contains : string option;
+ mutable univ_states : Ata.state list;
+ mutable starstate : Ptset.t option;
}
let dummy_conf = { st_root = -1;
st_univ = -1;
tr_parent_loop = Hashtbl.create 0;
tr = Hashtbl.create 0;
tr_aux = Hashtbl.create 0;
+ entry_points = [];
+ contains = None;
+ univ_states = [];
+ starstate = None;
}
let _r =
function (`Left|`Last) -> `Right
| `Right -> `Left
-let _l = function (`Left|`Last) -> `Left
- | `Right -> `Right
+ | `RRight -> `LLeft
+ | `LLeft -> `RRight
+
+
+let _l =
+ function (`Left|`Last) -> `Left
+ | `Right -> `Right
+ | `RRight -> `RRight
+ | `LLeft -> `LLeft
open Ata.Transitions
-let add_trans num htr ((q,_,_,_) as tr) =
+let add_trans num htr ((q,_,_,_,_) as tr) =
try
let (i,ltr) = Hashtbl.find htr q in
if List.exists (Ata.equal_trans tr) ltr
exception Exit of Ata.state * Ata.transition list
let rec replace s f =
match f.Ata.pos with
- | Ata.Atom(_,b,q,_) when q = s -> if b then Ata.true_ else Ata.false_
+ | Ata.Atom(_,b,q) when q = s -> if b then Ata.true_ else Ata.false_
| Ata.Or(f1,f2) -> (replace s f1) +| (replace s f2)
| Ata.And(f1,f2) -> (replace s f1) *& (replace s f2)
| _ -> f
let or_self conf old_dst q_src q_dst dir test pred mark =
try
let (num,l) = Hashtbl.find conf.tr q_src in
- let l2 = List.fold_left (fun acc (q,t,m,f) ->
- (q,TagSet.cap t test,mark,
+ let l2 = List.fold_left (fun acc (q,t,m,f,_) ->
+ (q,
+ TagSet.cap t test,
+ mark,
(if mark then replace old_dst f else f)
*& pred *&
- (if mark then Ata.true_ else (_l dir) ** q_dst))::acc)
+ (if mark then Ata.true_ else (_l dir) ** q_dst),
+ false)::acc)
l l
in Hashtbl.replace conf.tr q_src (num,l2)
with Not_found -> ()
| (x,z::y) ::r -> z,(x,y)::r
| _-> assert false
-let rec compile_step ?(existential=false) conf q_src dir ctx_path step num =
+let rec compile_step ?(existential=false) conf q_src dir ctx_path nrec step num =
let ex = existential in
let axis,test,pred = step in
let is_last = dir = `Last in
let p_st, p_anc, p_par, p_pre, p_num, p_f =
compile_pred conf q_src num ctx_path dir pred q_dst
in
-
let new_st,new_dst, new_ctx =
match axis with
- | Child | FollowingSibling | Descendant | DescendantOrSelf ->
- let axis =
- if axis = DescendantOrSelf
- then begin
- or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
- Descendant end
- else axis
+ | Child | Descendant ->
+ if (TagSet.is_finite test)
+ then conf.entry_points <- (TagSet.choose test,Ptset.singleton q_src)::conf.entry_points;
+ let left,right =
+ if nrec then `LLeft,`RRight
+ else `Left,`Right
in
- let t1 = ?< q_src><(test, is_last && not(existential))>=>
- p_f *& (if is_last then Ata.true_ else (_l dir) ** q_dst) in
- let t2 = ?< q_src><(TagSet.star, false)>=>
- (if axis=Descendant then `Left ** q_src +|`Right ** q_src
- else `Right ** q_src) in
- let tsa = ?< q_src><(att_or_str, false)>=> `Right ** q_src
+ let _ = if is_last && axis=Descendant && TagSet.equal test TagSet.star
+ then conf.starstate <- Some(Ptset.singleton q_src)
+ in
+ let t1 = ?< q_src><(test, is_last && not(ex))>=>
+ p_f *& ( if is_last then Ata.true_ else (_l left) ** q_dst) in
+
+ let _ = add_trans num conf.tr t1 in
+
+
+ let _ = if axis=Descendant then
+ add_trans num conf.tr_aux (
+ ?< q_src><@ ((if ex||nrec then TagSet.diff TagSet.star test
+ else TagSet.star),false)>=> `LLeft ** q_src )
+ in
+ let t3 =
+ ?< q_src><@ ((if ex then TagSet.diff TagSet.any test
+ else TagSet.any), false)>=>
+ if ex then right ** q_src
+ else (if axis=Descendant then `RRight else `Right) ** q_src
+ in
+ let _ = add_trans num conf.tr_aux t3
in
- add_trans num conf.tr t1;
- add_trans num conf.tr_aux t2;
- add_trans num conf.tr_aux tsa;
[q_dst], q_dst,
(if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
-
+
| Attribute ->
let q_dstreal = Ata.mk_state() in
(* attributes are always the first child *)
| Ancestor | AncestorOrSelf ->
conf.has_backward <- true;
let up_states, new_ctx =
- List.map (fst) ctx_path, (vpush q_root [])
+ List.fold_left (fun acc (q,_) -> if q == q_root then acc else q::acc) [] ctx_path, (vpush q_root [])
in
let _ = if axis = AncestorOrSelf then
or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
let fc = List.fold_left (fun f s -> ((_l dir)**s +|f)) Ata.false_ up_states
in
let t1 = ?< q_frm_root><(test,is_last && (not existential) )>=>
- (if is_last then Ata.true_ else (_l dir) ** q_dst) *& fc in
+ ( (*if is_last then Ata.true_ else *) (`LLeft ) ** q_dst) *& fc in
add_trans num conf.tr t1;
[q_dst ], q_dst, vpush q_frm_root new_ctx
(Ptset.elements (Ptset.union p_st (Ptset.from_list new_st)),
new_dst,
new_ctx)
-
+and is_rec = function
+ [] -> false
+ | ((axis,_,_),_)::_ ->
+ match axis with
+ Descendant | Ancestor -> true
+ | _ -> false
+
and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
List.fold_left
- (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward) (step,dir) ->
+ (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward,a_isrec) (step,dir) ->
let add_states,new_dst,new_ctx =
- compile_step ~existential:existential config a_dst dir ctx_path step num
+ compile_step ~existential:existential config a_dst dir ctx_path (is_rec a_isrec) step num
in
let new_states = Ptset.union (Ptset.from_list add_states) a_st in
let nanc_st,npar_st,npre_st,new_bw =
|(Parent|Ancestor|AncestorOrSelf),_,_ -> Ptset.add a_dst anc_st,par_st,pre_st,true
| _ -> anc_st,par_st,pre_st,has_backward
in
- new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw
+ new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw,(match a_isrec with [] -> [] | _::r -> r)
)
- (states, q_src, Ptset.empty,Ptset.empty,Ptset.empty, ctx_path,idx, false )
+ (states, q_src, Ptset.empty,Ptset.empty,Ptset.empty, ctx_path,idx, false,(List.tl annot_path) )
annot_path
-
+
and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
compile_pred conf q_src idx ctx_path dir p1 ddst in
| Path (p) ->
let q = Ata.mk_state () in
let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
- let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward =
+ let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward,_ =
compile_path ~existential:true annot_path conf q states idx ctx_path
in
let ret_dir = match annot_path with
let _ = match annot_path with
| (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ptset.add qdst conf.final_state
| _ -> ()
- in
+ in let _ = conf.univ_states <- a_dst::conf.univ_states in
(a_st,anc_st,par_st,pre_st,idx, ((ret_dir) ** q))
| True -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.true_
| False -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.false_
in
let steps = List.rev steps in
let dirsteps = dirannot steps in
+ let _ = Ata.mk_state() in
let config = { st_root = Ata.mk_state();
st_univ = Ata.mk_state();
final_state = Ptset.empty;
tr_parent_loop = Hashtbl.create 5;
tr = Hashtbl.create 5;
tr_aux = Hashtbl.create 5;
+ entry_points = [];
+ contains = None;
+ univ_states = [];
+ starstate = None;
}
in
let q0 = Ata.mk_state() in
add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
add_trans num config.tr_aux (mk_step config.st_no_nil (TagSet.add Tag.pcdata TagSet.star) `Left config.st_univ config.st_univ);
*)
- let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward =
+ let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward,_ =
compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
in
let fst_tr =
- ?< (config.st_root) >< (TagSet.star,false) >=>
- (`Left** q0) *& (if config.has_backward then `Left ** config.st_from_root else Ata.true_)
+ ?< (config.st_root) >< (TagSet.singleton (Tag.tag ""),false) >=>
+ ((if is_rec dirsteps then `LLeft else `Left)** q0) *& (if config.has_backward then `LLeft ** config.st_from_root else Ata.true_)
in
add_trans num config.tr fst_tr;
if config.has_backward then begin
add_trans num config.tr_aux
- (?< (config.st_from_root) >< (TagSet.star,false) >=> `Left ** config.st_from_root +|
- `Right ** config.st_from_root);
+ (?< (config.st_from_root) >< (TagSet.star,false) >=> `LLeft ** config.st_from_root);
add_trans num config.tr_aux
- (?< (config.st_from_root) >< (TagSet.cup TagSet.pcdata TagSet.attribute,false) >=>
- `Right ** config.st_from_root);
+ (?< (config.st_from_root) >< (TagSet.any,false) >=>
+ `RRight ** config.st_from_root);
- end;
+ end;
let phi = Hashtbl.create 37 in
- let fadd = fun _ (_,l) -> List.iter (fun (s,t,m,f) -> Hashtbl.add phi (t,s) (m,f)) l in
+ let fadd = fun _ (_,l) -> List.iter (fun (s,t,m,f,p) ->
+ let lt = try
+ Hashtbl.find phi s
+ with Not_found -> []
+ in
+ Hashtbl.replace phi s ((t,(m,f,p))::lt)
+ ) l in
Hashtbl.iter (fadd) config.tr;
Hashtbl.iter (fadd) config.tr_aux;
Hashtbl.iter (fadd) config.tr_parent_loop;
let final =
- let s = Ptset.union anc_st (Ptset.from_list [a_dst;config.st_univ])
- in if has_backward then s else Ptset.add config.st_from_root s
+ let s = Ptset.union anc_st (Ptset.from_list [])
+ in if has_backward then Ptset.add config.st_from_root s else s
in { Ata.id = Oo.id (object end);
- Ata.states = a_st;
+ Ata.states = Hashtbl.fold (fun q _ acc -> Ptset.add q acc) phi Ptset.empty;
Ata.init = Ptset.singleton config.st_root;
Ata.final = Ptset.union anc_st config.final_state;
- Ata.universal = Ptset.union anc_st config.final_state;
+ Ata.universal = Ptset.add a_dst (Ptset.from_list config.univ_states);
Ata.phi = phi;
- Ata.delta = Hashtbl.create 17;
- Ata.properties = Hashtbl.create 0;
- }
+ Ata.sigma = Hashtbl.create 17;
+ Ata.starstate = config.starstate;
+ },config.entry_points,!contains
end
projects / SXSI / xpathcomp.git / blobdiff