aboutsummaryrefslogtreecommitdiff
path: root/plugins/setoid_ring
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/setoid_ring')
-rw-r--r--plugins/setoid_ring/ArithRing.v6
-rw-r--r--plugins/setoid_ring/BinList.v2
-rw-r--r--plugins/setoid_ring/Cring.v2
-rw-r--r--plugins/setoid_ring/Field.v2
-rw-r--r--plugins/setoid_ring/Field_tac.v2
-rw-r--r--plugins/setoid_ring/Field_theory.v2
-rw-r--r--plugins/setoid_ring/InitialRing.v56
-rw-r--r--plugins/setoid_ring/NArithRing.v4
-rw-r--r--plugins/setoid_ring/Ncring.v2
-rw-r--r--plugins/setoid_ring/Ncring_initial.v6
-rw-r--r--plugins/setoid_ring/Ncring_polynom.v2
-rw-r--r--plugins/setoid_ring/Ncring_tac.v2
-rw-r--r--plugins/setoid_ring/Ring.v8
-rw-r--r--plugins/setoid_ring/Ring_base.v2
-rw-r--r--plugins/setoid_ring/Ring_polynom.v2
-rw-r--r--plugins/setoid_ring/Ring_theory.v2
-rw-r--r--plugins/setoid_ring/ZArithRing.v10
-rw-r--r--plugins/setoid_ring/g_newring.ml423
-rw-r--r--plugins/setoid_ring/newring.ml130
-rw-r--r--plugins/setoid_ring/newring.mli4
20 files changed, 156 insertions, 113 deletions
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index e7d0cd8e78..5f5b97925f 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -32,13 +32,13 @@ Qed.
Ltac natcst t :=
match isnatcst t with
true => constr:(N.of_nat t)
- | _ => constr:InitialRing.NotConstant
+ | _ => constr:(InitialRing.NotConstant)
end.
Ltac Ss_to_add f acc :=
match f with
| S ?f1 => Ss_to_add f1 (S acc)
- | _ => constr:(acc + f)%nat
+ | _ => constr:((acc + f)%nat)
end.
Ltac natprering :=
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 5dd1b86dd2..d639f6085f 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
index 4872c7764d..17a57e62a7 100644
--- a/plugins/setoid_ring/Cring.v
+++ b/plugins/setoid_ring/Cring.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
index 4de2efe37e..73a131398b 100644
--- a/plugins/setoid_ring/Field.v
+++ b/plugins/setoid_ring/Field.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
index f867c6d08a..babbb86a96 100644
--- a/plugins/setoid_ring/Field_tac.v
+++ b/plugins/setoid_ring/Field_tac.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index 0f5c49b0ff..2932d379e0 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index b92b847be5..8fcc077164 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -155,7 +155,7 @@ Section ZMORPHISM.
Ltac norm := gen_srewrite Rsth Reqe ARth.
Ltac add_push := gen_add_push radd Rsth Reqe ARth.
-(*morphisms are extensionaly equal*)
+(*morphisms are extensionally equal*)
Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
Proof.
destruct x;simpl; try rewrite (same_gen ARth);rrefl.
@@ -246,7 +246,7 @@ Proof (SRth_ARth Nsth Nth).
Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y.
Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed.
-(**Same as above : definition of two,extensionaly equal, generic morphisms *)
+(**Same as above : definition of two, extensionally equal, generic morphisms *)
(**from N to any semi-ring*)
Section NMORPHISM.
Variable R : Type.
@@ -612,32 +612,32 @@ End GEN_DIV.
Ltac inv_gen_phi_pos rI add mul t :=
let rec inv_cst t :=
match t with
- rI => constr:1%positive
- | (add rI rI) => constr:2%positive
- | (add rI (add rI rI)) => constr:3%positive
+ rI => constr:(1%positive)
+ | (add rI rI) => constr:(2%positive)
+ | (add rI (add rI rI)) => constr:(3%positive)
| (mul (add rI rI) ?p) => (* 2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *)
| ?p => constr:(xO p)
end
| (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant)
| ?p => constr:(xI p)
end
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end in
inv_cst t.
(* The (partial) inverse of gen_phiNword *)
Ltac inv_gen_phiNword rO rI add mul opp t :=
match t with
- rO => constr:NwO
+ rO => constr:(NwO)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p::nil)
end
end.
@@ -646,10 +646,10 @@ End GEN_DIV.
(* The inverse of gen_phiN *)
Ltac inv_gen_phiN rO rI add mul t :=
match t with
- rO => constr:0%N
+ rO => constr:(0%N)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p)
end
end.
@@ -657,21 +657,21 @@ End GEN_DIV.
(* The inverse of gen_phiZ *)
Ltac inv_gen_phiZ rO rI add mul opp t :=
match t with
- rO => constr:0%Z
+ rO => constr:(0%Z)
| (opp ?p) =>
match inv_gen_phi_pos rI add mul p with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zneg p)
end
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zpos p)
end
end.
(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above
- are only optimisations that directly returns the reifid constant
+ are only optimisations that directly returns the reified constant
instead of resorting to the constant propagation of the simplification
algorithm. *)
Ltac inv_gen_phi rO rI cO cI t :=
@@ -681,7 +681,7 @@ Ltac inv_gen_phi rO rI cO cI t :=
end.
(* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:NotConstant.
+ Ltac inv_morph_nothing t := constr:(NotConstant).
Ltac coerce_to_almost_ring set ext rspec :=
match type of rspec with
@@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
(* Tactic for constant *)
Ltac isnatcst t :=
match t with
- O => constr:true
+ O => constr:(true)
| S ?p => isnatcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isPcst t :=
match t with
| xI ?p => isPcst p
| xO ?p => isPcst p
- | xH => constr:true
+ | xH => constr:(true)
(* nat -> positive *)
| Pos.of_succ_nat ?n => isnatcst n
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isNcst t :=
match t with
- N0 => constr:true
+ N0 => constr:(true)
| Npos ?p => isPcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isZcst t :=
match t with
- Z0 => constr:true
+ Z0 => constr:(true)
| Zpos ?p => isPcst p
| Zneg ?p => isPcst p
(* injection nat -> Z *)
@@ -857,7 +857,7 @@ Ltac isZcst t :=
(* injection N -> Z *)
| Z.of_N ?n => isNcst n
(* *)
- | _ => constr:false
+ | _ => constr:(false)
end.
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index a10eeecce0..54e2789ba4 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -15,7 +15,7 @@ Set Implicit Arguments.
Ltac Ncst t :=
match isNcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v
index 2dc3197d19..cd3bef4353 100644
--- a/plugins/setoid_ring/Ncring.v
+++ b/plugins/setoid_ring/Ncring.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index c40e0ffbaa..96885d2f7a 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -42,7 +42,7 @@ Defined.
(*Instance ZEquality: @Equality Z:= (@eq Z).*)
-(** Two generic morphisms from Z to (abrbitrary) rings, *)
+(** Two generic morphisms from Z to (arbitrary) rings, *)
(**second one is more convenient for proofs but they are ext. equal*)
Section ZMORPHISM.
Context {R:Type}`{Ring R}.
@@ -130,7 +130,7 @@ Ltac rsimpl := simpl.
Qed.
-(*morphisms are extensionaly equal*)
+(*morphisms are extensionally equal*)
Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
Proof.
destruct x;rsimpl; try rewrite same_gen; reflexivity.
diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v
index 5845b62982..109808ee0f 100644
--- a/plugins/setoid_ring/Ncring_polynom.v
+++ b/plugins/setoid_ring/Ncring_polynom.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v
index 31c9e54d96..5e30a13000 100644
--- a/plugins/setoid_ring/Ncring_tac.v
+++ b/plugins/setoid_ring/Ncring_tac.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index b2417db6f4..77576cb933 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -36,9 +36,9 @@ Qed.
Ltac bool_cst t :=
let t := eval hnf in t in
match t with
- true => constr:true
- | false => constr:false
- | _ => constr:NotConstant
+ true => constr:(true)
+ | false => constr:(false)
+ | _ => constr:(NotConstant)
end.
Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index 9508b8e780..dc7c10cc5f 100644
--- a/plugins/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 2d2756b1c8..760ad4da11 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 4f05f0d4a9..7fcd6c08a7 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 848e06a7b4..23784cf33f 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -17,14 +17,14 @@ Set Implicit Arguments.
Ltac Zcst t :=
match isZcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac isZpow_coef t :=
match t with
| Zpos ?p => isPcst p
- | Z0 => constr:true
- | _ => constr:false
+ | Z0 => constr:(true)
+ | _ => constr:(false)
end.
Notation N_of_Z := Z.to_N (only parsing).
@@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing).
Ltac Zpow_tac t :=
match isZpow_coef t with
| true => constr:(N_of_Z t)
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac Zpower_neg :=
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
index 856ec0db5f..1ebb6e6b77 100644
--- a/plugins/setoid_ring/g_newring.ml4
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -14,6 +14,11 @@ open Libnames
open Printer
open Newring_ast
open Newring
+open Stdarg
+open Constrarg
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Tactic
DECLARE PLUGIN "newring_plugin"
@@ -46,9 +51,14 @@ VERNAC ARGUMENT EXTEND ring_mod
| [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
END
+VERNAC ARGUMENT EXTEND ring_mods
+ | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
- | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
- [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
+ | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
add_theory id (ic t) set k cst (pre,post) power sign div]
| [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
msg_notice (strbrk "The following ring structures have been declared:");
@@ -70,9 +80,14 @@ VERNAC ARGUMENT EXTEND field_mod
| [ "completeness" constr(inj) ] -> [ Inject inj ]
END
+VERNAC ARGUMENT EXTEND field_mods
+ | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
- [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
msg_notice (strbrk "The following field structures have been declared:");
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
index f73a15dba0..7ef89b7a0e 100644
--- a/plugins/setoid_ring/newring.ml
+++ b/plugins/setoid_ring/newring.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Pp
open Errors
open Util
@@ -31,6 +29,7 @@ open Decl_kinds
open Entries
open Misctypes
open Newring_ast
+open Proofview.Notations
(****************************************************************************)
(* controlled reduction *)
@@ -98,10 +97,10 @@ let protect_red map env sigma c =
(mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
let protect_tac map =
- Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
+ Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) None);;
let protect_tac_in map id =
- Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
+ Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)));;
(****************************************************************************)
@@ -136,8 +135,8 @@ let closed_term_ast l =
let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
TacFun([Some(Id.of_string"t")],
TacML(Loc.ghost,tacname,
- [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None);
- Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l]))
+ [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
+ TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)]))
(*
let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
*)
@@ -145,14 +144,19 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
(****************************************************************************)
let ic c =
- let env = Global.env() and sigma = Evd.empty in
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
Constrintern.interp_open_constr env sigma c
let ic_unsafe c = (*FIXME remove *)
- let env = Global.env() and sigma = Evd.empty in
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
fst (Constrintern.interp_constr env sigma c)
-let ty c = Typing.unsafe_type_of (Global.env()) Evd.empty c
+let ty c =
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
+ Typing.unsafe_type_of env sigma c
let decl_constant na ctx c =
let vars = Universes.universes_of_constr c in
@@ -170,19 +174,20 @@ let ltac_call tac (args:glob_tactic_arg list) =
let ltac_lcall tac args =
TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
-let ltac_letin (x, e1) e2 =
- TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2)
-
-let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
- Tacinterp.eval_tactic
- (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
+let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id arg lfun)
+ in
+ let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+ let lfun = Id.Map.add (Id.of_string "F") f lfun in
+ let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args)
let ltac_record flds =
TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds)
-
-let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
-
let dummy_goal env sigma =
let (gl,_,sigma) =
Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in
@@ -192,20 +197,39 @@ let constr_of v = match Value.to_constr v with
| Some c -> c
| None -> failwith "Ring.exec_tactic: anomaly"
+let tactic_res = ref [||]
+
+let get_res =
+ let open Tacexpr in
+ let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in
+ let entry = { mltac_name = name; mltac_index = 0 } in
+ let tac args ist =
+ let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in
+ let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in
+ tactic_res := Array.init n init;
+ Proofview.tclUNIT ()
+ in
+ Tacenv.register_ml_tactic name [| tac |];
+ entry
+
let exec_tactic env evd n f args =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun)
+ in
+ let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+ let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ (** Build the getter *)
let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
- let res = ref [||] in
- let get_res ist =
- let l = List.map (fun id -> Id.Map.find id ist.lfun) lid in
- res := Array.of_list l;
- TacId[] in
- let getter =
- Tacexp(TacFun(List.map(fun id -> Some id) lid,
- Tacintern.glob_tactic(tacticIn get_res))) in
+ let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
+ let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
+ let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+ (** Evaluate the whole result *)
let gl = dummy_goal env evd in
- let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
+ let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
- Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd
+ Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd)
let stdlib_modules =
[["Coq";"Setoids";"Setoid"];
@@ -498,8 +522,8 @@ let ring_equality env evd (r,add,mul,opp,req) =
match opp with
Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
| None -> plapp evd coq_eq_smorph [|r;add;mul|] in
- let setoid = Typing.solve_evars env evd setoid in
- let op_morph = Typing.solve_evars env evd op_morph in
+ let setoid = Typing.e_solve_evars env evd setoid in
+ let op_morph = Typing.e_solve_evars env evd op_morph in
(setoid,op_morph)
| _ ->
let setoid = setoid_of_relation (Global.env ()) evd r req in
@@ -598,7 +622,7 @@ let make_hyp_list env evd lH =
(fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
(plapp evd coq_nil [|carrier|])
in
- let l' = Typing.solve_evars env evd l in
+ let l' = Typing.e_solve_evars env evd l in
Evarutil.nf_evars_universes !evd l'
let interp_power env evd pow =
@@ -646,7 +670,7 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
let rk = reflect_coeff morphth in
let params,ctx =
exec_tactic env !evd 5 (zltac "ring_lemmas")
- (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
+ [sth;ext;rth;pspec;sspec;dspec;rk] in
let lemma1 = params.(3) in
let lemma2 = params.(4) in
@@ -724,7 +748,11 @@ let make_term_list env evd carrier rl =
let l = List.fold_right
(fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
(plapp evd coq_nil [|carrier|])
- in Typing.solve_evars env evd l
+ in Typing.e_solve_evars env evd l
+
+let carg = Tacinterp.Value.of_constr
+let tacarg expr =
+ Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr
let ltac_ring_structure e =
let req = carg e.ring_req in
@@ -732,18 +760,18 @@ let ltac_ring_structure e =
let ext = carg e.ring_ext in
let morph = carg e.ring_morph in
let th = carg e.ring_th in
- let cst_tac = Tacexp e.ring_cst_tac in
- let pow_tac = Tacexp e.ring_pow_tac in
+ let cst_tac = tacarg e.ring_cst_tac in
+ let pow_tac = tacarg e.ring_pow_tac in
let lemma1 = carg e.ring_lemma1 in
let lemma2 = carg e.ring_lemma2 in
- let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
+ let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
[req;sth;ext;morph;th;cst_tac;pow_tac;
lemma1;lemma2;pretac;posttac]
-let ring_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+let ring_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try (* find_ring_strucure can raise an exception *)
let evdref = ref sigma in
@@ -754,7 +782,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t =
let ring = ltac_ring_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
+ end }
(***********************************************************************)
@@ -931,7 +959,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
let rk = reflect_coeff morphth in
let params,ctx =
exec_tactic env !evd 9 (field_ltac"field_lemmas")
- (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
+ [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in
let lemma1 = params.(3) in
let lemma2 = params.(4) in
let lemma3 = params.(5) in
@@ -1001,21 +1029,21 @@ let process_field_mods l =
let ltac_field_structure e =
let req = carg e.field_req in
- let cst_tac = Tacexp e.field_cst_tac in
- let pow_tac = Tacexp e.field_pow_tac in
+ let cst_tac = tacarg e.field_cst_tac in
+ let pow_tac = tacarg e.field_pow_tac in
let field_ok = carg e.field_ok in
let field_simpl_ok = carg e.field_simpl_ok in
let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
let cond_ok = carg e.field_cond in
- let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+ let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.field_post_tac)) in
[req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
field_simpl_eq_in_ok;cond_ok;pretac;posttac]
-let field_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+let field_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try
let evdref = ref sigma in
@@ -1026,4 +1054,4 @@ let field_lookup (f:glob_tactic_expr) lH rl t =
let field = ltac_field_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
+ end }
diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli
index 4bd3383d65..07a1ae833b 100644
--- a/plugins/setoid_ring/newring.mli
+++ b/plugins/setoid_ring/newring.mli
@@ -45,7 +45,7 @@ val ic : constr_expr -> Evd.evar_map * constr
val from_name : ring_info Spmap.t ref
val ring_lookup :
- glob_tactic_expr ->
+ Genarg.Val.t ->
constr list ->
constr list -> constr -> unit Proofview.tactic
@@ -73,6 +73,6 @@ val add_field_theory :
val field_from_name : field_info Spmap.t ref
val field_lookup :
- glob_tactic_expr ->
+ Genarg.Val.t ->
constr list ->
constr list -> constr -> unit Proofview.tactic
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-03 19:25:23 +0000