Commit a53cec51 authored by Pietro Abate's avatar Pietro Abate

[r2003-05-18 14:42:51 by cvscast] Clean-up

Original author: cvscast
Date: 2003-05-18 14:44:17+00:00
parent 1b66fe0a
......@@ -8,14 +8,14 @@ CLEAN_DIRS = $(DIRS) tools tests
MISC = misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo
PARSER = parser/lexer.cmo parser/location.cmo \
PARSER = parser/location.cmo \
parser/wlexer.cmo \
parser/ast.cmo parser/parser.cmo
TYPING = typing/typed.cmo typing/typer.cmo
TYPES = \
types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo \
types/sortedList.cmo types/boolean.cmo \
types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
types/normal.cmo \
......
......@@ -12,7 +12,7 @@ let rec is_abstraction = function
let print_norm ppf d =
Location.protect ppf
(fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
(fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
let print_value ppf v =
Location.protect ppf (fun ppf -> Value.print ppf v)
......@@ -120,7 +120,7 @@ let debug ppf = function
Format.fprintf ppf "[DEBUG:accept]@\n";
let p = Typer.pat p in
let t = Patterns.accept p in
Format.fprintf ppf " %a@\n" Types.Print.print t
Format.fprintf ppf " %a@\n" Types.Print.print (Types.descr t)
| `Compile (t,pl) ->
Format.fprintf ppf "[DEBUG:compile]@\n";
let t = Typer.typ t
......
......@@ -67,4 +67,5 @@ let main () =
let () = main (); Types.print_stat ppf_err
let () = main ()
This diff is collapsed.
......@@ -12,93 +12,6 @@ end
type 'a bool = ('a list * 'a list) list
(*
module Make(X1 : S)(X2 : S) =
struct
type t = (X1.t * X2.t) list
type cell = { mutable t1 : X1.t; mutable t2 : X2.t; next: cell }
(* Quite ugly, isn't it ?
I _want_ sum+records types in OCaml ! *)
(* Possible optimizations:
- check whether t1 or t2 is empty initially
- check s1 = t1 (structural equility)
*)
let rec add root t1 t2 l =
if (Obj.magic l = 0) then root := { t1 = t1; t2 = t2; next = !root }
else
match l with
{ t1 = s1; t2 = s2; next = next } ->
let i = X1.cap t1 s1 in
if X1.is_empty i then add root t1 t2 l.next
else (
l.t1 <- i; l.t2 <- X2.cup t2 s2;
let k = X1.diff s1 t1 in
if not (X1.is_empty k) then
root := { t1 = k; t2 = s2; next = !root };
let j = X1.diff t1 s1 in
if not (X1.is_empty j) then add root j t2 next
)
let rec get accu l =
if Obj.magic l = 0 then accu
else get ((l.t1, l.t2)::accu) l.next
let normal x =
let res = ref (Obj.magic 0) in
List.iter (fun (t1,t2) -> add res t1 t2 !res) x;
get [] !res
let rec bigcap_aux t1 t2 = function
| (s1,s2)::rem -> bigcap_aux (X1.cap t1 s1) (X2.cap t2 s2) rem
| [] -> (t1,t2)
let bigcap = bigcap_aux X1.any X2.any
let line res (p,n) =
let (d1,d2) = bigcap p in
if not ((X1.is_empty d1) || (X2.is_empty d2)) then
(let resid = ref X1.empty in
List.iter
(fun (t1,t2) ->
let t1 = X1.cap d1 t1 in
if not (X1.is_empty t1) then
(resid := X1.cup !resid t1;
let t2 = X2.diff d2 t2 in
if not (X2.is_empty t2) then add res t1 t2 !res
)
) (normal n);
let d1 = X1.diff d1 !resid in
if not (X1.is_empty d1) then add res d1 d2 !res)
let boolean_normal x =
let res = ref (Obj.magic 0) in
List.iter (line res) x;
get [] !res
let boolean =
List.fold_left (fun accu x ->
let res = ref (Obj.magic 0) in
line res x;
get accu !res) []
let pi1 =
List.fold_left (fun accu (t1,t2) -> X1.cup accu t1) X1.empty
let pi2 =
List.fold_left (fun accu (t1,t2) -> X2.cup accu t2) X2.empty
let pi2_restricted restr =
List.fold_left (fun accu (t1,t2) ->
if X1.is_empty (X1.cap t1 restr) then accu
else X2.cup accu t2) X2.empty
end
*)
module Make(X1 : S)(X2 : S) =
struct
type t = (X1.t * X2.t) list
......
......@@ -37,9 +37,8 @@ let accept x = Types.internalize x.accept
let printed = ref []
let to_print = ref []
let rec print ppf (a,_,d) =
(* Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
match d with
| Constr t -> Types.Print.print_descr ppf t
| Constr t -> Types.Print.print ppf t
| Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
| Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
| Times (n1,n2) ->
......@@ -272,18 +271,6 @@ struct
type nnf = unit NodeSet.t * Types.descr (* pl,t; t <= \accept{pl} *)
(*
let rec compare_nodesl l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| p1::l1, p2::l2 ->
if p1.id < p2.id then -1
else if p1.id > p2.id then 1
else compare_nodesl l1 l2
| [], _ -> -1
| _ -> 1
*)
let compare_nnf (l1,t1) (l2,t2) =
let c = NodeSet.compare l1 l2 in if c <> 0 then c
else Types.compare_descr t1 t2
......@@ -469,9 +456,6 @@ struct
match lab with
| None -> assert false
| Some label ->
(* Printf.eprintf "[ l = %s; label = %s ]\n"
(LabelPool.value l)
(LabelPool.value label); *)
assert (label <= l);
if l == label then
let src = IdMap.constant SLeft p.fv in
......@@ -1113,7 +1097,7 @@ struct
Format.fprintf ppf ")" in
let print_basic (t,ret) =
Format.fprintf ppf " | %a -> %a@\n"
Types.Print.print_descr t
Types.Print.print t
print_ret ret
in
let print_prod2 = function
......@@ -1182,11 +1166,11 @@ struct
let print_dispatcher ppf d =
(* Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
d.id Types.Print.print_descr (Types.normalize d.t);
d.id Types.Print.print (Types.normalize d.t);
let print_code code (t, arity, m) =
Format.fprintf ppf " Returns $%i(arity=%i) for [%a]"
code arity
Types.Print.print_descr (Types.normalize t);
Types.Print.print (Types.normalize t);
(*
List.iter
(fun (i,b) ->
......
......@@ -30,17 +30,6 @@ val accept : node -> Types.node
val filter : Types.descr -> node -> (id * Types.node) list
(*
module Compiler: sig
type dispatcher
val make_dispatcher :
Types.descr ->
(node option * Types.descr) SortedList.t -> dispatcher
val print_disp: Format.formatter -> dispatcher -> unit
val demo: Format.formatter -> descr -> Types.descr -> unit
end
*)
(* Pattern matching: compilation *)
module Compile: sig
......
......@@ -408,11 +408,3 @@ struct
let equal (x:t) (y:t) = x = y
let compare (x:t) (y:t) = compare x y
end
include Make(
struct
type 'a t = 'a
let hash = Hashtbl.hash
let equal x y = x = y
let compare = compare
end)
(* Sorted list without duplicates.
Comparisons between elements are done by Pervasives.compare *)
module type ARG =
sig
type 'a t
......@@ -90,4 +87,3 @@ module Lift(X : ARG0) : ARG with type 'a t = X.t
module String : ARG0 with type t = string
include S with type 'a elem = 'a and type 'a t = 'a list
type ('a,'b) t = ('a * 'b) list
let rec unioni f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
let c = compare x1 x2 in
if c = 0 then (x1,(f x1 y1 y2))::(unioni f q1 q2)
else if c < 0 then t1::(unioni f q1 l2)
else t2::(unioni f l1 q2)
| ([],l2) -> l2
| (l1,[]) -> l1
let rec union f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
let c = compare x1 x2 in
if c = 0 then (x1,(f y1 y2))::(union f q1 q2)
else if c < 0 then t1::(union f q1 l2)
else t2::(union f l1 q2)
| ([],l2) -> l2
| (l1,[]) -> l1
let rec union_disj l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
let c = compare x1 x2 in
if c = 0 then failwith "SortedMap.union_disj"
else if c < 0 then t1::(union_disj q1 l2)
else t2::(union_disj l1 q2)
| ([],l2) -> l2
| (l1,[]) -> l1
let rec combine f1 f2 f12 l1 l2 =
match (l1,l2) with
| (x1,y1)::q1, (x2,y2)::q2 ->
let c = compare x1 x2 in
if c = 0 then (x1,(f12 y1 y2))::(combine f1 f2 f12 q1 q2)
else if c < 0 then (x1, f1 y1)::(combine f1 f2 f12 q1 l2)
else (x2, f2 y2)::(combine f1 f2 f12 l1 q2)
| ([],q2) -> List.map (fun (x2,y2) -> (x2,f2 y2)) l2
| (l1,[]) -> List.map (fun (x1,y1) -> (x1,f1 y1)) l1
let rec map f = function
| [] -> []
| (x,y)::q -> (x,f y)::(map f q)
let add f x y m =
union f [x,y] m
let change x f =
add (fun _ -> f) x
let rec set x y = function
| [] -> [x,y]
| (((x1,y1) as a)::l1) as l ->
let c = compare x1 x in
if c < 0 then a::(set x y l1)
else if c > 0 then (x,y)::l
else (x,y)::l1
let rec change_exists x1 f = function
| [] -> raise Not_found
| (x,y)::q when x = x1 -> (x,f y)::q
| h::q -> h::(change_exists x1 f q)
let rec diff l1 l2 =
match (l1,l2) with
| (((x1,y1) as t1)::q1, x2::q2) ->
let c = compare x1 x2 in
if c = 0 then diff q1 q2
else if c < 0 then t1::(diff q1 l2)
else diff l1 q2
| _ -> l1
let rec iter f = function
| [] -> ()
| (x,y)::q -> f x y; iter f q
let rec iter2 f12 f1 f2 l1 l2 =
match (l1,l2) with
| (x1,y1)::q1, (x2,y2)::q2 ->
let c = compare x1 x2 in
if c = 0 then (f12 x1 y1 y2; iter2 f12 f1 f2 q1 q2)
else if c < 0 then (f1 x1 y1; iter2 f12 f1 f2 q1 l2)
else (f2 x2 y2; iter2 f12 f1 f2 l1 q2)
| ([],l2) -> iter f2 l2
| (l1,[]) -> iter f1 l1
let rec from_sorted_list f = function
| (x1,y1)::(x2,y2)::q when x1 = x2 ->
from_sorted_list f ((x1, (f y1 y2))::q)
| (x,y)::q -> (x,y)::(from_sorted_list f q)
| l -> l
let from_list f l =
from_sorted_list f (List.sort (fun (a1,b1) (a2,b2) -> compare a1 a2) l)
type ('a,'b) t = ('a * 'b) list
val union: ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val unioni: ('a -> 'b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val union_disj: ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val combine: ('b -> 'd) -> ('c -> 'd) -> ('b -> 'c -> 'd) ->
('a,'b) t -> ('a,'c) t -> ('a,'d) t
val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t
val change: 'a -> ('b -> 'b) -> 'b -> ('a,'b) t -> ('a,'b) t
val set: 'a -> 'b -> ('a,'b) t -> ('a,'b) t
val change_exists: 'a -> ('b -> 'b) -> ('a,'b) t -> ('a,'b) t
val diff: ('a,'b) t -> 'a SortedList.t -> ('a,'b) t
val iter: ('a -> 'b -> unit) -> ('a,'b) t -> unit
val iter2:
('a -> 'b -> 'c -> unit) -> ('a -> 'b -> unit) -> ('a -> 'c -> unit)
-> ('a,'b) t -> ('a,'c) t -> unit
val from_sorted_list : ('b -> 'b -> 'b) -> ('a * 'b) SortedList.t -> ('a,'b) t
val from_list: ('b -> 'b -> 'b) -> ('a * 'b) list -> ('a,'b) t
......@@ -95,6 +95,8 @@ module RecArg = struct
let hash (o,r) = hash_rec (if o then 2 else 1) (LabelMap.get r)
end
(* It is also possible to use Boolean insteand of Bool here;
need to analyze when each one is more efficient *)
module BoolPair = Bool.Make(NodePair)
module BoolRec = Bool.Make(RecArg)
......@@ -240,6 +242,7 @@ struct
end
module DescrHash = Hashtbl.Make(Descr)
module DescrMap = Map.Make(Descr)
module DescrSet = Set.Make(Descr)
module Descr1 =
struct
......@@ -250,9 +253,9 @@ struct
end
module DescrSList = SortedList.Make(Descr1)
let hash_cons = DescrHash.create 17000
(* let hash_cons = DescrHash.create 17000 *)
let count = ref 0
let count = State.ref "Types.count" 0
let make () = incr count; { id = !count; descr = empty }
let define n d =
(* DescrHash.add hash_cons d n; *)
......@@ -269,8 +272,6 @@ let id n = n.id
let print_descr = ref (fun _ _ -> assert false)
let neg x = diff any x
let any_node = cons any
......@@ -383,7 +384,9 @@ let rec big_conj f l n =
| [] -> set n
| [arg] -> f arg n
| arg::rem ->
let s = { status = Maybe; active = false; notify = Do (n,(big_conj f rem), Nothing) } in
let s =
{ status = Maybe; active = false;
notify = Do (n,(big_conj f rem), Nothing) } in
try
f arg s;
if s.active then n.active <- true
......@@ -392,7 +395,9 @@ let rec big_conj f l n =
let rec guard a f n =
match slot a with
| { status = Empty } -> ()
| { status = Maybe } as s -> n.active <- true; s.notify <- Do (n,f,s.notify)
| { status = Maybe } as s ->
n.active <- true;
s.notify <- Do (n,f,s.notify)
| { status = NEmpty } -> f n
and slot d =
......@@ -402,15 +407,9 @@ and slot d =
(not d.absent)) then slot_not_empty
else try DescrHash.find memo d
with Not_found ->
(* incr count_slot;
Printf.eprintf "%i;" !count_slot; *)
(* Format.fprintf Format.std_formatter "Empty:%a@\n" !print_descr d; *)
let s = { status = Maybe; active = false; notify = Nothing } in
DescrHash.add memo d s;
(try
(* Format.fprintf Format.std_formatter "check_times_bool:@[%a@]@\n"
BoolPair.dump d.times; *)
(* check_times_bool any any d.times s; *)
iter_s s check_times (BoolPair.get d.times);
iter_s s check_times (BoolPair.get d.xml);
iter_s s check_arrow (BoolPair.get d.arrow);
......@@ -421,8 +420,6 @@ and slot d =
s
and check_times (left,right) s =
(* Printf.eprintf "[%i]" (List.length right);
flush stderr; *)
let rec aux accu1 accu2 right s = match right with
| (t1,t2)::right ->
let t1 = descr t1 and t2 = descr t2 in
......@@ -434,58 +431,22 @@ and check_times (left,right) s =
guard accu1' (aux accu1' accu2 right) s;
let accu2' = diff accu2 t2 in
guard accu2' (aux accu1 accu2' right) s
(* let accu1 = cap accu1 t1 in (* TODO: approximation of cap ... *)
let accu2' = diff accu2 t2 in
guard accu1 (guard accu2' (aux accu1 accu2' right)) s *)
guard accu2' (aux accu1 accu2' right) s
)
| [] -> set s
in
let (accu1,accu2) = cap_product left in
(* if List.length right > 6 then (
Printf.eprintf "HEURISTIC\n"; flush stderr;
let (n1,n2) = cup_product right in
let n1 = diff accu1 n1 and n2 = diff accu2 n2 in
guard n1 set s;
guard n2 set s;
Printf.eprintf "HEURISTIC failed\n"; flush stderr;
); *)
guard accu1 (guard accu2 (aux accu1 accu2 right)) s
(*
and check_times_bool accu1 accu2 b s =
match b with
| BoolPair.True -> guard accu1 (guard accu2 set) s
| BoolPair.False -> ()
| BoolPair.Split (_, (t1,t2), p,i,n) ->
check_times_bool accu1 accu2 i s;
let t1 = descr t1 and t2 = descr t2 in
if (trivially_disjoint accu1 t1 || trivially_disjoint accu2 t2)
then check_times_bool accu1 accu2 n s else
(
if p <> BoolPair.False then
(let accu1 = cap accu1 t1
and accu2 = cap accu2 t2 in
if not (trivially_empty accu1 || trivially_empty accu2) then
check_times_bool accu1 accu2 p s);
if n <> BoolPair.False then
(let accu1' = diff accu1 t1 in
check_times_bool accu1' accu2 n s;
let accu2' = diff accu2 t2 in
check_times_bool accu1 accu2' n s)
)
*)
and check_arrow (left,right) s =
let single_right (s1,s2) s =
let rec aux accu1 accu2 left s = match left with
| (t1,t2)::left ->
let accu1' = diff_t accu1 t1 in guard accu1' (aux accu1' accu2 left) s;
let accu2' = cap_t accu2 t2 in guard accu2' (aux accu1 accu2' left) s
let accu1' = diff_t accu1 t1 in
guard accu1' (aux accu1' accu2 left) s;
let accu2' = cap_t accu2 t2 in
guard accu2' (aux accu1 accu2' left) s
| [] -> set s
in
let accu1 = descr s1 in
......@@ -523,19 +484,19 @@ and check_record (labels,(oleft,left),rights) s =
let is_empty d =
(* Printf.eprintf "is_empty: start\n"; flush stderr; *)
let s = slot d in
List.iter
(fun s' ->
if s'.status == Maybe then s'.status <- Empty; s'.notify <- Nothing)
!marks;
marks := [];
(* Printf.eprintf "is_empty: done\n"; flush stderr; *)
s.status == Empty
module Assumptions = Set.Make(struct type t = descr let compare = compare_descr end)
let memo = ref Assumptions.empty
(*****************************************************************
Old (backtracking) implementation of the subtyping algo:
let memo = ref DescrSet.empty
let cache_false = DescrHash.create 33000
let rec empty_rec d =
......@@ -544,10 +505,10 @@ let rec empty_rec d =
else if not (Chars.is_empty d.chars) then false
else if d.absent then false
else if DescrHash.mem cache_false d then false
else if Assumptions.mem d !memo then true
else if DescrSet.mem d !memo then true
else (
let backup = !memo in
memo := Assumptions.add d backup;
memo := DescrSet.add d backup;
if
(empty_rec_times (BoolPair.get d.times)) &&
(empty_rec_times (BoolPair.get d.xml)) &&
......@@ -632,10 +593,10 @@ and empty_rec_record_aux (labels,(oleft,left),rights) =
and empty_rec_record c =
List.for_all empty_rec_record_aux (get_record c)
(*
let is_empty d =
empty_rec d
*)
*******************************************************************)
let non_empty d =
not (is_empty d)
......@@ -1246,7 +1207,7 @@ struct
| r -> (List.rev accu,Some r)
let print_descr ppf d =
let print ppf d =
let t = prepare d in
Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
(match List.rev !to_print with
......@@ -1265,13 +1226,8 @@ struct
count_name := 0;
to_print := [];
DescrHash.clear memo
let print ppf n = print_descr ppf (descr n)
end
let () = print_descr := Print.print_descr
module Positive =
struct
type rhs = [ `Type of descr | `Cup of v list | `Times of v * v | `Xml of v * v ]
......@@ -1335,7 +1291,7 @@ type t =
exception FoundSampleRecord of bool * (label * t) list
let rec sample_rec memo d =
if (Assumptions.mem d memo) || (is_empty d) then raise Not_found
if (DescrSet.mem d memo) || (is_empty d) then raise Not_found
else
try Int (Intervals.sample d.ints) with Not_found ->
try Atom (Atoms.sample d.atoms) with
......@@ -1344,7 +1300,7 @@ let rec sample_rec memo d =
try Char (Chars.sample d.chars) with Not_found ->
try sample_rec_arrow (BoolPair.get d.arrow) with Not_found ->
let memo = Assumptions.add d memo in
let memo = DescrSet.add d memo in
try Pair (sample_rec_times memo (BoolPair.get d.times)) with Not_found ->
try Xml (sample_rec_times memo (BoolPair.get d.xml)) with Not_found ->
try sample_rec_record memo d.record with Not_found ->
......@@ -1429,7 +1385,7 @@ and sample_rec_record_aux memo (labels,(oleft,left),rights) =
let get x = try sample_rec Assumptions.empty x with Not_found -> Other
let get x = try sample_rec DescrSet.empty x with Not_found -> Other
let rec print_sep f sep ppf = function
| [] -> ()
......@@ -1464,7 +1420,7 @@ and sample_rec_record_aux memo (labels,(oleft,left),rights) =
(print_sep
(fun ppf (t1,t2) ->
Format.fprintf ppf "%a -> %a; "
Print.print t1 Print.print t2
Print.print (descr t1) Print.print (descr t2)
)
" ; "
) iface
......@@ -1641,10 +1597,3 @@ module Char = struct
let get d = d.chars
let any = { empty with chars = Chars.any }
end
let print_stat ppf =
(* Format.fprintf ppf "nb_rec = %i@." !nb_rec;
Format.fprintf ppf "nb_norec = %i@." !nb_norec;
*)
()
......@@ -204,8 +204,6 @@ module Print :
sig
val register_global : string -> descr -> unit
val print_const : Format.formatter -> const -> unit
val print : Format.formatter -> node -> unit
val print_descr: Format.formatter -> descr -> unit
val print: Format.formatter -> descr -> unit
end
val print_stat: Format.formatter -> unit
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!