diff options
author | Stephane Glondu <steph@glondu.net> | 2013-05-08 18:01:07 +0200 |
---|---|---|
committer | Stephane Glondu <steph@glondu.net> | 2013-05-08 18:01:07 +0200 |
commit | 095eac936751bab72e3c6bbdfa3ede51f7198721 (patch) | |
tree | 44cf2859ba6b8486f056efaaf7ee6c2d855f2aae /plugins/subtac/subtac.ml | |
parent | 4e6d6dab2ef2de6c1ad7972fc981e55a4fde7ae3 (diff) | |
parent | 0b14713e3efd7f8f1cc8a06555d0ec8fbe496130 (diff) |
Merge branch 'experimental/master'
Diffstat (limited to 'plugins/subtac/subtac.ml')
-rw-r--r-- | plugins/subtac/subtac.ml | 32 |
1 files changed, 17 insertions, 15 deletions
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 95cacc38..ad248bfb 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - +open Compat open Global open Pp open Util @@ -27,7 +26,7 @@ open List open Recordops open Evarutil open Pretype_errors -open Rawterm +open Glob_term open Evarconv open Pattern open Vernacexpr @@ -50,7 +49,7 @@ open Tacinterp open Tacexpr let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then + if not (Evd.is_empty evm) then let stmt_id = Nameops.add_suffix id "_stmt" in let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with @@ -83,13 +82,11 @@ let start_proof_com env isevars sopt kind (bl,t) hook = Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps]; hook loc gr) -let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; - print_subgoals () + Vernacentries.print_subgoals () -let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) +let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") @@ -142,12 +139,12 @@ let subtac (loc, command) = (fun _ _ -> ()) | DefineBody (bl, _, c, tycon) -> ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) - | VernacFixpoint (l, b) -> + | VernacFixpoint l -> List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in - ignore(Subtac_command.build_recursive l b) + ignore(Subtac_command.build_recursive l) | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) -> if guard <> None then @@ -172,10 +169,10 @@ let subtac (loc, command) = error "Declare Instance not supported here."; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) - | VernacCoFixpoint (l, b) -> + | VernacCoFixpoint l -> if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; - ignore(Subtac_command.build_corecursive l b) + ignore(Subtac_command.build_corecursive l) (*| VernacEndProof e -> subtac_end_proof e*) @@ -219,6 +216,11 @@ let subtac (loc, command) = | Type_errors.TypeError (env, exn) as e -> raise e - | Pretype_errors.PretypeError (env, exn) as e -> raise e + | Pretype_errors.PretypeError (env, _, exn) as e -> raise e + + | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | + Loc.Exc_located (loc, e') as e) -> raise e - | e -> raise e + | reraise -> + (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) + raise reraise |