+ module Fold2Res = struct
+ external get : 'a array -> int ->'a = "%array_unsafe_get"
+ external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+ external field1 : 'a -> 'b = "%field1"
+ type 'a t = 'a array array array array
+ let dummy = [||]
+ let dummy_val : 'a =
+ let v = Obj.repr ((),2,()) in
+ Obj.magic v
+
+ let create n = Array.create n dummy
+
+ let find h tag fl s1 s2 =
+ let af = get h tag in
+ if af == dummy then raise Not_found
+ else
+ let as1 = get af fl.Formlistlist.Node.id in
+ if as1 == dummy then raise Not_found
+ else
+ let as2 = get as1 s1.SList.Node.id in
+ if as2 == dummy then raise Not_found
+ else let v = get as2 s2.SList.Node.id in
+ if field1 v == 2 then raise Not_found
+ else v
+
+ let add h tag fl s1 s2 data =
+ let af =
+ let x = get h tag in
+ if x == dummy then
+ begin
+ let y = Array.make 10000 dummy in
+ set h tag y;y
+ end
+ else x
+ in
+ let as1 =
+ let x = get af fl.Formlistlist.Node.id in
+ if x == dummy then
+ begin
+ let y = Array.make 10000 dummy in
+ set af fl.Formlistlist.Node.id y;y
+ end
+ else x
+ in
+ let as2 =
+ let x = get as1 s1.SList.Node.id in
+ if x == dummy then
+ begin
+ let y = Array.make 10000 dummy_val in
+ set as1 s1.SList.Node.id y;y
+ end
+ else x
+ in
+ set as2 s2.SList.Node.id data
+ end
+
+ module Fold2Res2 = struct
+ include Hashtbl.Make(struct
+ type t = Tag.t*Formlistlist.t*SList.t*SList.t
+ let equal (a,b,c,d) (x,y,z,t) =
+ a == x && b == y && c == z && d == t
+ let hash (a,b,c,d) = HASHINT4 (a,b.Formlistlist.Node.id,
+ c.SList.Node.id,d.SList.Node.id)
+ end)
+ let add h t f s1 s2 d =
+ add h (t,f,s1,s2) d
+ let find h t f s1 s2 =
+ find h (t,f,s1,s2)
+ end
+
+ let h_fold2 = Fold2Res.create 10000
+
+ let top_down ?(noright=false) a tree t slist ctx slot_size =
+ let pempty = empty_size slot_size in
+ let rempty = Array.make slot_size RS.empty in
+ (* evaluation starts from the right so we put sl1,res1 at the end *)
+ let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) =
+ let res = Array.copy rempty in
+ try
+ let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in
+ if b then for i=0 to slot_size - 1 do
+ res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
+ done;
+ r,res
+ with
+ Not_found ->
+ begin
+ let btab = Array.make slot_size NO in
+ let rec fold l1 l2 fll i aq ab =
+ match fll.Formlistlist.Node.node,
+ l1.SList.Node.node,
+ l2.SList.Node.node
+ with
+ | Formlistlist.Cons(fl,fll),
+ SList.Cons(s1,ll1),
+ SList.Cons(s2,ll2) ->
+ let r',conf = eval_formlist tag s1 s2 fl in
+ let _ = btab.(i) <- conf
+ in
+ fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab)
+ | _ -> aq,ab
+ in
+ let r,b = fold sl1 sl2 fll 0 SList.nil false in
+ Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab);
+ if b then for i=0 to slot_size - 1 do
+ res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
+ done;
+ r,res;
+ end
+ in
+
+ let null_result = (pempty,Array.copy rempty) in
+ let rec loop t slist ctx =
+ if t == Tree.nil then null_result else get_trans t slist (Tree.tag tree t) ctx
+ and loop_tag tag t slist ctx =
+ if t == Tree.nil then null_result else get_trans t slist tag ctx
+ and loop_no_right t slist ctx =
+ if t == Tree.nil then null_result else get_trans ~noright:true t slist (Tree.tag tree t) ctx
+ and get_trans ?(noright=false) t slist tag ctx =
+ let cont =
+ try
+ TransCache.find td_trans tag slist
+ with
+ | Not_found ->
+ let fl_list,llist,rlist,ca,da,sa,fa =
+ SList.fold
+ (fun set (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
+ let fl,ll,rr,ca,da,sa,fa =
+ StateSet.fold
+ (fun q acc ->
+ List.fold_left
+ (fun ((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc) as acc)
+ (ts,t) ->
+ if (TagSet.mem tag ts)
+ then
+ let _,_,_,f,_ = Transition.node t in
+ let (child,desc,below),(sibl,foll,after) = Formula.st f in
+ (Formlist.cons t fl_acc,
+ StateSet.union ll_acc below,
+ StateSet.union rl_acc after,
+ StateSet.union child c_acc,
+ StateSet.union desc d_acc,
+ StateSet.union sibl s_acc,
+ StateSet.union foll f_acc)
+ else acc ) acc (
+ try Hashtbl.find a.trans q
+ with
+ Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
+ q;[]
+ )
+
+ ) set (Formlist.nil,StateSet.empty,StateSet.empty,ca,da,sa,fa)
+ in (Formlistlist.cons fl fll_acc), (SList.cons ll lllacc), (SList.cons rr rllacc),ca,da,sa,fa)
+ slist (Formlistlist.nil,SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
+ in
+ (* Logic to chose the first and next function *)
+ let tags_child,tags_below,tags_siblings,tags_after = Tree.tags tree tag in
+ let d_f = Algebra.decide a tags_child tags_below (StateSet.union ca da) true in
+ let d_n = Algebra.decide a tags_siblings tags_after (StateSet.union sa fa) false in
+ let f_kind,first = choose_jump_down tree d_f
+ and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil )
+ else choose_jump_next tree d_n in
+ (*let f_kind,first = `ANY, Tree.first_child tree
+ and n_kind,next = `ANY, Tree.next_sibling_below tree
+ in *)
+ let empty_res = null_result in
+ let cont =
+ match f_kind,n_kind with
+ | `NIL,`NIL ->
+ (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res empty_res)
+ | _,`NIL -> (
+ match f_kind with
+ |`TAG(tag') ->
+ let default = fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res
+ (loop_tag tag' (first t) llist t )
+ in
+ let cf = SList.hd llist in
+ if (slot_size == 1) && StateSet.is_singleton cf
+ then
+ let s = StateSet.choose cf in
+ if (Algebra.is_rec a s fst) && (Algebra.is_rec a s snd)
+ && (Algebra.is_final_marking a s)
+ then
+ RS.mk_quick_tag_loop default llist 1 tree tag'
+ else default
+ else default
+ | _ ->
+ (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res
+ (loop (first t) llist t ))