Commit 17b988b3 authored by Pietro Abate's avatar Pietro Abate
Browse files

Add interface for tpyes/var.ml and tight up boolVar interface

parent 31208ef3
...@@ -239,7 +239,8 @@ ALL_OBJECTS = $(OBJECTS) \ ...@@ -239,7 +239,8 @@ ALL_OBJECTS = $(OBJECTS) \
parser/cduce_netclient.cmo \ parser/cduce_netclient.cmo \
runtime/cduce_expat.cmo runtime/cduce_pxp.cmo runtime/cduce_expat.cmo runtime/cduce_pxp.cmo
ALL_INTERFACES = schema/schema_types.mli ALL_INTERFACES = schema/schema_types.mli
#types/var.mli types/boolVar.mli
DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES) DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
......
...@@ -12,6 +12,8 @@ ML_SRC= \ ...@@ -12,6 +12,8 @@ ML_SRC= \
cduce/types/atoms.ml \ cduce/types/atoms.ml \
cduce/misc/bool.ml \ cduce/misc/bool.ml \
cduce/types/chars.ml \ cduce/types/chars.ml \
cduce/types/var.ml \
cduce/types/boolVar.ml \
cduce/types/ident.ml \ cduce/types/ident.ml \
cduce/types/intervals.ml \ cduce/types/intervals.ml \
cduce/misc/inttbl.ml \ cduce/misc/inttbl.ml \
...@@ -46,7 +48,6 @@ cduce_types.p.cmx: cduce_types.cmx ...@@ -46,7 +48,6 @@ cduce_types.p.cmx: cduce_types.cmx
CDUCE_INCLUDES = $(DIRS:%=-I %) CDUCE_INCLUDES = $(DIRS:%=-I %)
.SUFFIXES: .ml .mli .cmo .cmi .cmx .SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo: .ml.cmo:
...@@ -65,8 +66,6 @@ compute_depend: ...@@ -65,8 +66,6 @@ compute_depend:
include cduce/types_depend include cduce/types_depend
clean: clean:
for i in $(DIRS); do \ for i in $(DIRS); do \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \ (cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \
......
...@@ -15,6 +15,3 @@ true: -traverse ...@@ -15,6 +15,3 @@ true: -traverse
<schema/**>: package(pcre), package(netstring) <schema/**>: package(pcre), package(netstring)
<runtime/**>: package(pcre), package(netstring) <runtime/**>: package(pcre), package(netstring)
<tests/libtest/*Test.*>: package(netstring), package(pcre), package(oUnit), package(ulex), package(num), package(camlp4.lib) <tests/libtest/*Test.*>: package(netstring), package(pcre), package(oUnit), package(ulex), package(num), package(camlp4.lib)
<tests/eval/src/main.*>: pp(camlp4orf.opt), package(netstring), package(pcre), package(oUnit), package(ulex), package(num), package(camlp4.lib)
<kim*.native>: pp(camlp4orf.opt), package(netstring), package(pcre), package(oUnit), package(ulex), package(num), package(camlp4.lib)
This diff is collapsed.
...@@ -18,9 +18,12 @@ module type S = sig ...@@ -18,9 +18,12 @@ module type S = sig
val from_int: int -> t val from_int: int -> t
end end
module HInt = Hashtbl.Make(struct type t = int module HInt =
let hash x = x Hashtbl.Make(struct
let equal x y = x==y end) type t = int
let hash x = x
let equal x y = x==y
end)
module Make(X : Custom.T) = struct module Make(X : Custom.T) = struct
type token type token
......
...@@ -7,7 +7,7 @@ module Locals = Map.Make(String) ...@@ -7,7 +7,7 @@ module Locals = Map.Make(String)
(* To throw in case of an unbound name *) (* To throw in case of an unbound name *)
exception Error exception Error
let polyvar = Types.var (`Var (Var.make_id "A")) let polyvar = Types.var (Var.mk "A")
let type_of_string s = match s with let type_of_string s = match s with
| "Int" -> Builtin_defs.int | "Int" -> Builtin_defs.int
...@@ -115,7 +115,7 @@ and make_sigma s = ...@@ -115,7 +115,7 @@ and make_sigma s =
and type_of_ptype = and type_of_ptype =
let open Types in function let open Types in function
| Type(t) -> type_of_string t | Type(t) -> type_of_string t
| PType(t) -> var (`Var (Var.make_id t)) | PType(t) -> var (Var.mk t)
| TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2)) | TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
| TUnion(t1, t2) -> cup (type_of_ptype t1) (type_of_ptype t2) | TUnion(t1, t2) -> cup (type_of_ptype t1) (type_of_ptype t2)
| TInter(t1, t2) -> cap (type_of_ptype t1) (type_of_ptype t2) | TInter(t1, t2) -> cap (type_of_ptype t1) (type_of_ptype t2)
......
...@@ -4,7 +4,7 @@ let (=) : int -> int -> bool = (=) ...@@ -4,7 +4,7 @@ let (=) : int -> int -> bool = (=)
(* this is the the of the Constructor container *) (* this is the the of the Constructor container *)
module type E = sig module type E = sig
type elem type elem
include Custom.T include Custom.T
val empty : t val empty : t
...@@ -19,20 +19,8 @@ end ...@@ -19,20 +19,8 @@ end
module type S = sig module type S = sig
type s type s
module T : sig
include E
val is_empty : s -> bool
val is_full : s -> bool
end
type elem = s Var.pairvar type elem = s Var.pairvar
type 'a bdd = include Custom.T
[ `True
| `False
| `Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd) ]
include Custom.T with type t = elem bdd
(* returns the union of all leaves in the BDD *) (* returns the union of all leaves in the BDD *)
val leafconj: t -> s val leafconj: t -> s
...@@ -48,14 +36,13 @@ module type S = sig ...@@ -48,14 +36,13 @@ module type S = sig
val cap : t -> t -> t val cap : t -> t -> t
val diff : t -> t -> t val diff : t -> t -> t
val atom : elem -> t val atom : elem -> t
(* val neg_atom : elem -> t *)
val trivially_disjoint: t -> t -> bool val trivially_disjoint: t -> t -> bool
(* vars a : return a bdd that is ( Any ^ Var a ) *) (* vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Var.var -> t val vars : Var.var -> t
val iter: (elem-> unit) -> t -> unit val iter: (elem -> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b) val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) -> -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
...@@ -72,9 +59,7 @@ module type S = sig ...@@ -72,9 +59,7 @@ module type S = sig
*) *)
end end
(* module type MAKE = functor (T : E) -> S with type s = T.t
module type MAKE = functor (T : E) -> S with type elem = T.t Custom.pairvar
*)
(* ternary BDD (* ternary BDD
* where the nodes are Atm of X.t | Var of String.t * where the nodes are Atm of X.t | Var of String.t
...@@ -94,22 +79,16 @@ module type MAKE = functor (T : E) -> S with type elem = T.t Custom.pairvar ...@@ -94,22 +79,16 @@ module type MAKE = functor (T : E) -> S with type elem = T.t Custom.pairvar
* *
* *) * *)
module Make(T : E) : S with type s = T.t = module Make (T : E) : S with type s = T.t = struct
struct
(* ternary decision trees . cf section 11.3.3 Frish PhD *) (* ternary decision trees . cf section 11.3.3 Frish PhD *)
(* plus variables *) (* plus variables *)
(* `Atm are containers (Atoms, Chars, Intervals, Pairs ... ) (* `Atm are containers (Atoms, Chars, Intervals, Pairs ... )
* `Var are String * `Var are String
*) *)
module T = struct
include T
let is_empty t = (empty == t)
let is_full t = (full == t)
end
type s = T.t type s = T.t
module X = Var.Make(T)
type elem = s Var.pairvar type elem = s Var.pairvar
module X : Custom.T with type t = elem = Var.Make(T)
type 'a bdd = type 'a bdd =
[ `True [ `True
| `False | `False
...@@ -167,6 +146,9 @@ struct ...@@ -167,6 +146,9 @@ struct
`Split (h, x,`True,`False,`False) `Split (h, x,`True,`False,`False)
let vars v = let vars v =
let compute_hash x p i n =
(Var.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
in
let a = atom (`Atm T.full) in let a = atom (`Atm T.full) in
let h = compute_hash v a `False `False in let h = compute_hash v a `False `False in
( `Split (h,v,a,`False,`False) :> t ) ( `Split (h,v,a,`False,`False) :> t )
......
...@@ -138,7 +138,6 @@ module BoolIntervals : BoolVar.S with ...@@ -138,7 +138,6 @@ module BoolIntervals : BoolVar.S with
module BoolChars : BoolVar.S with module BoolChars : BoolVar.S with
type s = Chars.t = BoolVar.Make(Chars) type s = Chars.t = BoolVar.Make(Chars)
module TLV = struct module TLV = struct
module Set = struct module Set = struct
......
...@@ -85,10 +85,14 @@ include Custom.T ...@@ -85,10 +85,14 @@ include Custom.T
module Node : Custom.T module Node : Custom.T
module Pair : Bool.S with type elem = (Node.t * Node.t) module Pair : Bool.S with type elem = (Node.t * Node.t)
module BoolPair : BoolVar.S with type s = Pair.t and type elem = Pair.t Var.pairvar module BoolPair : BoolVar.S with
type s = Pair.t and
type elem = Pair.t Var.pairvar
module Rec : Bool.S with type elem = bool * Node.t Ident.label_map module Rec : Bool.S with type elem = bool * Node.t Ident.label_map
module BoolRec : BoolVar.S with type s = Rec.t and type elem = Rec.t Var.pairvar module BoolRec : BoolVar.S with
type s = Rec.t and
type elem = Rec.t Var.pairvar
type descr = t type descr = t
......
type t = { module V = struct
fresh : bool; type t = { fresh : bool; id : string; }
id : string; let make_id ?(fresh=false) id = { id = id ; fresh = fresh }
} let dump ppf t = Format.fprintf ppf "{id=%s;fresh=%b}" t.id t.fresh
let make_id ?(fresh=false) id = let compare x y = Pervasives.compare x.id y.id
{ id = id ; fresh = fresh } let equal x y = Pervasives.compare x.id y.id = 0
let hash x = Hashtbl.hash x.id
let dump ppf t = Format.fprintf ppf "{id=%s;fresh=%b}" t.id t.fresh end
let compare x y = Pervasives.compare x.id y.id
let equal x y = Pervasives.compare x.id y.id = 0
let hash x = Hashtbl.hash x.id
type var = [ `Var of t ] type var = [ `Var of V.t ]
type 'a pairvar = [ `Atm of 'a | var ] type 'a pairvar = [ `Atm of 'a | var ]
let dump ppf (`Var x) = Format.fprintf ppf "%a" dump x let dump ppf (`Var x) = Format.fprintf ppf "%a" V.dump x
let print ppf (`Var x) = Format.fprintf ppf "'%s" x.id let print ppf (`Var x) = Format.fprintf ppf "'%s" x.V.id
let compare (`Var x) (`Var y) = compare x y let compare (`Var x) (`Var y) = V.compare x y
let equal v1 v2 = (compare v1 v2) = 0 let equal v1 v2 = (compare v1 v2) = 0
let hash (`Var x) = V.hash x
let mk ?fresh id =
`Var (V.make_id ?fresh id)
let fresh : ?pre: string -> unit -> [> var ] =
let counter = ref 0 in
fun ?(pre="_fresh_") -> fun _ ->
let id = (Printf.sprintf "%s%d" pre !counter) in
let v = mk ~fresh:true id in
incr counter;
v
;;
let id (`Var t) = t.id let id (`Var t) = t.V.id
let is_fresh (`Var t) = t.fresh let is_fresh (`Var t) = t.V.fresh
module Set = struct module Set = struct
include Set.Make( struct type t = var let compare = compare end) include Set.Make(struct type t = var let compare = compare end)
let aux_print sep printer ppf s = let aux_print sep printer ppf s =
let rec aux ppf = function let rec aux ppf = function
|[] -> () |[] -> ()
...@@ -39,9 +48,11 @@ module Set = struct ...@@ -39,9 +48,11 @@ module Set = struct
let from_list l = List.fold_left (fun acc x -> add x acc) empty l let from_list l = List.fold_left (fun acc x -> add x acc) empty l
end end
module type MAKE = functor (X : Custom.T) -> Custom.T with type t = X.t pairvar
module Make (X : Custom.T) = struct module Make (X : Custom.T) = struct
type t = X.t pairvar type t = X.t pairvar
let hash = function `Atm t -> X.hash t | `Var x -> hash x let hash = function `Atm t -> X.hash t | `Var x -> V.hash x
let check = function `Atm t -> X.check t | `Var _ -> () let check = function `Atm t -> X.check t | `Var _ -> ()
let compare t1 t2 = let compare t1 t2 =
match t1,t2 with match t1,t2 with
...@@ -56,15 +67,3 @@ module Make (X : Custom.T) = struct ...@@ -56,15 +67,3 @@ module Make (X : Custom.T) = struct
|`Atm x -> X.dump ppf x |`Atm x -> X.dump ppf x
|`Var x -> dump ppf (`Var x) |`Var x -> dump ppf (`Var x)
end end
let mk ?fresh id =
`Var (make_id ?fresh id)
let fresh : ?pre: string -> unit -> [> var ] =
let counter = ref 0 in
fun ?(pre="_fresh_") -> fun _ ->
let id = (Printf.sprintf "%s%d" pre !counter) in
let v = mk ~fresh:true id in
incr counter;
v
module V : sig
type t
val make_id : ?fresh:bool -> string -> t
val dump : Format.formatter -> t -> unit
val compare : t -> t -> int
val equal : t -> t -> bool
val hash : t -> int
end
type var = [ `Var of V.t ]
val dump : Format.formatter -> var -> unit
val print : Format.formatter -> var -> unit
val compare : var -> var -> int
val equal : var -> var -> bool
val hash : var -> int
val mk : ?fresh:bool -> string -> var
val fresh : ?pre:string -> unit -> var
val id : var -> string
val is_fresh : var -> bool
module Set : sig
include Set.S with type elt = var
val dump : Format.formatter -> t -> unit
val print : Format.formatter -> t -> unit
val is_empty : t -> bool
val from_list : elt list -> t
end
type 'a pairvar = [ `Atm of 'a | var ]
module type MAKE = functor (X : Custom.T) -> Custom.T with type t = X.t pairvar
module Make : MAKE
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment