Commit 65feefa1 authored by Andrei Paskevich's avatar Andrei Paskevich Committed by François Bobot

add_new for maps and sets + some minor changes

parent 87923af7
...@@ -236,7 +236,8 @@ let check_termination ldl = ...@@ -236,7 +236,8 @@ let check_termination ldl =
Mls.iter (build_call_graph cgr syms) syms; Mls.iter (build_call_graph cgr syms) syms;
let check ls _ = let check ls _ =
let cl = build_call_list cgr ls in let cl = build_call_list cgr ls in
check_call_list ls cl in check_call_list ls cl
in
Mls.mapi check syms Mls.mapi check syms
(** Inductive predicate declaration *) (** Inductive predicate declaration *)
...@@ -372,8 +373,7 @@ exception EmptyDecl ...@@ -372,8 +373,7 @@ exception EmptyDecl
exception EmptyAlgDecl of tysymbol exception EmptyAlgDecl of tysymbol
exception EmptyIndDecl of lsymbol exception EmptyIndDecl of lsymbol
let news_id s id = Sid.change id (fun there -> let news_id s id = Sid.add_new id (ClashIdent id) s
if there then raise (ClashIdent id) else true) s
let syms_ts s ts = Sid.add ts.ts_name s let syms_ts s ts = Sid.add ts.ts_name s
let syms_ls s ls = Sid.add ls.ls_name s let syms_ls s ls = Sid.add ls.ls_name s
......
...@@ -67,23 +67,22 @@ module Compile (X : Action) = struct ...@@ -67,23 +67,22 @@ module Compile (X : Action) = struct
in in
(* dispatch every case to a primitive constructor/wild case *) (* dispatch every case to a primitive constructor/wild case *)
let cases,wilds = let cases,wilds =
let change_case fs pl a cases = let add_case fs pl a cases =
Mls.change fs (function Mls.change fs (function
| None -> Some [pl,a] | None -> Some [pl,a]
| Some rl -> Some ((pl,a)::rl)) cases in | Some rl -> Some ((pl,a)::rl)) cases
in
let union_cases pl a types cases = let union_cases pl a types cases =
let make_wild pl a ql = let add pl q = pat_wild q.pat_ty :: pl in
let add pl q = pat_wild q.pat_ty :: pl in let wild ql = [List.fold_left add pl ql, a] in
[List.fold_left add pl ql,a] let join _ wl rl = Some (List.append wl rl) in
in Mls.union join (Mls.map wild types) cases
let types = Mls.map (make_wild pl a) types in in
Mls.union (fun _ pla rl -> Some (List.append pla rl))
types cases in
let rec dispatch (pl,a) (cases,wilds) = let rec dispatch (pl,a) (cases,wilds) =
let p = List.hd pl in let pl = List.tl pl in let p = List.hd pl in let pl = List.tl pl in
match p.pat_node with match p.pat_node with
| Papp (fs,pl') -> | Papp (fs,pl') ->
change_case fs (List.rev_append pl' pl) a cases, wilds add_case fs (List.rev_append pl' pl) a cases, wilds
| Por (p,q) -> | Por (p,q) ->
dispatch (p::pl, a) (dispatch (q::pl, a) (cases,wilds)) dispatch (p::pl, a) (dispatch (q::pl, a) (cases,wilds))
| Pas (p,x) -> | Pas (p,x) ->
...@@ -129,8 +128,8 @@ module Compile (X : Action) = struct ...@@ -129,8 +128,8 @@ module Compile (X : Action) = struct
if Mls.mem cs types then comp_cases cs al else comp_wilds () if Mls.mem cs types then comp_cases cs al else comp_wilds ()
| _ -> | _ ->
let base = let base =
if Mls.submap (fun _ () _ -> true) css types if Mls.submap (const3 true) css types then []
then [] else [mk_branch (pat_wild ty) (comp_wilds ())] else [mk_branch (pat_wild ty) (comp_wilds ())]
in in
let add cs ql acc = let add cs ql acc =
let get_vs q = create_vsymbol (id_fresh "x") q.pat_ty in let get_vs q = create_vsymbol (id_fresh "x") q.pat_ty in
......
...@@ -142,16 +142,12 @@ let remove_prop pr = ...@@ -142,16 +142,12 @@ let remove_prop pr =
let get_syntax_map task = let get_syntax_map task =
let add_ts td m = match td.td_node with let add_ts td m = match td.td_node with
| Meta (_,[MAts ts; MAstr s]) -> | Meta (_,[MAts ts; MAstr s]) ->
Mid.change ts.ts_name (function Mid.add_new ts.ts_name s (KnownTypeSyntax ts) m
| None -> Some s
| Some _ -> raise (KnownTypeSyntax ts)) m
| _ -> assert false | _ -> assert false
in in
let add_ls td m = match td.td_node with let add_ls td m = match td.td_node with
| Meta (_,[MAls ls; MAstr s]) -> | Meta (_,[MAls ls; MAstr s]) ->
Mid.change ls.ls_name (function Mid.add_new ls.ls_name s (KnownLogicSyntax ls) m
| None -> Some s
| Some _ -> raise (KnownLogicSyntax ls)) m
| _ -> assert false | _ -> assert false
in in
let m = Mid.empty in let m = Mid.empty in
......
...@@ -139,9 +139,7 @@ exception DuplicateTypeVar of tvsymbol ...@@ -139,9 +139,7 @@ exception DuplicateTypeVar of tvsymbol
exception UnboundTypeVar of tvsymbol exception UnboundTypeVar of tvsymbol
let create_tysymbol name args def = let create_tysymbol name args def =
let add s v = Stv.change v (fun there -> let add s v = Stv.add_new v (DuplicateTypeVar v) s in
if there then raise (DuplicateTypeVar v) else true) s
in
let s = List.fold_left add Stv.empty args in let s = List.fold_left add Stv.empty args in
let rec vars () ty = match ty.ty_node with let rec vars () ty = match ty.ty_node with
| Tyvar v when not (Stv.mem v s) -> raise (UnboundTypeVar v) | Tyvar v when not (Stv.mem v s) -> raise (UnboundTypeVar v)
......
...@@ -62,6 +62,7 @@ module type S = ...@@ -62,6 +62,7 @@ module type S =
val mapi_fold: val mapi_fold:
(key -> 'a -> 'acc -> 'acc * 'b) -> 'a t -> 'acc -> 'acc * 'b t (key -> 'a -> 'acc -> 'acc * 'b) -> 'a t -> 'acc -> 'acc * 'b t
val translate : (key -> key) -> 'a t -> 'a t val translate : (key -> key) -> 'a t -> 'a t
val add_new : key -> 'a -> exn -> 'a t -> 'a t
module type Set = module type Set =
sig sig
...@@ -95,6 +96,7 @@ module type S = ...@@ -95,6 +96,7 @@ module type S =
val inter : t -> t -> t val inter : t -> t -> t
val diff : t -> t -> t val diff : t -> t -> t
val translate : (elt -> elt) -> t -> t val translate : (elt -> elt) -> t -> t
val add_new : elt -> exn -> t -> t
end end
module Set : Set module Set : Set
...@@ -496,6 +498,10 @@ module Make(Ord: OrderedType) = struct ...@@ -496,6 +498,10 @@ module Make(Ord: OrderedType) = struct
Node(l,v,d,r,h),last in Node(l,v,d,r,h),last in
let m,_ = aux None m in m let m,_ = aux None m in m
let add_new x v e m = change x (function
| Some _ -> raise e
| None -> Some v) m
module type Set = module type Set =
sig sig
type elt = key type elt = key
...@@ -528,6 +534,7 @@ module Make(Ord: OrderedType) = struct ...@@ -528,6 +534,7 @@ module Make(Ord: OrderedType) = struct
val inter : t -> t -> t val inter : t -> t -> t
val diff : t -> t -> t val diff : t -> t -> t
val translate : (elt -> elt) -> t -> t val translate : (elt -> elt) -> t -> t
val add_new : elt -> exn -> t -> t
end end
module Set = module Set =
...@@ -568,6 +575,7 @@ module Make(Ord: OrderedType) = struct ...@@ -568,6 +575,7 @@ module Make(Ord: OrderedType) = struct
let inter = inter (fun _ _ _ -> Some ()) let inter = inter (fun _ _ _ -> Some ())
let diff = diff (fun _ _ _ -> None) let diff = diff (fun _ _ _ -> None)
let translate = translate let translate = translate
let add_new x = add_new x ()
end end
end end
......
...@@ -225,6 +225,10 @@ module type S = ...@@ -225,6 +225,10 @@ module type S =
function [f]. [f] must be strictly monotone on the key of [m]. function [f]. [f] must be strictly monotone on the key of [m].
Otherwise it raises invalid_arg *) Otherwise it raises invalid_arg *)
val add_new : key -> 'a -> exn -> 'a t -> 'a t
(** [add_new x v e m] binds [x] to [v] in [m] if [x] is not bound,
and raises [exn] otherwise. *)
module type Set = module type Set =
sig sig
type elt = key type elt = key
...@@ -340,6 +344,10 @@ module type S = ...@@ -340,6 +344,10 @@ module type S =
(** [translate f s] translates the elements in the set [s] by the (** [translate f s] translates the elements in the set [s] by the
function [f]. [f] must be strictly monotone on the elements of [s]. function [f]. [f] must be strictly monotone on the elements of [s].
Otherwise it raises invalid_arg *) Otherwise it raises invalid_arg *)
val add_new : elt -> exn -> t -> t
(** [add_new x e s] adds [x] to [s] if [s] does not contain [x],
and raises [exn] otherwise. *)
end end
module Set : Set module Set : Set
......
...@@ -16,13 +16,19 @@ ...@@ -16,13 +16,19 @@
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Stdlib open Stdlib
(* useful combinators *) (* useful combinators *)
let ($) f x = f x let ($) f x = f x
let const f _ = f let const f _ = f
let const2 f _ _ = f
let const3 f _ _ _ = f
let flip f x y = f y x let flip f x y = f y x
let cons f acc x = (f x)::acc let cons f acc x = (f x)::acc
......
...@@ -16,13 +16,19 @@ ...@@ -16,13 +16,19 @@
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *) (* *)
(**************************************************************************) (**************************************************************************)
open Stdlib open Stdlib
(** Useful functions *) (** Useful functions *)
val ($) : ('a -> 'b) -> 'a -> 'b val ($) : ('a -> 'b) -> 'a -> 'b
val const : 'a -> 'b -> 'a val const : 'a -> 'b -> 'a
val const2 : 'a -> 'b -> 'c -> 'a
val const3 : 'a -> 'b -> 'c -> 'd -> 'a
val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
val cons : ('a -> 'b) -> 'b list -> 'a -> 'b list val cons : ('a -> 'b) -> 'b list -> 'a -> 'b list
...@@ -85,6 +91,7 @@ val any_fn : ('a -> bool) -> 'b -> 'a -> bool ...@@ -85,6 +91,7 @@ val any_fn : ('a -> bool) -> 'b -> 'a -> bool
val ffalse : 'a -> bool val ffalse : 'a -> bool
(** [ffalse] constant function [false] *) (** [ffalse] constant function [false] *)
val ttrue : 'a -> bool val ttrue : 'a -> bool
(** [ttrue] constant function [true] *) (** [ttrue] constant function [true] *)
...@@ -120,7 +127,7 @@ module OrderedHashList (X : Tagged) : OrderedHash with type t = X.t list ...@@ -120,7 +127,7 @@ module OrderedHashList (X : Tagged) : OrderedHash with type t = X.t list
module StructMake (X : Tagged) : module StructMake (X : Tagged) :
sig sig
module M : Map.S with type key = X.t module M : Map.S with type key = X.t
module S : M.Set with type elt = X.t module S : M.Set
module H : Hashtbl.S with type key = X.t module H : Hashtbl.S with type key = X.t
end end
......
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