module TransTable = Hashtbl
module Formlist = struct
- include Hlist.Make(Transition)
- type data = t node
- let make _ = failwith "make"
+ include Hlist.Make(Transition)
let print ppf fl =
iter (fun t -> Transition.print ppf t; Format.pp_print_newline ppf ()) fl
end
-
type 'a t = {
id : int;
module Run (RS : ResultSet) =
struct
- module SList = struct
- include Hlist.Make (StateSet)
- type data = t node
- let make _ = failwith "make"
- end
+ module SList = Hlist.Make (StateSet)
else RS.concat res1 res2
else RS.empty
-
let top_down ?(noright=false) a tree t slist ctx slot_size =
let pempty = empty_size slot_size in
- (* evaluation starts from the right so we put sl1,res1 at the end *)
+ (* evaluation starts from the right so we put sl1,res1 at the end *)
let eval_fold2_slist fll t (sl2,res2) (sl1,res1) =
let res = Array.copy res1 in
let rec fold l1 l2 fll i aq =
- match SList.node l1,SList.node l2, fll with
- | SList.Cons(s1,ll1),
- SList.Cons(s2,ll2),
- fl::fll ->
- let r',flags = eval_formlist s1 s2 fl in
- let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i)
- in
+ match fll with
+ [fl] -> (* inline for speed *)
+ let s1 = SList.hd l1
+ and s2 = SList.hd l2 in
+ let r',flags = eval_formlist s1 s2 fl in
+ let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i) in
+ (SList.cons r' aq),res
+ | fl::fll ->
+ let SList.Cons(s1,ll1) = l1.SList.Node.node
+ and SList.Cons(s2,ll2) = l2.SList.Node.node in
+ let r',flags = eval_formlist s1 s2 fl in
+ let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i)
+ in
fold ll1 ll2 fll (i+1) (SList.cons r' aq)
-
- | SList.Nil, SList.Nil,[] -> aq,res
- | _ -> assert false
+ | _ -> aq,res
in
- fold sl1 sl2 fll 0 SList.nil
+ fold sl1 sl2 fll 0 SList.nil
in
let null_result() = (pempty,Array.make slot_size RS.empty) 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 =
in
(* Logic to chose the first and next function *)
let _,tags_below,_,tags_after = Tree.tags tree tag in
+(* let _ = Printf.eprintf "Tags below %s are : \n" (Tag.to_string tag) in
+ let _ = Ptset.Int.iter (fun i -> Printf.eprintf "%s " (Tag.to_string i)) tags_below in
+ let _ = Printf.eprintf "\n%!" in *)
let f_kind,first = choose_jump_down tree tags_below ca da a
and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil )
else choose_jump_next tree tags_after sa fa a in
INCLUDE "utils.ml"
-module type S =
-sig
- type data
- type t
- val make : data -> t
- val node : t -> data
- val hash : t -> int
- val uid : t -> int
- val equal : t -> t -> bool
-end
+module type SA =
+ sig
+ type data
+ type t
+ val make : data -> t
+ val node : t -> data
+ val hash : t -> int
+ val uid : t -> int
+ val equal : t -> t -> bool
+ end
+
+module type S =
+ sig
+ type data
+ type t = private { id : int;
+ key : int;
+ node : data }
+ val make : data -> t
+ val node : t -> data
+ val hash : t -> int
+ val uid : t -> int
+ val equal : t -> t -> bool
+ end
+
module Make (H : Hashtbl.HashedType) : S with type data = H.t =
struct
type data = H.t
- type t = { id : int;
- key : int;
- node : data;
- }
-
+ type t = { id : int;
+ key : int;
+ node : data }
let node t = t.node
let hash t = t.key
let uid t = t.id
-module type S =
+module type SA =
sig
type data
type t
val equal : t -> t -> bool
end
+module type S =
+ sig
+ type data
+ type t = private { id : int;
+ key : int;
+ node : data }
+ val make : data -> t
+ val node : t -> data
+ val hash : t -> int
+ val uid : t -> int
+ val equal : t -> t -> bool
+ end
+
module Make (H : Hashtbl.HashedType) : S with type data = H.t
module type S = sig
type elt
type 'a node = Nil | Cons of elt * 'a
- type t
+
+ module rec Node :
+ sig
+ include Hcons.S with type data = Data.t
+ end
+ and Data : sig
+ include Hashtbl.HashedType with type t = Node.t node
+ end
+ type data = Data.t
+ type t = Node.t
val hash : t -> int
val uid : t -> int
+ val make : data -> t
val equal : t -> t -> bool
val nil : t
val node : t -> t node
val length : t -> int
end
-module Make ( H : Hcons.S ) : S with type elt = H.t =
+module Make ( H : Hcons.SA ) : S with type elt = H.t =
struct
type elt = H.t
type 'a node = Nil | Cons of elt * 'a
- module rec HNode : Hcons.S with type data = Node.t = Hcons.Make (Node)
- and Node : Hashtbl.HashedType with type t = HNode.t node =
+ module rec Node : Hcons.S with type data = Data.t = Hcons.Make (Data)
+ and Data : Hashtbl.HashedType with type t = Node.t node =
struct
- type t = HNode.t node
+ type t = Node.t node
let equal x y =
match x,y with
- | Nil,Nil -> true
- | Cons (a,aa), Cons(b,bb) -> (H.equal a b) && (HNode.equal aa bb)
+ | _,_ when x==y -> true
+ | Cons (a,aa), Cons(b,bb) -> (aa==bb) && (H.equal a b)
| _ -> false
let hash = function
| Nil -> 0
- | Cons(a,aa) -> HASHINT3(PRIME3,H.uid a, HNode.uid aa)
+ | Cons(a,aa) -> HASHINT3(PRIME3,H.uid a, aa.Node.id)
end
- ;;
-
- type t = HNode.t
- let node = HNode.node
- let hash = HNode.hash
- let equal = HNode.equal
- let uid = HNode.uid
- let nil = HNode.make Nil
- let cons a b = HNode.make (Cons(a,b))
- let hd a =
- match HNode.node a with
- | Nil -> failwith "hd"
- | Cons(a,_) -> a
-
- let tl a =
- match HNode.node a with
- | Nil -> failwith "tl"
- | Cons(_,a) -> a
-
+ type data = Data.t
+ type t = Node.t
+ let make = Node.make
+ let node = Node.node
+ let hash = Node.hash
+ let equal = Node.equal
+ let uid = Node.uid
+ let nil = Node.make Nil
+ let cons a b = Node.make (Cons(a,b))
+ let hd = function { Node.node = Cons(a,_) } -> a | _ -> failwith "hd"
+ let tl = function { Node.node = Cons(_,a) } -> a | _ -> failwith "tl"
let fold f l acc =
- let rec loop acc l = match HNode.node l with
+ let rec loop acc l = match l.Node.node with
| Nil -> acc
| Cons(a,aa) -> loop (f a acc) aa
in
loop acc l
let map f l =
- let rec loop l = match HNode.node l with
+ let rec loop l = match l.Node.node with
| Nil -> nil
| Cons(a,aa) -> cons (f a) (loop aa)
in
loop l
let iter f l =
- let rec loop l = match HNode.node l with
+ let rec loop l = match l.Node.node with
| Nil -> ()
| Cons(a,aa) -> (f a);(loop aa)
in
module type S = sig
type elt
type 'a node = Nil | Cons of elt * 'a
- type t
+
+ module rec Node :
+ sig
+ include Hcons.S with type data = Data.t
+ end
+ and Data : sig
+ include Hashtbl.HashedType with type t = Node.t node
+ end
+ type data = Data.t
+ type t = Node.t
val hash : t -> int
val uid : t -> int
+ val make : data -> t
val equal : t -> t -> bool
val nil : t
val node : t -> t node
val length : t -> int
end
-module Make (H : Hcons.S) : S with type elt = H.t
+module Make (H : Hcons.SA) : S with type elt = H.t
val node : t -> data
end
-module Make ( H : Hcons.S ) : S with type elt = H.t =
+module Make ( H : Hcons.SA ) : S with type elt = H.t =
struct
type elt = H.t
type 'a node =
projects / SXSI / xpathcomp.git / commitdiff