aboutsummaryrefslogtreecommitdiff
path: root/plugins/cc
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/cc')
-rw-r--r--plugins/cc/ccalgo.ml71
-rw-r--r--plugins/cc/ccalgo.mli2
-rw-r--r--plugins/cc/cctac.ml35
-rw-r--r--plugins/cc/g_congruence.mlg (renamed from plugins/cc/g_congruence.ml4)14
-rw-r--r--plugins/cc/plugin_base.dune5
5 files changed, 56 insertions, 71 deletions
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index 5a48189260..a6f432b5bd 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -9,7 +9,7 @@
(************************************************************************)
(* This file implements the basic congruence-closure algorithm by *)
-(* Downey,Sethi and Tarjan. *)
+(* Downey, Sethi and Tarjan. *)
(* Plus some e-matching and constructor handling by P. Corbineau *)
open CErrors
@@ -18,7 +18,6 @@ open Names
open Sorts
open Constr
open Vars
-open Evd
open Goptions
open Tacmach
open Util
@@ -27,6 +26,10 @@ let init_size=5
let cc_verbose=ref false
+let print_constr t =
+ let sigma, env = Pfedit.get_current_context () in
+ Printer.pr_econstr_env env sigma t
+
let debug x =
if !cc_verbose then Feedback.msg_debug (x ())
@@ -131,8 +134,8 @@ type cinfo=
ci_nhyps: int} (* # projectable args *)
let family_eq f1 f2 = match f1, f2 with
- | Prop Pos, Prop Pos
- | Prop Null, Prop Null
+ | Set, Set
+ | Prop, Prop
| Type _, Type _ -> true
| _ -> false
@@ -272,7 +275,8 @@ type state =
mutable rew_depth:int;
mutable changed:bool;
by_type: Int.Set.t Typehash.t;
- mutable gls:Goal.goal Evd.sigma}
+ mutable env:Environ.env;
+ sigma:Evd.evar_map}
let dummy_node =
{
@@ -307,7 +311,8 @@ let empty depth gls:state =
rew_depth=depth;
by_type=Constrhash.create init_size;
changed=false;
- gls=gls
+ env=pf_env gls;
+ sigma=project gls
}
let forest state = state.uf
@@ -328,9 +333,6 @@ let get_representative uf i=
let get_constructors uf i= uf.map.(i).constructors
-let find_pac uf i pac =
- PacMap.find pac (get_constructors uf i)
-
let rec find_oldest_pac uf i pac=
try PacMap.find pac (get_constructors uf i) with
Not_found ->
@@ -426,7 +428,7 @@ let cc_product s1 s2 =
mkLambda(_B_,mkSort(s2),_body_))
let rec constr_of_term = function
- Symb s-> applist_projection s []
+ Symb s-> s
| Product(s1,s2) -> cc_product s1 s2
| Eps id -> mkVar id
| Constructor cinfo -> mkConstructU cinfo.ci_constr
@@ -434,25 +436,7 @@ let rec constr_of_term = function
make_app [(constr_of_term s2)] s1
and make_app l=function
Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
- | other ->
- applist_proj other l
-and applist_proj c l =
- match c with
- | Symb s -> applist_projection s l
- | _ -> Term.applistc (constr_of_term c) l
-and applist_projection c l =
- match Constr.kind c with
- | Const c when Environ.is_projection (fst c) (Global.env()) ->
- let p = Projection.make (fst c) false in
- (match l with
- | [] -> (* Expand the projection *)
- let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *)
- let pb = Environ.lookup_projection p (Global.env()) in
- let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in
- Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx
- | hd :: tl ->
- Term.applistc (mkProj (p, hd)) tl)
- | _ -> Term.applistc c l
+ | other -> Term.applist (constr_of_term other,l)
let rec canonize_name sigma c =
let c = EConstr.Unsafe.to_constr c in
@@ -474,10 +458,10 @@ let rec canonize_name sigma c =
| LetIn (na,b,t,ct) ->
mkLetIn (na, func b,func t,func ct)
| App (ct,l) ->
- mkApp (func ct,Array.smartmap func l)
+ mkApp (func ct,Array.Smart.map func l)
| Proj(p,c) ->
let p' = Projection.map (fun kn ->
- Constant.make1 (Constant.canonical kn)) p in
+ MutInd.make1 (MutInd.canonical kn)) p in
(mkProj (p', func c))
| _ -> c
@@ -500,10 +484,10 @@ let rec inst_pattern subst = function
args t
let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++
- Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]"
+ print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]"
let pr_term t = str "[" ++
- Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]"
+ print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]"
let rec add_term state t=
let uf=state.uf in
@@ -511,8 +495,8 @@ let rec add_term state t=
Not_found ->
let b=next uf in
let trm = constr_of_term t in
- let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in
- let typ = canonize_name (project state.gls) typ in
+ let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in
+ let typ = canonize_name state.sigma typ in
let new_node=
match t with
Symb _ | Product (_,_) ->
@@ -618,7 +602,7 @@ let add_inst state (inst,int_subst) =
begin
debug (fun () ->
(str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
- (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++
+ (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++
pr_term s ++ str " == " ++ pr_term t ++ str "]"));
add_equality state prf s t
end
@@ -626,7 +610,7 @@ let add_inst state (inst,int_subst) =
begin
debug (fun () ->
(str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
- (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++
+ (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++
pr_term s ++ str " <> " ++ pr_term t ++ str "]"));
add_disequality state (Hyp prf) s t
end
@@ -820,11 +804,10 @@ let one_step state =
let __eps__ = Id.of_string "_eps_"
let new_state_var typ state =
- let id = pf_get_new_id __eps__ state.gls in
- let {it=gl ; sigma=sigma} = state.gls in
- let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in
- state.gls<- gls;
- id
+ let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in
+ let id = Namegen.next_ident_away __eps__ ids in
+ state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (id,typ)) state.env;
+ id
let complete_one_class state i=
match (get_representative state.uf i).inductive_status with
@@ -832,9 +815,9 @@ let complete_one_class state i=
let rec app t typ n =
if n<=0 then t else
let _,etyp,rest= destProd typ in
- let id = new_state_var etyp state in
+ let id = new_state_var (EConstr.of_constr etyp) state in
app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in
- let _c = pf_unsafe_type_of state.gls
+ let _c = Typing.unsafe_type_of state.env state.sigma
(EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in
let _c = EConstr.Unsafe.to_constr _c in
let _args =
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index 4ebc6a135a..d52e83dc31 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -145,8 +145,6 @@ val tail_pac : pa_constructor -> pa_constructor
val find : forest -> int -> int
-val find_pac : forest -> int -> pa_constructor -> int
-
val find_oldest_pac : forest -> int -> pa_constructor -> int
val term : forest -> int -> term
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index d19817e74e..055d36747d 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -28,17 +28,13 @@ open Proofview.Notations
module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
-let reference dir s = lazy (Coqlib.coq_reference "CC" dir s)
-
-let _f_equal = reference ["Init";"Logic"] "f_equal"
-let _eq_rect = reference ["Init";"Logic"] "eq_rect"
-let _refl_equal = reference ["Init";"Logic"] "eq_refl"
-let _sym_eq = reference ["Init";"Logic"] "eq_sym"
-let _trans_eq = reference ["Init";"Logic"] "eq_trans"
-let _eq = reference ["Init";"Logic"] "eq"
-let _False = reference ["Init";"Logic"] "False"
-let _True = reference ["Init";"Logic"] "True"
-let _I = reference ["Init";"Logic"] "I"
+let _f_equal = lazy (Coqlib.lib_ref "core.eq.congr")
+let _eq_rect = lazy (Coqlib.lib_ref "core.eq.rect")
+let _refl_equal = lazy (Coqlib.lib_ref "core.eq.refl")
+let _sym_eq = lazy (Coqlib.lib_ref "core.eq.sym")
+let _trans_eq = lazy (Coqlib.lib_ref "core.eq.trans")
+let _eq = lazy (Coqlib.lib_ref "core.eq.type")
+let _False = lazy (Coqlib.lib_ref "core.False.type")
let whd env sigma t =
Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t
@@ -49,7 +45,7 @@ let whd_delta env sigma t =
(* decompose member of equality in an applicative format *)
(** FIXME: evar leak *)
-let sf_of env sigma c = e_sort_of env (ref sigma) c
+let sf_of env sigma c = snd (sort_of env sigma c)
let rec decompose_term env sigma t=
match EConstr.kind sigma (whd env sigma t) with
@@ -84,13 +80,13 @@ let rec decompose_term env sigma t=
let canon_const = Constant.make1 (Constant.canonical c) in
(Symb (Constr.mkConstU (canon_const,u)))
| Proj (p, c) ->
- let canon_const kn = Constant.make1 (Constant.canonical kn) in
- let p' = Projection.map canon_const p in
+ let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in
+ let p' = Projection.map canon_mind p in
let c = Retyping.expand_projection env sigma p' c [] in
decompose_term env sigma c
| _ ->
let t = Termops.strip_outer_cast sigma t in
- if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found
+ if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found
(* decompose equality in members and type *)
open Termops
@@ -264,9 +260,8 @@ let app_global_with_holes f args n =
let ans = mkApp (fc, args) in
let (sigma, holes) = gen_holes env sigma t n [] in
let ans = applist (ans, holes) in
- let evdref = ref sigma in
- let () = Typing.e_check env evdref ans concl in
- (!evdref, ans)
+ let sigma = Typing.check env sigma ans concl in
+ (sigma, ans)
end
end
@@ -424,7 +419,7 @@ let build_term_to_complete uf pac =
let cc_tactic depth additionnal_terms =
Proofview.Goal.enter begin fun gl ->
let sigma = Tacmach.New.project gl in
- Coqlib.check_required_library Coqlib.logic_module_name;
+ Coqlib.(check_required_library logic_module_name);
let _ = debug (fun () -> Pp.str "Reading subgoal ...") in
let state = make_prb gl depth additionnal_terms in
let _ = debug (fun () -> Pp.str "Problem built, solving ...") in
@@ -444,7 +439,7 @@ let cc_tactic depth additionnal_terms =
let open Glob_term in
let env = Proofview.Goal.env gl in
let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in
- let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in
+ let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in
let pr_missing (c, missing) =
let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in
let holes = List.init missing (fun _ -> hole) in
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.mlg
index fb013ac131..685059294f 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.mlg
@@ -8,22 +8,26 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
+{
+
open Ltac_plugin
open Cctac
open Stdarg
+}
+
DECLARE PLUGIN "cc_plugin"
(* Tactic registration *)
TACTIC EXTEND cc
- [ "congruence" ] -> [ congruence_tac 1000 [] ]
- |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
- |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ]
+| [ "congruence" ] -> { congruence_tac 1000 [] }
+| [ "congruence" integer(n) ] -> { congruence_tac n [] }
+| [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l }
|[ "congruence" integer(n) "with" ne_constr_list(l) ] ->
- [ congruence_tac n l ]
+ { congruence_tac n l }
END
TACTIC EXTEND f_equal
- [ "f_equal" ] -> [ f_equal ]
+| [ "f_equal" ] -> { f_equal }
END
diff --git a/plugins/cc/plugin_base.dune b/plugins/cc/plugin_base.dune
new file mode 100644
index 0000000000..2a92996d2a
--- /dev/null
+++ b/plugins/cc/plugin_base.dune
@@ -0,0 +1,5 @@
+(library
+ (name cc_plugin)
+ (public_name coq.plugins.cc)
+ (synopsis "Coq's congruence closure plugin")
+ (libraries coq.plugins.ltac))
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 18:30:18 +0000