aboutsummaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/extraction/ocaml.ml34
-rw-r--r--plugins/funind/functional_principles_types.ml7
-rw-r--r--plugins/funind/g_indfun.ml42
-rw-r--r--plugins/funind/recdef.ml8
-rw-r--r--plugins/ltac/extratactics.ml46
-rw-r--r--plugins/ltac/pptactic.ml182
-rw-r--r--plugins/ltac/pptactic.mli25
-rw-r--r--plugins/ltac/rewrite.ml7
-rw-r--r--plugins/ltac/taccoerce.ml2
-rw-r--r--plugins/ltac/tacinterp.ml57
-rw-r--r--plugins/micromega/persistent_cache.ml4
-rw-r--r--plugins/romega/const_omega.ml2
-rw-r--r--plugins/setoid_ring/newring.ml10
-rw-r--r--plugins/ssr/ssrcommon.ml2
-rw-r--r--plugins/ssr/ssrvernac.ml46
-rw-r--r--plugins/ssrmatching/ssrmatching.ml42
16 files changed, 250 insertions, 106 deletions
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 9cbc3fd713..5d0f9c167e 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -100,11 +100,41 @@ let pp_global k r = str (str_global k r)
let pp_modname mp = str (Common.pp_module mp)
+(* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *)
+
+let infix_symbols =
+ ['=' ; '<' ; '>' ; '@' ; '^' ; ';' ; '&' ; '+' ; '-' ; '*' ; '/' ; '$' ; '%' ]
+let operator_chars =
+ [ '!' ; '$' ; '%' ; '&' ; '*' ; '+' ; '-' ; '.' ; '/' ; ':' ; '<' ; '=' ; '>' ; '?' ; '@' ; '^' ; '|' ; '~' ]
+
+(* infix ops in OCaml, but disallowed by preceding grammar *)
+
+let builtin_infixes =
+ [ "::" ; "," ]
+
+let substring_all_opchars s start stop =
+ let rec check_char i =
+ if i >= stop then true
+ else
+ List.mem s.[i] operator_chars && check_char (i+1)
+ in
+ check_char start
+
let is_infix r =
is_inline_custom r &&
(let s = find_custom r in
- let l = String.length s in
- l >= 2 && s.[0] == '(' && s.[l-1] == ')')
+ let len = String.length s in
+ len >= 3 &&
+ (* parenthesized *)
+ (s.[0] == '(' && s.[len-1] == ')' &&
+ let inparens = String.trim (String.sub s 1 (len - 2)) in
+ let inparens_len = String.length inparens in
+ (* either, begins with infix symbol, any remainder is all operator chars *)
+ (List.mem inparens.[0] infix_symbols && substring_all_opchars inparens 1 inparens_len) ||
+ (* or, starts with #, at least one more char, all are operator chars *)
+ (inparens.[0] == '#' && inparens_len >= 2 && substring_all_opchars inparens 1 inparens_len) ||
+ (* or, is an OCaml built-in infix *)
+ (List.mem inparens builtin_infixes)))
let get_infix r =
let s = find_custom r in
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 996e2b6af0..7a9bbd92cf 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -348,8 +348,11 @@ let generate_functional_principle (evd: Evd.evar_map ref)
let evd',value = change_property_sort evd' s new_principle_type new_princ_name in
let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in
(* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
- let univs = (snd (Evd.universe_context ~names:[] ~extensible:true evd')) in
- let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs value in
+ let univs =
+ let poly = Flags.is_universe_polymorphism () in
+ Evd.const_univ_entry ~poly evd'
+ in
+ let ce = Declare.definition_entry ~univs value in
ignore(
Declare.declare_constant
name
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 829556a71e..87609296bc 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -154,7 +154,7 @@ VERNAC COMMAND EXTEND Function
| _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in
match
Vernac_classifier.classify_vernac
- (Vernacexpr.VernacFixpoint(None, List.map snd recsl))
+ (Vernacexpr.VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl))
with
| Vernacexpr.VtSideff ids, _ when hard ->
Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater)
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 3089ec4708..b0a76137b7 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -66,8 +66,8 @@ let find_reference sl s =
let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
locate (make_qualid dp (Id.of_string s))
-let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value =
- let ce = definition_entry ~univs:ctx value (*FIXME *) in
+let declare_fun f_id kind ?univs value =
+ let ce = definition_entry ?univs value (*FIXME *) in
ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None)))
@@ -1556,8 +1556,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
let functional_id = add_suffix function_name "_F" in
let term_id = add_suffix function_name "_terminate" in
let functional_ref =
- let ctx = (snd (Evd.universe_context ~names:[] ~extensible:true evm)) in
- declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res
+ let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evm) in
+ declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res
in
(* Refresh the global universes, now including those of _F *)
let evm = Evd.from_env (Global.env ()) in
diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
index 790a9e4352..982fc7cc3c 100644
--- a/plugins/ltac/extratactics.ml4
+++ b/plugins/ltac/extratactics.ml4
@@ -313,10 +313,10 @@ let project_hint pri l2r r =
let id =
Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
in
- let ctx = Evd.universe_context_set sigma in
- let c = EConstr.to_constr sigma c in
let poly = Flags.use_polymorphic_flag () in
- let c = Declare.declare_definition ~poly ~internal:Declare.InternalTacticRequest id (c,ctx) in
+ let ctx = Evd.const_univ_entry ~poly sigma in
+ let c = EConstr.to_constr sigma c in
+ let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in
let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in
(info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
index d707512457..6aa2f6f898 100644
--- a/plugins/ltac/pptactic.ml
+++ b/plugins/ltac/pptactic.ml
@@ -84,6 +84,24 @@ type 'a extra_genarg_printer =
(tolerability -> Val.t -> Pp.t) ->
'a -> Pp.t
+type 'a raw_extra_genarg_printer_with_level =
+ (constr_expr -> Pp.t) ->
+ (constr_expr -> Pp.t) ->
+ (tolerability -> raw_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a glob_extra_genarg_printer_with_level =
+ (glob_constr_and_expr -> Pp.t) ->
+ (glob_constr_and_expr -> Pp.t) ->
+ (tolerability -> glob_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a extra_genarg_printer_with_level =
+ (EConstr.constr -> Pp.t) ->
+ (EConstr.constr -> Pp.t) ->
+ (tolerability -> Val.t -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
let string_of_genarg_arg (ArgumentType arg) =
let rec aux : type a b c. (a, b, c) genarg_type -> string = function
| ListArg t -> aux t ^ "_list"
@@ -127,9 +145,9 @@ let string_of_genarg_arg (ArgumentType arg) =
| Some Refl ->
let open Genprint in
match generic_top_print (in_gen (Topwit wit) x) with
- | PrinterBasic pr -> pr ()
- | PrinterNeedsContext pr -> pr (Global.env()) Evd.empty
- | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ | TopPrinterBasic pr -> pr ()
+ | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
printer (Global.env()) Evd.empty default_ensure_surrounded
end
| _ -> default
@@ -723,8 +741,10 @@ let pr_goal_selector ~toplevel s =
| TacIntroPattern (ev,[]) as t ->
pr_atom0 t
| TacIntroPattern (ev,(_::_ as p)) ->
- hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++
- prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
+ hov 1 (primitive (if ev then "eintros" else "intros") ++
+ (match p with
+ | [_,Misctypes.IntroForthcoming false] -> mt ()
+ | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p))
| TacApply (a,ev,cb,inhyp) ->
hov 1 (
(if a then mt() else primitive "simple ") ++
@@ -1192,42 +1212,77 @@ let declare_extra_genarg_pprule wit
| ExtraArg s -> ()
| _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.")
end;
- let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
+ let f x =
+ Genprint.PrinterBasic (fun () ->
+ f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in
let g x =
+ Genprint.PrinterBasic (fun () ->
let env = Global.env () in
- g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x
+ g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x)
in
let h x =
- Genprint.PrinterNeedsContext (fun env sigma ->
+ Genprint.TopPrinterNeedsContext (fun env sigma ->
h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x)
in
Genprint.register_print0 wit f g h
+let declare_extra_genarg_pprule_with_level wit
+ (f : 'a raw_extra_genarg_printer_with_level)
+ (g : 'b glob_extra_genarg_printer_with_level)
+ (h : 'c extra_genarg_printer_with_level) default_surrounded default_non_surrounded =
+ begin match wit with
+ | ExtraArg s -> ()
+ | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.")
+ end;
+ let open Genprint in
+ let f x =
+ PrinterNeedsLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun n ->
+ f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in
+ let g x =
+ let env = Global.env () in
+ PrinterNeedsLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun n ->
+ g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) }
+ in
+ let h x =
+ TopPrinterNeedsContextAndLevel {
+ default_already_surrounded = default_surrounded;
+ default_ensure_surrounded = default_non_surrounded;
+ printer = (fun env sigma n ->
+ h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) }
+ in
+ Genprint.register_print0 wit f g h
+
let declare_extra_vernac_genarg_pprule wit f =
- let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in
+ let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in
Genprint.register_vernac_print0 wit f
(** Registering *)
-let pr_intro_pattern_env p = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma ->
let print_constr c = let (sigma, c) = c env sigma in pr_econstr_env env sigma c in
Miscprint.pr_intro_pattern print_constr p)
-let pr_red_expr_env r = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma ->
pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma,
pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r)
-let pr_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, bl = bl env sigma in
Miscprint.pr_bindings
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl)
-let pr_with_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_with_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, bl = bl env sigma in
pr_with_bindings
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl)
-let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma ->
+let pr_destruction_arg_env c = Genprint.TopPrinterNeedsContext (fun env sigma ->
let sigma, c = match c with
| clear_flag,ElimOnConstr g -> let sigma,c = g env sigma in sigma,(clear_flag,ElimOnConstr c)
| clear_flag,ElimOnAnonHyp n as x -> sigma, x
@@ -1236,12 +1291,16 @@ let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma ->
(pr_econstr_env env sigma) (pr_leconstr_env env sigma) c)
let make_constr_printer f c =
- Genprint.PrinterNeedsContextAndLevel {
+ Genprint.TopPrinterNeedsContextAndLevel {
Genprint.default_already_surrounded = Ppconstr.ltop;
Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr;
Genprint.printer = (fun env sigma n -> f env sigma n c)}
let lift f a = Genprint.PrinterBasic (fun () -> f a)
+let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a)
+
+let register_basic_print0 wit f g h =
+ Genprint.register_print0 wit (lift f) (lift g) (lift_top h)
let pr_glob_constr_pptac c =
@@ -1255,80 +1314,81 @@ let pr_lglob_constr_pptac c =
let () =
let pr_bool b = if b then str "true" else str "false" in
let pr_unit _ = str "()" in
- Genprint.register_print0 wit_int_or_var
- (pr_or_var int) (pr_or_var int) (lift int);
- Genprint.register_print0 wit_ref
- pr_reference (pr_or_var (pr_located pr_global)) (lift pr_global);
- Genprint.register_print0 wit_ident
- pr_id pr_id (lift pr_id);
- Genprint.register_print0 wit_var
- (pr_located pr_id) (pr_located pr_id) (lift pr_id);
- Genprint.register_print0
+ let open Genprint in
+ register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int;
+ register_basic_print0 wit_ref
+ pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+ register_basic_print0 wit_ident pr_id pr_id pr_id;
+ register_basic_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id;
+ register_print0
wit_intro_pattern
- (Miscprint.pr_intro_pattern pr_constr_expr)
- (Miscprint.pr_intro_pattern (fun (c, _) -> pr_glob_constr_pptac c))
+ (lift (Miscprint.pr_intro_pattern pr_constr_expr))
+ (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c)))
pr_intro_pattern_env;
Genprint.register_print0
wit_clause_dft_concl
- (pr_clauses (Some true) pr_lident)
- (pr_clauses (Some true) pr_lident)
- (fun c -> Genprint.PrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c))
+ (lift (pr_clauses (Some true) pr_lident))
+ (lift (pr_clauses (Some true) pr_lident))
+ (fun c -> Genprint.TopPrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c))
;
Genprint.register_print0
wit_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_lconstr_expr)
+ (lift (fun (c, _) -> pr_lglob_constr_pptac c))
(make_constr_printer Printer.pr_econstr_n_env)
;
Genprint.register_print0
wit_uconstr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_constr_expr)
+ (lift (fun (c,_) -> pr_glob_constr_pptac c))
(make_constr_printer Printer.pr_closed_glob_n_env)
;
Genprint.register_print0
wit_open_constr
- Ppconstr.pr_constr_expr
- (fun (c, _) -> pr_glob_constr_pptac c)
+ (lift Ppconstr.pr_constr_expr)
+ (lift (fun (c, _) -> pr_glob_constr_pptac c))
(make_constr_printer Printer.pr_econstr_n_env)
;
- Genprint.register_print0 wit_red_expr
- (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))
- (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))
+ Genprint.register_print0
+ wit_red_expr
+ (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)))
+ (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac)))
pr_red_expr_env
;
- Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis (lift pr_quantified_hypothesis);
- Genprint.register_print0 wit_bindings
- (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)
- (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis;
+ register_print0 wit_bindings
+ (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr))
+ (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_bindings_env
;
- Genprint.register_print0 wit_constr_with_bindings
- (pr_with_bindings pr_constr_expr pr_lconstr_expr)
- (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 wit_constr_with_bindings
+ (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr))
+ (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_with_bindings_env
;
- Genprint.register_print0 wit_open_constr_with_bindings
- (pr_with_bindings pr_constr_expr pr_lconstr_expr)
- (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 wit_open_constr_with_bindings
+ (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr))
+ (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_with_bindings_env
;
- Genprint.register_print0 Tacarg.wit_destruction_arg
- (pr_destruction_arg pr_constr_expr pr_lconstr_expr)
- (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))
+ register_print0 Tacarg.wit_destruction_arg
+ (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr))
+ (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac)))
pr_destruction_arg_env
;
- Genprint.register_print0 Stdarg.wit_int int int (lift int);
- Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool (lift pr_bool);
- Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit (lift pr_unit);
- Genprint.register_print0 Stdarg.wit_pre_ident str str (lift str);
- Genprint.register_print0 Stdarg.wit_string qstring qstring (lift qstring)
+ register_basic_print0 Stdarg.wit_int int int int;
+ register_basic_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
+ register_basic_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
+ register_basic_print0 Stdarg.wit_pre_ident str str str;
+ register_basic_print0 Stdarg.wit_string qstring qstring qstring
let () =
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_tactic printer printer printer
+ let printer _ _ prtac = prtac in
+ declare_extra_genarg_pprule_with_level wit_tactic printer printer printer
+ ltop (0,E)
let () =
- let pr_unit _ _ _ () = str "()" in
- let printer _ _ prtac = prtac (0, E) in
- declare_extra_genarg_pprule wit_ltac printer printer pr_unit
+ let pr_unit _ _ _ _ () = str "()" in
+ let printer _ _ prtac = prtac in
+ declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit
+ ltop (0,E)
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
index 5ecfaf590c..bda5774abf 100644
--- a/plugins/ltac/pptactic.mli
+++ b/plugins/ltac/pptactic.mli
@@ -40,12 +40,37 @@ type 'a extra_genarg_printer =
(tolerability -> Val.t -> Pp.t) ->
'a -> Pp.t
+type 'a raw_extra_genarg_printer_with_level =
+ (constr_expr -> Pp.t) ->
+ (constr_expr -> Pp.t) ->
+ (tolerability -> raw_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a glob_extra_genarg_printer_with_level =
+ (glob_constr_and_expr -> Pp.t) ->
+ (glob_constr_and_expr -> Pp.t) ->
+ (tolerability -> glob_tactic_expr -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
+type 'a extra_genarg_printer_with_level =
+ (EConstr.constr -> Pp.t) ->
+ (EConstr.constr -> Pp.t) ->
+ (tolerability -> Val.t -> Pp.t) ->
+ tolerability -> 'a -> Pp.t
+
val declare_extra_genarg_pprule :
('a, 'b, 'c) genarg_type ->
'a raw_extra_genarg_printer ->
'b glob_extra_genarg_printer ->
'c extra_genarg_printer -> unit
+val declare_extra_genarg_pprule_with_level :
+ ('a, 'b, 'c) genarg_type ->
+ 'a raw_extra_genarg_printer_with_level ->
+ 'b glob_extra_genarg_printer_with_level ->
+ 'c extra_genarg_printer_with_level ->
+ (* surroounded *) tolerability -> (* non-surroounded *) tolerability -> unit
+
val declare_extra_vernac_genarg_pprule :
('a, 'b, 'c) genarg_type ->
'a raw_extra_genarg_printer -> unit
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index 14b0742a76..c0060c5a7c 100644
--- a/plugins/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
@@ -1884,11 +1884,11 @@ let declare_projection n instance_id r =
in it_mkProd_or_LetIn ccl ctx
in
let typ = it_mkProd_or_LetIn typ ctx in
- let pl, ctx = Evd.universe_context ~names:[] ~extensible:true sigma in
+ let univs = Evd.const_univ_entry ~poly sigma in
let typ = EConstr.to_constr sigma typ in
let term = EConstr.to_constr sigma term in
let cst =
- Declare.definition_entry ~types:typ ~poly ~univs:ctx term
+ Declare.definition_entry ~types:typ ~univs term
in
ignore(Declare.declare_constant n
(Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
@@ -1972,9 +1972,10 @@ let add_morphism_infer glob m n =
let evd = Evd.from_env env in
let uctx, instance = build_morphism_signature env evd m in
if Lib.is_modtype () then
+ let uctx = UState.const_univ_entry ~poly uctx in
let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id
(Entries.ParameterEntry
- (None,poly,(instance,UState.context uctx),None),
+ (None,(instance,uctx),None),
Decl_kinds.IsAssumption Decl_kinds.Logical)
in
add_instance (Typeclasses.new_instance
diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml
index c03a867326..9ae112d371 100644
--- a/plugins/ltac/taccoerce.ml
+++ b/plugins/ltac/taccoerce.ml
@@ -33,7 +33,7 @@ let (wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_bin
let () = register_val0 wit None in
let () = Genprint.register_val_print0 (base_val_typ wit)
(fun c ->
- Genprint.PrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in
+ Genprint.TopPrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in
wit
(** All the types considered here are base types *)
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index 1a8ec6d6f6..e0d7eca5f8 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -128,7 +128,7 @@ let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
let wit = Genarg.create_arg "tacvalue" in
let () = register_val0 wit None in
let () = Genprint.register_val_print0 (base_val_typ wit)
- (fun _ -> Genprint.PrinterBasic (fun () -> str "<tactic closure>")) in
+ (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in
wit
let of_tacvalue v = in_gen (topwit wit_tacvalue) v
@@ -242,9 +242,9 @@ let pr_value env v =
| None -> str "a value of type" ++ spc () ++ pr_argument_type v in
let open Genprint in
match generic_val_print v with
- | PrinterBasic pr -> pr ()
- | PrinterNeedsContext pr -> pr_with_env pr
- | PrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
+ | TopPrinterBasic pr -> pr ()
+ | TopPrinterNeedsContext pr -> pr_with_env pr
+ | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
pr_with_env (fun env sigma -> printer env sigma default_already_surrounded)
let pr_closure env ist body =
@@ -821,9 +821,9 @@ let message_of_value v =
Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in
let open Genprint in
match generic_val_print v with
- | PrinterBasic pr -> Ftactic.return (pr ())
- | PrinterNeedsContext pr -> pr_with_env pr
- | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
+ | TopPrinterBasic pr -> Ftactic.return (pr ())
+ | TopPrinterNeedsContext pr -> pr_with_env pr
+ | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } ->
pr_with_env (fun env sigma -> printer env sigma default_ensure_surrounded)
let interp_message_token ist = function
@@ -1353,8 +1353,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
begin
let open Genprint in
match generic_val_print v with
- | PrinterBasic _ -> call_debug None
- | PrinterNeedsContext _ | PrinterNeedsContextAndLevel _ ->
+ | TopPrinterBasic _ -> call_debug None
+ | TopPrinterNeedsContext _ | TopPrinterNeedsContextAndLevel _ ->
Proofview.Goal.enter (fun gl -> call_debug (Some (pf_env gl,project gl)))
end <*>
if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
@@ -1380,13 +1380,38 @@ and tactic_of_value ist vle =
extra = TacStore.set ist.extra f_trace []; } in
let tac = name_if_glob appl (eval_tactic ist t) in
Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
- | VFun (_, _, _,vars,_) ->
- let numargs = List.length vars in
- Tacticals.New.tclZEROMSG
- (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
- Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
- Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
- pr_enum Name.print vars ++ Pp.str ".")
+ | VFun (appl,_,vmap,vars,_) ->
+ let tactic_nm =
+ match appl with
+ UnnamedAppl -> "An unnamed user-defined tactic"
+ | GlbAppl apps ->
+ let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in
+ match nms with
+ [] -> assert false
+ | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *)
+ in
+ let numargs = List.length vars in
+ let givenargs =
+ List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in
+ let numgiven = List.length givenargs in
+ Tacticals.New.tclZEROMSG
+ (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++
+ (match numargs with
+ 0 -> assert false
+ | 1 ->
+ Pp.str "There is a missing argument for variable " ++
+ (Name.print (List.hd vars))
+ | _ -> Pp.str "There are missing arguments for variables " ++
+ pr_enum Name.print vars) ++ Pp.pr_comma () ++
+ match numgiven with
+ 0 ->
+ Pp.str "no arguments at all were provided."
+ | 1 ->
+ Pp.str "an argument was provided for variable " ++
+ Pp.str (List.hd givenargs) ++ Pp.str "."
+ | _ ->
+ Pp.str "arguments were provided for variables " ++
+ pr_enum Pp.str givenargs ++ Pp.str ".")
| VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
else if has_type vle (topwit wit_tactic) then
let tac = out_gen (topwit wit_tactic) vle in
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index 49ccb468c1..387a525141 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.ml
@@ -149,7 +149,7 @@ let open_in f =
match read_key_elem inch with
| None -> ()
| Some (key,elem) ->
- Table.add htbl key elem ;
+ Table.replace htbl key elem ;
xload () in
try
(* Locking of the (whole) file while reading *)
@@ -195,7 +195,7 @@ let add t k e =
else
let fd = descr_of_out_channel outch in
begin
- Table.add tbl k e ;
+ Table.replace tbl k e ;
do_under_lock Write fd
(fun _ ->
Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index 337510ef1f..0d491d92bd 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -155,7 +155,7 @@ let mk_list univ typ l =
loop l
let mk_plist =
- let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in
+ let type1lev = Universes.new_univ_level () in
fun l -> mk_list type1lev mkProp l
let mk_list = mk_list Univ.Level.set
diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml
index 1c3bdb958f..f22f00839a 100644
--- a/plugins/setoid_ring/newring.ml
+++ b/plugins/setoid_ring/newring.ml
@@ -150,13 +150,13 @@ let ic_unsafe c = (*FIXME remove *)
let sigma = Evd.from_env env in
EConstr.of_constr (fst (Constrintern.interp_constr env sigma c))
-let decl_constant na ctx c =
+let decl_constant na univs c =
let open Constr in
let vars = Univops.universes_of_constr c in
- let ctx = Univops.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
+ let univs = Univops.restrict_universe_context univs vars in
+ let univs = Monomorphic_const_entry univs in
mkConst(declare_constant (Id.of_string na)
- (DefinitionEntry (definition_entry ~opaque:true
- ~univs:(Univ.ContextSet.to_context ctx) c),
+ (DefinitionEntry (definition_entry ~opaque:true ~univs c),
IsProof Lemma))
(* Calling a global tactic *)
@@ -220,7 +220,7 @@ let exec_tactic env evd n f args =
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
let nf c = nf (constr_of c) in
- Array.map nf !tactic_res, snd (Evd.universe_context ~names:[] ~extensible:true evd)
+ Array.map nf !tactic_res, Evd.universe_context_set evd
let stdlib_modules =
[["Coq";"Setoids";"Setoid"];
diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml
index 83b4547698..047ca509be 100644
--- a/plugins/ssr/ssrcommon.ml
+++ b/plugins/ssr/ssrcommon.ml
@@ -565,7 +565,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) =
if evlist = [] then 0, c0 else
let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in
pp(lazy(str"evlist=" ++ pr_list (fun () -> str";")
- (fun (k,_) -> str(Evd.string_of_existential k)) evlist));
+ (fun (k,_) -> Evar.print k) evlist));
let evplist =
let depev = List.fold_left (fun evs (_,(_,t,_)) ->
let t = EConstr.of_constr t in
diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4
index 7385ed84c7..3efb7b9147 100644
--- a/plugins/ssr/ssrvernac.ml4
+++ b/plugins/ssr/ssrvernac.ml4
@@ -551,9 +551,9 @@ GEXTEND Gram
| IDENT "Canonical"; qid = Constr.global;
d = G_vernac.def_body ->
let s = coerce_reference_to_id qid in
- Vernacexpr.VernacDefinition
- ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure),
- ((Loc.tag s),None),(d ))
+ Vernacexpr.VernacLocal(false,Vernacexpr.VernacDefinition
+ ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure),
+ ((Loc.tag s),None),(d )))
]];
END
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
index 276b7c8ab2..e63a05b781 100644
--- a/plugins/ssrmatching/ssrmatching.ml4
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -396,7 +396,7 @@ let inv_dir = function L2R -> R2L | R2L -> L2R
type pattern_class =
| KpatFixed
| KpatConst
- | KpatEvar of existential_key
+ | KpatEvar of Evar.t
| KpatLet
| KpatLam
| KpatRigid
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 10:28:22 +0000