From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- tactics/auto.ml | 694 +++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 483 insertions(+), 211 deletions(-) (limited to 'tactics/auto.ml') diff --git a/tactics/auto.ml b/tactics/auto.ml index 6a9ced3e..93ca89f4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* search_entry - Le constr correspond à la constante de tête de la conclusion. + Le constr correspond à la constante de tête de la conclusion. Une search_entry est un triplet comprenant : - - la liste des tactiques qui n'ont pas de pattern associé + - la liste des tactiques qui n'ont pas de pattern associé - la liste des tactiques qui ont un pattern - - un discrimination net borné (Btermdn.t) constitué de tous les + - un discrimination net borné (Btermdn.t) constitué de tous les patterns de la seconde liste de tactiques *) -type stored_data = pri_auto_tactic +type stored_data = int * pri_auto_tactic + (* First component is the index of insertion in the table, to keep most recent first semantics. *) + +let auto_tactic_ord code1 code2 = + match code1, code2 with + | Res_pf (c1, _), Res_pf (c2, _) + | ERes_pf (c1, _), ERes_pf (c2, _) + | Give_exact c1, Give_exact c2 + | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> constr_ord c1 c2 + | Unfold_nth (EvalVarRef i1), Unfold_nth (EvalVarRef i2) -> Pervasives.compare i1 i2 + | Unfold_nth (EvalConstRef c1), Unfold_nth (EvalConstRef c2) -> + kn_ord (canonical_con c1) (canonical_con c2) + | Extern t1, Extern t2 -> Pervasives.compare t1 t2 + | _ -> Pervasives.compare code1 code2 module Bounded_net = Btermdn.Make(struct type t = stored_data - let compare = Pervasives.compare + let compare = pri_order_int end) type search_entry = stored_data list * stored_data list * Bounded_net.t let empty_se = ([],[],Bounded_net.create ()) -let eq_pri_auto_tactic x y = +let eq_pri_auto_tactic (_, x) (_, y) = if x.pri = y.pri && x.pat = y.pat then match x.code,y.code with | Res_pf(cstr,_),Res_pf(cstr1,_) -> @@ -118,15 +149,18 @@ let eq_pri_auto_tactic x y = let add_tac pat t st (l,l',dn) = match pat with | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn) - | Some pat -> if not (List.exists (eq_pri_auto_tactic t) l') then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn) + | Some pat -> + if not (List.exists (eq_pri_auto_tactic t) l') + then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn) -let rebuild_dn st (l,l',dn) = - (l, l', List.fold_left (fun dn t -> Bounded_net.add (Some st) dn (Option.get t.pat, t)) +let rebuild_dn st ((l,l',dn) : search_entry) = + (l, l', List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) (Bounded_net.create ()) l') + let lookup_tacs (hdc,c) st (l,l',dn) = let l' = List.map snd (Bounded_net.lookup st dn c) in - let sl' = Sort.list pri_order l' in + let sl' = List.stable_sort pri_order_int l' in Sort.merge pri_order l sl' module Constr_map = Map.Make(RefOrdered) @@ -136,11 +170,138 @@ let is_transparent_gr (ids, csts) = function | ConstRef cst -> Cpred.mem cst csts | IndRef _ | ConstructRef _ -> false +let dummy_goal = Goal.V82.dummy_goal + +let translate_hint (go,p) = + let mk_clenv (c,t) = + let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env } + in + let code = match p.code with + | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t)) + | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t)) + | Res_pf_THEN_trivial_fail (c,t) -> + Res_pf_THEN_trivial_fail (c, mk_clenv (c,t)) + | Give_exact c -> Give_exact c + | Unfold_nth e -> Unfold_nth e + | Extern t -> Extern t + in + (go,{ p with code = code }) + +let path_matches hp hints = + let rec aux hp hints k = + match hp, hints with + | PathAtom _, [] -> false + | PathAtom PathAny, (_ :: hints') -> k hints' + | PathAtom p, (h :: hints') -> + if p = h then k hints' else false + | PathStar hp', hints -> + k hints || aux hp' hints (fun hints' -> aux hp hints' k) + | PathSeq (hp, hp'), hints -> + aux hp hints (fun hints' -> aux hp' hints' k) + | PathOr (hp, hp'), hints -> + aux hp hints k || aux hp' hints k + | PathEmpty, _ -> false + | PathEpsilon, hints -> k hints + in aux hp hints (fun hints' -> true) + +let rec matches_epsilon = function + | PathAtom _ -> false + | PathStar _ -> true + | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p' + | PathOr (p, p') -> matches_epsilon p || matches_epsilon p' + | PathEmpty -> false + | PathEpsilon -> true + +let rec is_empty = function + | PathAtom _ -> false + | PathStar _ -> false + | PathSeq (p, p') -> is_empty p || is_empty p' + | PathOr (p, p') -> matches_epsilon p && matches_epsilon p' + | PathEmpty -> true + | PathEpsilon -> false + +let rec path_derivate hp hint = + let rec derivate_atoms hints hints' = + match hints, hints' with + | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs' + | [], [] -> PathEpsilon + | [], hints -> PathEmpty + | grs, [] -> PathAtom (PathHints grs) + | _, _ -> PathEmpty + in + match hp with + | PathAtom PathAny -> PathEpsilon + | PathAtom (PathHints grs) -> + (match grs, hint with + | h :: hints, PathAny -> PathEmpty + | hints, PathHints hints' -> derivate_atoms hints hints' + | _, _ -> assert false) + | PathStar p -> if path_matches p [hint] then hp else PathEpsilon + | PathSeq (hp, hp') -> + let hpder = path_derivate hp hint in + if matches_epsilon hp then + PathOr (PathSeq (hpder, hp'), path_derivate hp' hint) + else if is_empty hpder then PathEmpty + else PathSeq (hpder, hp') + | PathOr (hp, hp') -> + PathOr (path_derivate hp hint, path_derivate hp' hint) + | PathEmpty -> PathEmpty + | PathEpsilon -> PathEmpty + +let rec normalize_path h = + match h with + | PathStar PathEpsilon -> PathEpsilon + | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty + | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p + | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p + | PathOr (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if p = p' && q = q' then h + else normalize_path (PathOr (p', q')) + | PathSeq (p, q) -> + let p', q' = normalize_path p, normalize_path q in + if p = p' && q = q' then h + else normalize_path (PathSeq (p', q')) + | _ -> h + +let path_derivate hp hint = normalize_path (path_derivate hp hint) + +let rec pp_hints_path = function + | PathAtom (PathAny) -> str"." + | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs + | PathStar p -> str "(" ++ pp_hints_path p ++ str")*" + | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p' + | PathOr (p, p') -> + str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")" + | PathEmpty -> str"Ø" + | PathEpsilon -> str"ε" + +let rec subst_hints_path subst hp = + match hp with + | PathAtom PathAny -> hp + | PathAtom (PathHints grs) -> + let gr' gr = fst (subst_global subst gr) in + let grs' = list_smartmap gr' grs in + if grs' == grs then hp else PathAtom (PathHints grs') + | PathStar p -> let p' = subst_hints_path subst p in + if p' == p then hp else PathStar p' + | PathSeq (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathSeq (p', q') + | PathOr (p, q) -> + let p' = subst_hints_path subst p in + let q' = subst_hints_path subst q in + if p' == p && q' == q then hp else PathOr (p', q') + | _ -> hp + module Hint_db = struct type t = { hintdb_state : Names.transparent_state; + hintdb_cut : hints_path; hintdb_unfolds : Idset.t * Cset.t; + mutable hintdb_max_id : int; use_dn : bool; hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant @@ -148,8 +309,13 @@ module Hint_db = struct hintdb_nopat : (global_reference option * stored_data) list } + let next_hint_id t = + let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h + let empty st use_dn = { hintdb_state = st; + hintdb_cut = PathEmpty; hintdb_unfolds = (Idset.empty, Cset.empty); + hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; hintdb_nopat = [] } @@ -157,47 +323,54 @@ module Hint_db = struct let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - + let map_none db = - Sort.merge pri_order (List.map snd db.hintdb_nopat) [] - + List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) + let map_all k db = let (l,l',_) = find k db in - Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l' + List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') let map_auto (k,c) db = let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in - Sort.merge pri_order (List.map snd db.hintdb_nopat) l' + List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') let is_exact = function | Give_exact _ -> true | _ -> false - let addkv gr v db = + let is_unfold = function + | Unfold_nth _ -> true + | _ -> false + + let addkv gr id v db = + let idv = id, v in let k = match gr with - | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr + | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && + is_unfold v.code then None else Some gr | None -> None in let dnst = if db.use_dn then Some db.hintdb_state else None in let pat = if not db.use_dn && is_exact v.code then None else v.pat in match k with | None -> - if not (List.exists (fun (_, v') -> v = v') db.hintdb_nopat) then - { db with hintdb_nopat = (gr,v) :: db.hintdb_nopat } + if not (List.exists (fun (_, (_, v')) -> v = v') db.hintdb_nopat) then + { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map } + { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in - List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat + List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one (k,v) db = + let add_one kv db = + let (k,v) = translate_hint kv in let st',db,rebuild = match v.code with | Unfold_nth egr -> @@ -211,13 +384,27 @@ module Hint_db = struct | _ -> db.hintdb_state, db, false in let db = if db.use_dn && rebuild then rebuild_db st' db else db - in addkv k v db + in addkv k (next_hint_id db) v db let add_list l db = List.fold_right add_one l db + let remove_sdl p sdl = list_smartfilter p sdl + let remove_he st p (sl1, sl2, dn as he) = + let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in + if sl1' == sl1 && sl2' == sl2 then he + else rebuild_dn st (sl1', sl2', dn) + + let remove_list grs db = + let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem gr grs) | _ -> true in + let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintnopat = list_smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in + { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } + + let remove_one gr db = remove_list [gr] db + let iter f db = - f None (List.map snd db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map + f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat); + Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map let transparent_state db = db.hintdb_state @@ -225,6 +412,11 @@ module Hint_db = struct if db.use_dn then rebuild_db st db else { db with hintdb_state = st } + let add_cut path db = + { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) } + + let cut db = db.hintdb_cut + let unfolds db = db.hintdb_unfolds let use_dn db = db.use_dn @@ -255,6 +447,9 @@ let current_db_names () = (**************************************************************************) let auto_init : (unit -> unit) ref = ref (fun () -> ()) +let add_auto_init f = + let init = !auto_init in + auto_init := (fun () -> init (); f ()) let init () = searchtable := Hintdbmap.empty; !auto_init () let freeze () = !searchtable @@ -280,47 +475,51 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let dummy_goal = - {it = make_evar empty_named_context_val mkProp; - sigma = empty} +let name_of_constr c = try Some (global_of_constr c) with Not_found -> None -let make_exact_entry sigma pri (c,cty) = +let make_exact_entry sigma pri ?(name=PathAny) (c,cty) = let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> let pat = snd (Pattern.pattern_of_constr sigma cty) in - let head = - try head_of_constr_reference (fst (head_constr cty)) - with _ -> failwith "make_exact_entry" + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_exact_entry" in - (Some head, - { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) + (Some hd, + { pri = (match pri with None -> 0 | Some p -> p); + pat = Some pat; + name = name; + code = Give_exact c }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = +let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> let ce = mk_clenv_from dummy_goal (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = snd (Pattern.pattern_of_constr sigma c') in - let hd = (try head_pattern_bound pat - with BoundPattern -> failwith "make_apply_entry") in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in if nmiss = 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; - code = Res_pf(c,{ce with env=empty_env}) }) + name = name; + code = Res_pf(c,cty) }) else begin if not eapply then failwith "make_apply_entry"; if verbose then warn (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); (Some hd, - { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); - pat = Some pat; - code = ERes_pf(c,{ce with env=empty_env}) }) + { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + pat = Some pat; + name = name; + code = ERes_pf(c,cty) }) end | _ -> failwith "make_apply_entry" @@ -328,12 +527,12 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = c is a constr cty is the type of constr *) -let make_resolves env sigma flags pri c = - let cty = type_of env sigma c in +let make_resolves env sigma flags pri ?name c = + let cty = Retyping.get_type_of env sigma c in let ents = map_succeed (fun f -> f (c,cty)) - [make_exact_entry sigma pri; make_apply_entry env sigma flags pri] + [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name] in if ents = [] then errorlabstrm "Hint" @@ -345,7 +544,8 @@ let make_resolves env sigma flags pri c = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma (hname,_,htyp) = try - [make_apply_entry env sigma (true, true, false) None + [make_apply_entry env sigma (true, true, false) None + ~name:(PathHints [VarRef hname]) (mkVar hname, htyp)] with | Failure _ -> [] @@ -353,26 +553,30 @@ let make_resolve_hyp env sigma (hname,_,htyp) = (* REM : in most cases hintname = id *) let make_unfold eref = - (Some (global_of_evaluable_reference eref), + let g = global_of_evaluable_reference eref in + (Some g, { pri = 4; pat = None; + name = PathHints [g]; code = Unfold_nth eref }) let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in (hdconstr, - { pri=pri; + { pri = pri; pat = pat; - code= Extern tacast }) + name = PathAny; + code = Extern tacast }) -let make_trivial env sigma c = +let make_trivial env sigma ?(name=PathAny) c = let t = hnf_constr env sigma (type_of env sigma c) in let hd = head_of_constr_reference (fst (head_constr t)) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; - pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce))); - code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) - + pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce))); + name = name; + code=Res_pf_THEN_trivial_fail(c,t) }) + open Vernacexpr (**************************************************************************) @@ -402,23 +606,39 @@ let add_transparency dbname grs b = st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') -type hint_action = | CreateDB of bool * transparent_state - | AddTransparency of evaluable_global_reference list * bool - | AddTactic of (global_reference option * pri_auto_tactic) list +let remove_hint dbname grs = + let db = get_db dbname in + let db' = Hint_db.remove_list grs db in + searchtable_add (dbname, db') + +type hint_action = + | CreateDB of bool * transparent_state + | AddTransparency of evaluable_global_reference list * bool + | AddHints of hint_entry list + | RemoveHints of global_reference list + | AddCut of hints_path + +let add_cut dbname path = + let db = get_db dbname in + let db' = Hint_db.add_cut path db in + searchtable_add (dbname, db') + +type hint_obj = bool * string * hint_action (* locality, name, action *) let cache_autohint (_,(local,name,hints)) = match hints with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) | AddTransparency (grs, b) -> add_transparency name grs b - | AddTactic hints -> add_hint name hints + | AddHints hints -> add_hint name hints + | RemoveHints grs -> remove_hint name grs + | AddCut path -> add_cut name path let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for auto") let set_extern_subst_tactic f = forward_subst_tactic := f -let subst_autohint (subst,(local,name,hintlist as obj)) = - let trans_clenv clenv = Clenv.subst_clenv subst clenv in +let subst_autohint (subst,(local,name,hintlist as obj)) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = @@ -428,90 +648,72 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = in let subst_hint (k,data as hint) = let k' = Option.smartmap subst_key k in - let data' = match data.code with - | Res_pf (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=Res_pf (c', clenv')} - | ERes_pf (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=ERes_pf (c', clenv')} + let pat' = Option.smartmap (subst_pattern subst) data.pat in + let code' = match data.code with + | Res_pf (c,t) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code else Res_pf (c', t') + | ERes_pf (c,t) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t'==t then data.code else ERes_pf (c',t') | Give_exact c -> - let c' = subst_mps subst c in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Give_exact c')} - | Res_pf_THEN_trivial_fail (c, clenv) -> - let c' = subst_mps subst c in - let clenv' = trans_clenv clenv in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if c==c' && clenv'==clenv && pat'==data.pat then data else - {data with - pat=pat'; - code=Res_pf_THEN_trivial_fail (c',clenv')} + let c' = subst_mps subst c in + if c==c' then data.code else Give_exact c' + | Res_pf_THEN_trivial_fail (c,t) -> + let c' = subst_mps subst c in + let t' = subst_mps subst t in + if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t') | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if ref==ref' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Unfold_nth ref')} + if ref==ref' then data.code else Unfold_nth ref' | Extern tac -> let tac' = !forward_subst_tactic subst tac in - let pat' = Option.smartmap (subst_pattern subst) data.pat in - if tac==tac' && pat'==data.pat then data else - {data with - pat=pat'; - code=(Extern tac')} + if tac==tac' then data.code else Extern tac' in - if k' == k && data' == data then hint else - (k',data') + let data' = + if data.pat==pat' && data.code==code' then data + else { data with pat = pat'; code = code' } + in + if k' == k && data' == data then hint else (k',data') in match hintlist with | CreateDB _ -> obj | AddTransparency (grs, b) -> let grs' = list_smartmap (subst_evaluable_reference subst) grs in if grs==grs' then obj else (local, name, AddTransparency (grs', b)) - | AddTactic hintlist -> + | AddHints hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else - (local,name,AddTactic hintlist') + (local,name,AddHints hintlist') + | RemoveHints grs -> + let grs' = list_smartmap (fun x -> fst (subst_global subst x)) grs in + if grs==grs' then obj else (local, name, RemoveHints grs') + | AddCut path -> + let path' = subst_hints_path subst path in + if path' == path then obj else (local, name, AddCut path') let classify_autohint ((local,name,hintlist) as obj) = - if local or hintlist = (AddTactic []) then Dispose else Substitute obj + if local or hintlist = (AddHints []) then Dispose else Substitute obj -let discharge_autohint (_,(local,name,hintlist as obj)) = - if local then None else - match hintlist with - | CreateDB _ -> - (* We assume that the transparent state is either empty or full *) - Some obj - | AddTransparency _ | AddTactic _ -> - (* Needs the adequate code here to support Global Hints in sections *) - None - -let (inAutoHint,_) = +let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = (fun _ -> cache_autohint); subst_function = subst_autohint; - classify_function = classify_autohint } - + classify_function = classify_autohint; } let create_hint_db l n st b = Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) +let remove_hints local dbnames grs = + let dbnames = if dbnames = [] then ["core"] else dbnames in + List.iter + (fun dbname -> + Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs))) + dbnames + (**************************************************************************) (* The "Hint" vernacular command *) (**************************************************************************) @@ -520,16 +722,21 @@ let add_resolves env sigma clist local dbnames = (fun dbname -> Lib.add_anonymous_leaf (inAutoHint - (local,dbname, AddTactic - (List.flatten (List.map (fun (x, hnf, y) -> - make_resolves env sigma (true,hnf,Flags.is_verbose()) x y) clist))))) + (local,dbname, AddHints + (List.flatten (List.map (fun (x, hnf, path, y) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path y) clist))))) dbnames - let add_unfolds l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) + (inAutoHint (local,dbname, AddHints (List.map make_unfold l)))) + dbnames + +let add_cuts l local dbnames = + List.iter + (fun dbname -> Lib.add_anonymous_leaf + (inAutoHint (local,dbname, AddCut l))) dbnames let add_transparency l b local dbnames = @@ -550,10 +757,10 @@ let add_extern pri pat tacast local dbname = (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.") | [] -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) + (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast]))) | None -> Lib.add_anonymous_leaf - (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) + (inAutoHint(local,dbname, AddHints [make_extern pri None tacast])) let add_externs pri pat tacast local dbnames = List.iter (add_extern pri pat tacast local) dbnames @@ -562,7 +769,8 @@ let add_trivials env sigma l local dbnames = List.iter (fun dbname -> Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) + inAutoHint(local,dbname, + AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l)))) dbnames let forward_intern_tac = @@ -571,8 +779,9 @@ let forward_intern_tac = let set_extern_intern_tac f = forward_intern_tac := f type hints_entry = - | HintsResolveEntry of (int option * bool * constr) list - | HintsImmediateEntry of constr list + | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list + | HintsImmediateEntry of (hints_path_atom * constr) list + | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsExternEntry of @@ -580,24 +789,69 @@ type hints_entry = | HintsDestructEntry of identifier * int * (bool,unit) location * (patvar list * constr_pattern) * glob_tactic_expr +let h = id_of_string "H" + +exception Found of constr * types + +let prepare_hint env (sigma,c) = + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + (* We re-abstract over uninstantiated evars. + It is actually a bit stupid to generalize over evars since the first + thing make_resolves will do is to re-instantiate the products *) + let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in + let vars = ref (collect_vars c) in + let subst = ref [] in + let rec find_next_evar c = match kind_of_term c with + | Evar (evk,args as ev) -> + (* We skip the test whether args is the identity or not *) + let t = Evarutil.nf_evar sigma (existential_type sigma ev) in + let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in + if free_rels t <> Intset.empty then + error "Hints with holes dependent on a bound variable not supported."; + if occur_existential t then + (* Not clever enough to construct dependency graph of evars *) + error "Not clever enough to deal with evars dependent in other evars."; + raise (Found (c,t)) + | _ -> iter_constr find_next_evar c in + let rec iter c = + try find_next_evar c; c + with Found (evar,t) -> + let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in + vars := Idset.add id !vars; + subst := (evar,mkVar id)::!subst; + mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in + iter c + +let path_of_constr_expr c = + match c with + | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny) + | _ -> PathAny + let interp_hints h = - let f = Constrintern.interp_constr Evd.empty (Global.env()) in + let f c = + let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in + let c = prepare_hint (Global.env()) (evd,c) in + Evarutil.check_evars (Global.env()) Evd.empty evd c; + c in let fr r = let gr = global_with_alias r in let r' = evaluable_of_global_reference (Global.env()) gr in Dumpglob.add_glob (loc_of_reference r) gr; r' in + let fres (o, b, c) = (o, b, path_of_constr_expr c, f c) in + let fi c = path_of_constr_expr c, f c in let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in match h with - | HintsResolve lhints -> HintsResolveEntry (List.map (on_pi3 f) lhints) - | HintsImmediate lhints -> HintsImmediateEntry (List.map f lhints) + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) | HintsTransparency (lhints, b) -> HintsTransparencyEntry (List.map fr lhints, b) | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in - list_tabulate (fun i -> None, true, mkConstruct (ind,i+1)) + list_tabulate (fun i -> let c = (ind,i+1) in + None, true, PathHints [ConstructRef c], mkConstruct c) (nconstructors ind) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> @@ -609,11 +863,14 @@ let interp_hints h = HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code) let add_hints local dbnames0 h = + if List.mem "nocore" dbnames0 then + error "The hint database \"nocore\" is meant to stay empty."; let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in let env = Global.env() and sigma = Evd.empty in match h with | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames + | HintsCutEntry lhints -> add_cuts lhints local dbnames | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames | HintsTransparencyEntry (lhints, b) -> add_transparency lhints b local dbnames @@ -639,8 +896,8 @@ let pr_autotactic = | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) -let pr_hint v = - (pr_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ()) +let pr_hint (id, v) = + (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ()) @@ -655,7 +912,7 @@ let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in let valid_dbs = map_succeed - (fun (name,db) -> (name,db,Hint_db.map_all c db)) + (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db))) dbs in if valid_dbs = [] then @@ -682,6 +939,7 @@ let pr_hint_term cl = else Hint_db.map_auto (hd, applist (hdc,args)) with Bound -> Hint_db.map_none in + let fn db = List.map (fun x -> 0, x) (fn db) in map_succeed (fun (name, db) -> (name, db, fn db)) dbs in if valid_dbs = [] then @@ -700,8 +958,12 @@ let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) let print_applicable_hint () = let pts = get_pftreestate () in - let gl = nth_goal_of_pftreestate 1 pts in - print_hint_term (pf_concl gl) + let glss = Proof.V82.subgoals pts in + match glss.Evd.it with + | [] -> Util.error "No focused goal." + | g::_ -> + let gl = { Evd.it = g; sigma = glss.Evd.sigma } in + print_hint_term (pf_concl gl) (* displays the whole hint database db *) let print_hint_db db = @@ -711,17 +973,18 @@ let print_hint_db db = else str"Non-discriminated database"))); msgnl (hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids)); msgnl (hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts)); + msgnl (hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db))); Hint_db.iter (fun head hintlist -> match head with | Some head -> msg (hov 0 (str "For " ++ pr_global head ++ str " -> " ++ - pr_hint_list hintlist)) + pr_hint_list (List.map (fun x -> (0,x)) hintlist))) | None -> msg (hov 0 (str "For any goal -> " ++ - pr_hint_list hintlist))) + pr_hint_list (List.map (fun x -> (0, x)) hintlist)))) db let print_hint_db_by_name dbname = @@ -746,7 +1009,7 @@ let print_searchtable () = (* tactics with a trace mechanism for automatic search *) (**************************************************************************) -let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l +let priority l = List.filter (fun (_, hint) -> hint.pri = 0) l (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -755,10 +1018,18 @@ open Unification let auto_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly = false; + use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = false; resolve_evars = true; - use_evars_pattern_unification = false; + use_pattern_unification = false; + use_meta_bound_pattern_unification = true; + frozen_evars = ExistentialSet.empty; + restrict_conv_on_strict_subterms = false; (* Compat *) + modulo_betaiota = false; + modulo_eta = true; + allow_K_in_toplevel_higher_order_unification = false } (* Try unification with the precompiled clause, then use registered Apply *) @@ -769,12 +1040,12 @@ let h_clenv_refine ev c clenv = let unify_resolve_nodelta (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in h_clenv_refine false c clenv'' gl let unify_resolve flags (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let clenv'' = clenv_unique_resolver false ~flags clenv' gl in + let clenv'' = clenv_unique_resolver ~flags clenv' gl in h_clenv_refine false c clenv'' gl let unify_resolve_gen = function @@ -783,40 +1054,44 @@ let unify_resolve_gen = function (* Util *) -let expand_constructor_hints lems = - list_map_append (fun lem -> +let expand_constructor_hints env lems = + list_map_append (fun (sigma,lem) -> match kind_of_term lem with | Ind ind -> list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind) | _ -> - [lem]) lems + [prepare_hint env (sigma,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) let add_hint_lemmas eapply lems hint_db gl = - let lems = expand_constructor_hints lems in + let lems = expand_constructor_hints (pf_env gl) lems in let hintlist' = list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in Hint_db.add_list hintlist' hint_db -let make_local_hint_db eapply lems gl = +let make_local_hint_db ?ts eapply lems gl = let sign = pf_hyps gl in + let ts = match ts with + | None -> Hint_db.transparent_state (searchtable_map "core") + | Some ts -> ts + in let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in add_hint_lemmas eapply lems - (Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false)) gl + (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl (* Serait-ce possible de compiler d'abord la tactique puis de faire la - substitution sans passer par bdize dont l'objectif est de préparer un + substitution sans passer par bdize dont l'objectif est de préparer un terme pour l'affichage ? (HH) *) -(* Si on enlève le dernier argument (gl) conclPattern est calculé une +(* Si on enlève le dernier argument (gl) conclPattern est calculé une fois pour toutes : en particulier si Pattern.somatch produit une UserError -Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même -si après Intros la conclusion matche le pattern. +Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même +si après Intros la conclusion matche le pattern. *) -(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) +(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for auto") @@ -837,8 +1112,8 @@ let conclPattern concl pat tac gl = (**************************************************************************) (* local_db is a Hint database containing the hypotheses of current goal *) -(* Papageno : cette fonction a été pas mal simplifiée depuis que la base - de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) +(* Papageno : cette fonction a été pas mal simplifiée depuis que la base + de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = {auto_unif_flags with @@ -864,7 +1139,7 @@ let rec trivial_fail_db mod_delta db_list local_db gl = in tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map (fun tac -> tclCOMPLETE tac) (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = @@ -876,7 +1151,7 @@ and my_find_search mod_delta = else my_find_search_nodelta and my_find_search_delta db_list local_db hdc concl = - let flags = {auto_unif_flags with use_metas_eagerly = true} in + let flags = {auto_unif_flags with use_metas_eagerly_in_conv_on_closed_terms = true} in let f = hintmap_of hdc concl in if occur_existential concl then list_map_append @@ -906,20 +1181,23 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) = - match t with - | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> +and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) = + let tactic = + match t with + | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl) + | ERes_pf _ -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (c,cl) -> tclTHEN - (unify_resolve_gen flags (term,cl)) + (unify_resolve_gen flags (c,cl)) (trivial_fail_db (flags <> None) db_list local_db) - | Unfold_nth c -> (fun gl -> - if exists_evaluable_reference (pf_env gl) c then - tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl - else tclFAIL 0 (str"Unbound reference") gl) - | Extern tacast -> conclPattern concl p tacast + | Unfold_nth c -> + (fun gl -> + if exists_evaluable_reference (pf_env gl) c then + tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl + else tclFAIL 0 (str"Unbound reference") gl) + | Extern tacast -> conclPattern concl p tacast + in tactic and trivial_resolve mod_delta db_list local_db cl = try @@ -933,21 +1211,25 @@ and trivial_resolve mod_delta db_list local_db cl = (my_find_search mod_delta db_list local_db head cl)) with Not_found -> [] -let trivial lems dbnames gl = - let db_list = - List.map - (fun x -> - try - searchtable_map x - with Not_found -> - error_no_such_hint_database x) - ("core"::dbnames) +(** The use of the "core" database can be de-activated by passing + "nocore" amongst the databases. *) + +let make_db_list dbnames = + let use_core = not (List.mem "nocore" dbnames) in + let dbnames = list_remove "nocore" dbnames in + let dbnames = if use_core then "core"::dbnames else dbnames in + let lookup db = + try searchtable_map db with Not_found -> error_no_such_hint_database db in + List.map lookup dbnames + +let trivial lems dbnames gl = + let db_list = make_db_list dbnames in tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl let full_trivial lems gl = let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_subtract dbnames ["v62"] in + let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl @@ -955,10 +1237,8 @@ let gen_trivial lems = function | None -> full_trivial lems | Some l -> trivial lems l -let inj_open c = (Evd.empty,c) - let h_trivial lems l = - Refiner.abstract_tactic (TacTrivial (lems,l)) + Refiner.abstract_tactic (TacTrivial (List.map snd lems,l)) (gen_trivial lems l) (**************************************************************************) @@ -1051,15 +1331,7 @@ let search = search_gen 0 let default_search_depth = ref 5 let delta_auto mod_delta n lems dbnames gl = - let db_list = - List.map - (fun x -> - try - searchtable_map x - with Not_found -> - error_no_such_hint_database x) - ("core"::dbnames) - in + let db_list = make_db_list dbnames in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl let auto = delta_auto false @@ -1070,7 +1342,7 @@ let default_auto = auto !default_search_depth [] [] let delta_full_auto mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in - let dbnames = list_subtract dbnames ["v62"] in + let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl @@ -1088,7 +1360,7 @@ let gen_auto n lems dbnames = let inj_or_var = Option.map (fun n -> ArgArg n) let h_auto n lems l = - Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) + Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l)) (gen_auto n lems l) (**************************************************************************) @@ -1117,7 +1389,7 @@ let dauto (n,p) lems = let default_dauto = dauto (None,None) [] let h_dauto (n,p) lems = - Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems)) + Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems)) (dauto (n,p) lems) (***************************************) -- cgit v1.2.3 From 61dc740ed1c3780cccaec00d059a28f0d31d0052 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Mon, 4 Jun 2012 12:07:52 +0200 Subject: Imported Upstream version 8.4~gamma0+really8.4beta2 --- .gitignore | 3 + CHANGES | 56 +- COPYRIGHT | 2 +- CREDITS | 10 +- INSTALL | 6 +- Makefile | 2 +- Makefile.build | 14 +- Makefile.common | 17 +- Makefile.doc | 44 +- README | 6 +- TODO | 53 - checker/mod_checking.ml | 74 +- checker/subtyping.ml | 58 +- configure | 29 +- dev/base_include | 6 +- dev/printers.mllib | 2 +- dev/top_printers.ml | 4 + doc/common/macros.tex | 1 + doc/common/styles/html/coqremote/cover.html | 9 +- doc/common/styles/html/coqremote/footer.html | 45 + doc/common/styles/html/coqremote/header.html | 49 + doc/common/styles/html/simple/cover.html | 10 +- doc/common/styles/html/simple/footer.html | 2 + doc/common/styles/html/simple/header.html | 13 + doc/common/title.tex | 2 +- doc/faq/FAQ.tex | 6 +- doc/refman/Cases.tex | 2 +- doc/refman/RefMan-cic.tex | 77 +- doc/refman/RefMan-coi.tex | 4 +- doc/refman/RefMan-com.tex | 176 +- doc/refman/RefMan-ext.tex | 41 +- doc/refman/RefMan-gal.tex | 4 +- doc/refman/RefMan-ltac.tex | 3 +- doc/refman/RefMan-oth.tex | 138 +- doc/refman/RefMan-pro.tex | 79 +- doc/refman/RefMan-sch.tex | 418 ++ doc/refman/RefMan-syn.tex | 2 +- doc/refman/RefMan-tac.tex | 6168 ++++++++++++------------ doc/refman/RefMan-tacex.tex | 584 --- doc/refman/RefMan-uti.tex | 52 +- doc/refman/Reference-Manual.tex | 7 +- doc/refman/coqdoc.tex | 12 +- doc/stdlib/hidden-files | 0 doc/stdlib/index-list.html.template | 36 +- doc/stdlib/index-trailer.html | 2 - doc/stdlib/make-library-index | 34 +- ide/command_windows.ml | 24 +- ide/command_windows.mli | 2 + ide/coq.ml | 120 +- ide/coq.mli | 14 +- ide/coq_commands.ml | 1 - ide/coq_lex.mll | 28 +- ide/coqide-gtk2rc | 10 - ide/coqide.ml | 231 +- ide/coqide.mli | 3 - ide/coqide_main.ml4 | 24 +- ide/coqide_ui.ml | 28 +- ide/ideproof.ml | 16 +- ide/ideutils.ml | 99 +- ide/ideutils.mli | 13 + ide/minilib.ml | 47 +- ide/preferences.ml | 210 +- ide/preferences.mli | 21 +- ide/tags.ml | 33 +- ide/tags.mli | 50 + ide/utils/configwin.ml | 4 +- ide/utils/configwin_ihm.ml | 6 +- interp/constrextern.ml | 50 +- interp/constrextern.mli | 1 + interp/constrintern.ml | 70 +- interp/constrintern.mli | 3 + interp/genarg.ml | 42 +- interp/genarg.mli | 6 +- interp/notation.ml | 5 + interp/notation.mli | 2 + interp/topconstr.ml | 15 +- interp/topconstr.mli | 4 + kernel/declarations.mli | 4 + kernel/mod_typing.ml | 82 +- kernel/safe_typing.ml | 56 +- kernel/safe_typing.mli | 2 +- kernel/subtyping.ml | 74 +- kernel/term.ml | 1 + kernel/term.mli | 6 +- kernel/univ.ml | 111 +- kernel/univ.mli | 4 + lib/envars.ml | 6 +- lib/explore.ml | 18 +- lib/explore.mli | 2 +- lib/pp.ml4 | 19 +- lib/pp.mli | 3 + lib/util.ml | 25 +- lib/util.mli | 6 + lib/xml_parser.mli | 2 +- library/assumptions.ml | 18 +- library/declare.ml | 2 +- library/global.ml | 2 +- library/global.mli | 2 +- library/goptions.ml | 1 + library/impargs.ml | 13 +- library/lib.ml | 111 +- library/lib.mli | 43 +- man/coqc.1 | 12 + man/coqtop.1 | 8 +- myocamlbuild.ml | 9 + parsing/argextend.ml4 | 74 +- parsing/egrammar.ml | 41 +- parsing/egrammar.mli | 2 + parsing/extrawit.ml | 12 +- parsing/g_constr.ml4 | 24 +- parsing/g_proofs.ml4 | 21 +- parsing/g_tactic.ml4 | 27 +- parsing/g_vernac.ml4 | 4 +- parsing/ppconstr.ml | 72 +- parsing/ppconstr.mli | 6 +- parsing/pptactic.ml | 30 +- parsing/ppvernac.ml | 76 +- parsing/printer.ml | 37 +- parsing/printer.mli | 3 +- parsing/q_coqast.ml4 | 15 +- parsing/tacextend.ml4 | 61 +- plugins/decl_mode/g_decl_mode.ml4 | 5 +- plugins/dp/Dp.v | 118 - plugins/dp/TODO | 24 - plugins/dp/dp.ml | 1133 ----- plugins/dp/dp.mli | 20 - plugins/dp/dp_plugin.mllib | 5 - plugins/dp/dp_why.ml | 185 - plugins/dp/dp_why.mli | 17 - plugins/dp/dp_zenon.mli | 7 - plugins/dp/dp_zenon.mll | 189 - plugins/dp/fol.mli | 58 - plugins/dp/g_dp.ml4 | 77 - plugins/dp/test2.v | 80 - plugins/dp/tests.v | 300 -- plugins/dp/vo.itarget | 1 - plugins/dp/zenon.v | 92 - plugins/extraction/extract_env.ml | 11 +- plugins/extraction/modutil.ml | 11 +- plugins/firstorder/g_ground.ml4 | 2 - plugins/funind/functional_principles_proofs.ml | 3 +- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/invfun.ml | 55 +- plugins/funind/recdef.ml | 42 +- plugins/micromega/coq_micromega.ml | 19 +- plugins/nsatz/nsatz.ml4 | 2 +- plugins/pluginsbyte.itarget | 1 - plugins/pluginsdyn.itarget | 1 - plugins/pluginsopt.itarget | 1 - plugins/pluginsvo.itarget | 3 +- plugins/rtauto/proof_search.ml | 4 +- plugins/rtauto/proof_search.mli | 2 +- plugins/subtac/eterm.ml | 17 +- plugins/subtac/g_subtac.ml4 | 4 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_cases.ml | 2 +- plugins/subtac/subtac_classes.ml | 9 +- plugins/subtac/subtac_coercion.ml | 107 +- plugins/subtac/subtac_command.ml | 2 +- plugins/subtac/subtac_obligations.ml | 25 +- plugins/subtac/subtac_pretyping.ml | 4 +- plugins/subtac/subtac_pretyping_F.ml | 33 +- plugins/subtac/subtac_utils.ml | 11 +- plugins/subtac/subtac_utils.mli | 1 + plugins/xml/dumptree.ml4 | 4 +- pretyping/cases.ml | 5 +- pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 8 +- pretyping/evarconv.ml | 119 +- pretyping/evarutil.ml | 1503 +++--- pretyping/evarutil.mli | 6 +- pretyping/evd.ml | 10 +- pretyping/evd.mli | 2 + pretyping/inductiveops.ml | 19 +- pretyping/namegen.ml | 47 +- pretyping/namegen.mli | 5 +- pretyping/pretyping.ml | 9 +- pretyping/pretyping.mli | 3 +- pretyping/tacred.ml | 12 +- pretyping/typeclasses.ml | 34 +- pretyping/typeclasses.mli | 12 +- pretyping/unification.ml | 2 +- pretyping/vnorm.ml | 9 +- proofs/clenv.ml | 4 +- proofs/evar_refiner.ml | 2 +- proofs/goal.ml | 6 +- proofs/goal.mli | 4 +- proofs/logic.ml | 8 +- proofs/pfedit.ml | 14 +- proofs/pfedit.mli | 22 +- proofs/proof.ml | 134 +- proofs/proof.mli | 14 +- proofs/proof_global.ml | 72 +- proofs/proof_global.mli | 6 - proofs/proofview.ml | 11 + proofs/proofview.mli | 5 + proofs/refiner.ml | 4 - proofs/refiner.mli | 1 - proofs/tacexpr.ml | 11 +- proofs/tacmach.ml | 8 - proofs/tacmach.mli | 3 - proofs/tactic_debug.ml | 103 +- proofs/tactic_debug.mli | 7 + scripts/coqc.ml | 23 +- tactics/auto.ml | 417 +- tactics/auto.mli | 54 +- tactics/class_tactics.ml4 | 37 +- tactics/dhyp.ml | 359 -- tactics/dhyp.mli | 28 - tactics/eauto.ml4 | 146 +- tactics/eauto.mli | 4 +- tactics/extraargs.ml4 | 35 +- tactics/extraargs.mli | 2 + tactics/extratactics.ml4 | 18 +- tactics/refine.ml | 2 +- tactics/rewrite.ml4 | 22 +- tactics/tacinterp.ml | 605 ++- tactics/tacinterp.mli | 14 +- tactics/tacticals.ml | 1 - tactics/tacticals.mli | 1 - tactics/tactics.ml | 10 +- tactics/tactics.mllib | 1 - test-suite/bugs/closed/shouldsucceed/2603.v | 21 +- test-suite/bugs/closed/shouldsucceed/2732.v | 19 + test-suite/bugs/closed/shouldsucceed/2733.v | 26 + test-suite/complexity/autodecomp.v | 11 - test-suite/output/Arguments.out | 8 + test-suite/output/Arguments.v | 12 + test-suite/output/Notations2.out | 6 + test-suite/output/Notations2.v | 15 + test-suite/output/PrintInfos.out | 9 +- test-suite/success/Cases.v | 71 +- test-suite/success/CasesDep.v | 22 +- test-suite/success/Hints.v | 5 - test-suite/success/Mod_params.v | 84 +- test-suite/success/Notations.v | 14 +- test-suite/success/RecTutorial.v | 69 +- test-suite/success/Reset.v | 7 - test-suite/success/apply.v | 17 +- test-suite/success/coercions.v | 42 + test-suite/success/dependentind.v | 31 + test-suite/success/evars.v | 70 + test-suite/success/hyps_inclusion.v | 8 +- test-suite/success/telescope_canonical.v | 70 +- theories/Arith/Div2.v | 26 +- theories/Init/Logic.v | 4 +- theories/Init/Prelude.v | 1 - theories/Init/Specif.v | 2 +- theories/Lists/intro.tex | 2 +- theories/Logic/ChoiceFacts.v | 16 +- theories/MSets/MSetAVL.v | 1377 +----- theories/MSets/MSetGenTree.v | 1145 +++++ theories/MSets/MSetRBT.v | 1931 ++++++++ theories/MSets/vo.itarget | 2 + theories/Program/Equality.v | 26 +- theories/Unicode/Utf8_core.v | 4 +- theories/Vectors/Fin.v | 10 +- theories/Vectors/VectorDef.v | 23 +- theories/Vectors/VectorSpec.v | 6 + theories/Wellfounded/Lexicographic_Product.v | 14 +- theories/ZArith/Int.v | 128 +- theories/ZArith/ZOdiv.v | 88 + theories/ZArith/ZOdiv_def.v | 15 + theories/ZArith/Zeven.v | 6 +- theories/ZArith/vo.itarget | 2 + tools/coq_makefile.ml | 26 +- tools/coqdoc/cpretty.mll | 20 +- tools/coqdoc/index.ml | 6 +- tools/coqdoc/output.ml | 8 +- tools/win32hack.mllib | 1 + tools/win32hack_filename.ml | 4 + toplevel/backtrack.ml | 225 + toplevel/backtrack.mli | 93 + toplevel/class.ml | 2 +- toplevel/classes.ml | 9 +- toplevel/command.ml | 36 +- toplevel/coqtop.ml | 11 +- toplevel/himsg.ml | 16 +- toplevel/ide_intf.ml | 120 +- toplevel/ide_intf.mli | 26 + toplevel/ide_slave.ml | 436 +- toplevel/interface.mli | 47 +- toplevel/metasyntax.ml | 12 + toplevel/metasyntax.mli | 2 + toplevel/mltop.ml4 | 23 +- toplevel/mltop.mli | 10 + toplevel/record.ml | 6 +- toplevel/search.mli | 2 + toplevel/toplevel.ml | 3 - toplevel/toplevel.mllib | 1 + toplevel/vernac.ml | 65 +- toplevel/vernac.mli | 9 +- toplevel/vernacentries.ml | 198 +- toplevel/vernacentries.mli | 31 +- toplevel/vernacexpr.ml | 28 +- 295 files changed, 12968 insertions(+), 11382 deletions(-) delete mode 100644 TODO create mode 100644 doc/common/styles/html/coqremote/footer.html create mode 100644 doc/common/styles/html/coqremote/header.html create mode 100644 doc/common/styles/html/simple/footer.html create mode 100644 doc/common/styles/html/simple/header.html create mode 100644 doc/refman/RefMan-sch.tex create mode 100644 doc/stdlib/hidden-files delete mode 100644 doc/stdlib/index-trailer.html create mode 100644 ide/tags.mli delete mode 100644 plugins/dp/Dp.v delete mode 100644 plugins/dp/TODO delete mode 100644 plugins/dp/dp.ml delete mode 100644 plugins/dp/dp.mli delete mode 100644 plugins/dp/dp_plugin.mllib delete mode 100644 plugins/dp/dp_why.ml delete mode 100644 plugins/dp/dp_why.mli delete mode 100644 plugins/dp/dp_zenon.mli delete mode 100644 plugins/dp/dp_zenon.mll delete mode 100644 plugins/dp/fol.mli delete mode 100644 plugins/dp/g_dp.ml4 delete mode 100644 plugins/dp/test2.v delete mode 100644 plugins/dp/tests.v delete mode 100644 plugins/dp/vo.itarget delete mode 100644 plugins/dp/zenon.v delete mode 100644 tactics/dhyp.ml delete mode 100644 tactics/dhyp.mli create mode 100644 test-suite/bugs/closed/shouldsucceed/2732.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2733.v delete mode 100644 test-suite/complexity/autodecomp.v delete mode 100644 test-suite/success/Reset.v create mode 100644 theories/MSets/MSetGenTree.v create mode 100644 theories/MSets/MSetRBT.v create mode 100644 theories/ZArith/ZOdiv.v create mode 100644 theories/ZArith/ZOdiv_def.v create mode 100644 tools/win32hack.mllib create mode 100644 tools/win32hack_filename.ml create mode 100644 toplevel/backtrack.ml create mode 100644 toplevel/backtrack.mli (limited to 'tactics/auto.ml') diff --git a/.gitignore b/.gitignore index 7fcd2580..32a40af6 100644 --- a/.gitignore +++ b/.gitignore @@ -79,6 +79,9 @@ doc/stdlib/Library.out doc/stdlib/Library.pdf doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex +doc/stdlib/FullLibrary.pdf +doc/stdlib/FullLibrary.ps +doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/html/ doc/stdlib/index-body.html doc/stdlib/index-list.html diff --git a/CHANGES b/CHANGES index 74aefe49..c245fb25 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,54 @@ -Changes from V8.3 to V8.4 -========================= +Changes from V8.4beta to V8.4 +============================= + +Vernacular commands + +- Undo and UndoTo are now handling the proof states. They may + perform some extra steps of backtrack to avoid states where + the proof state is unavailable (typically a closed proof). +- The commands Suspend and Resume have been removed. +- A basic Show Script has been reintroduced (no indentation). +- New command "Set Parsing Explicit" for deactivating parsing (and printing) + of implicit arguments (useful for teaching). +- New command "Grab Existential Variables" to transform the unresolved evars at + the end of a proof into goals. + +Tactics + +- Still no general "info" tactical, but new specific tactics + info_auto, info_eauto, info_trivial which provides information + on the proofs found by auto/eauto/trivial. Display of these + details could also be activated by Set Info Auto/Eauto/Trivial. +- Details on everything tried by auto/eauto/trivial during + a proof search could be obtained by "debug auto", "debug eauto", + "debug trivial" or by a global "Set Debug Auto/Eauto/Trivial". +- New command "r string" that interprets "idtac string" as a breakpoint + and jumps to its next use in Ltac debugger. +- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, + harvey, zenon, gwhy) have been removed, since Why2 has not been + maintained for the last few years. The Why3 plugin should be a suitable + replacement in most cases. + +Libraries + +- MSetRBT : a new implementation of MSets via Red-Black trees (initial + contribution by Andrew Appel). +- MSetAVL : for maximal sharing with the new MSetRBT, the argument order + of Node has changed (this should be transparent to regular MSets users). + +Module System + +- The names of modules (and module types) are now in a fully separated + namespace from ordinary definitions : "Definition E:=0. Module E. End E." + is now accepted. + +CoqIDE + +- Coqide now supports the Restart command, and Undo (with a warning). + Better support for Abort. + +Changes from V8.3 to V8.4beta +============================= Logic @@ -69,6 +118,8 @@ Tactics - When applying destruct or inversion on a fixpoint hiding an inductive type, recursive calls to the fixpoint now remain folded by default (rare source of incompatibility generally solvable by adding a call to simpl). +- The behavior of the simpl tactic can be tuned using the new "Arguments" + vernacular. Vernacular commands @@ -90,6 +141,7 @@ Vernacular commands to avoid conversion at Qed time to go into a very long computation. - New command "Show Goal ident" to display the statement of a goal, even a closed one (available from Proof General). +- New command "Arguments" subsuming "Implicit Arguments" and "Arguments Scope". Module System diff --git a/COPYRIGHT b/COPYRIGHT index 8d81d8c4..3aa6aae9 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,6 +1,6 @@ The Coq proof assistant -Copyright 1999-2010 The Coq development team, INRIA, CNRS, University +Copyright 1999-2012 The Coq development team, INRIA, CNRS, University Paris Sud, University Paris 7, Ecole Polytechnique. This product includes also software developed by diff --git a/CREDITS b/CREDITS index 53bd9e93..543cb3f3 100644 --- a/CREDITS +++ b/CREDITS @@ -106,6 +106,7 @@ The following people have contributed to the development of different versions of the Coq Proof assistant during the indicated time: Bruno Barras (INRIA, 1995-now) + Pierre Boutillier (INRIA-PPS, 2010-now) Jacek Chrzaszcz (LRI, 1998-2003) Thierry Coquand (INRIA, 1985-1989) Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now) @@ -118,10 +119,12 @@ of the Coq Proof assistant during the indicated time: Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now) Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998) + Stéphane Glondu (INRIA-PPS, 2007-now) Benjamin Grégoire (INRIA, 2003-now) Hugo Herbelin (INRIA, 1996-now) Gérard Huet (INRIA, 1985-1997) - Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now) + Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now) + Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) Pascal Manoury (INRIA, 1993) Micaela Mayero (INRIA, 1997-2002) @@ -132,9 +135,11 @@ of the Coq Proof assistant during the indicated time: Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now) Jean-Marc Notin (CNRS, 2006-now) Catherine Parent-Vigouroux (ENS Lyon, 1992-1995) - Patrick Loiseleur (Paris Sud, 1997-1999) Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, LRI, 1997-now) + Pierre-Marie Pédrot (INRIA-PPS, 2011-now) + Matthias Puech (INRIA-Bologna, 2008-now) + Yann Régis-Gianas (INRIA-PPS, 2009-now) Clément Renard (INRIA, 2001-2004) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) @@ -142,6 +147,7 @@ of the Coq Proof assistant during the indicated time: Élie Soubiran (INRIA, 2007-now) Matthieu Sozeau (INRIA, 2005-now) Arnaud Spiwack (INRIA, 2006-now) + Enrico Tassi (INRIA, 2011-now) Benjamin Werner (INRIA, 1989-1994) *************************************************************************** diff --git a/INSTALL b/INSTALL index e88dc319..5ee00613 100644 --- a/INSTALL +++ b/INSTALL @@ -39,9 +39,9 @@ WHAT DO YOU NEED ? urpmi coq - Should you need or prefer to compile Coq V8.2 yourself, you need: + Should you need or prefer to compile Coq V8.4 yourself, you need: - - Objective Caml version 3.10.0 or later + - Objective Caml version 3.11.2 or later (available at http://caml.inria.fr/) - Camlp5 (version <= 4.08, or 5.* transitional) @@ -87,7 +87,7 @@ QUICK INSTALLATION PROCEDURE. INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= -1- Check that you have the Objective Caml compiler version 3.10.0 (or later) +1- Check that you have the Objective Caml compiler version 3.11.2 (or later) installed on your computer and that "ocamlmktop" and "ocamlc" (or its native code version "ocamlc.opt") lie in a directory which is present in your $PATH environment variable. diff --git a/Makefile b/Makefile index 876ac583..0ff72856 100644 --- a/Makefile +++ b/Makefile @@ -191,6 +191,7 @@ docclean: rm -f doc/common/version.tex rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html rm -f doc/coq.tex + rm -f doc/refman/styles.hva doc/refman/cover.html archclean: clean-ide optclean voclean rm -rf _build myocamlbuild_config.ml @@ -221,7 +222,6 @@ cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli distclean: clean cleanconfig - $(MAKE) -C test-suite distclean voclean: rm -f states/*.coq diff --git a/Makefile.build b/Makefile.build index 59ee457c..41dfabbf 100644 --- a/Makefile.build +++ b/Makefile.build @@ -318,7 +318,7 @@ $(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT) $(STRIP) $@ $(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE) - $(SHOW)'OCAMLOPT -o $@' + $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\ str.cma $(COQRUNBYTEFLAGS) $(LINKIDE) @@ -446,7 +446,7 @@ noreal: logic arith bool zarith qarith lists sets fsets relations \ # 3) plugins ########################################################################### -.PHONY: plugins omega micromega ring setoid_ring nsatz dp xml extraction +.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction .PHONY: field fourier funind cc subtac rtauto pluginsopt plugins: $(PLUGINSVO) @@ -455,7 +455,6 @@ micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) ring: $(RINGVO) $(RINGCMA) setoid_ring: $(NEWRINGVO) $(NEWRINGCMA) nsatz: $(NSATZVO) $(NSATZCMA) -dp: $(DPCMA) xml: $(XMLVO) $(XMLCMA) extraction: $(EXTRACTIONCMA) field: $(FIELDVO) $(FIELDCMA) @@ -623,7 +622,7 @@ INSTALLCMI = $(sort \ install-library: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib @@ -632,7 +631,7 @@ install-library: $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) ifeq ($(BEST),opt) $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) + $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install # it with libraries @@ -643,11 +642,14 @@ endif install-library-light: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states rm -f $(FULLCOQLIB)/revision -$(INSTALLLIB) revision $(FULLCOQLIB) +ifeq ($(BEST),opt) + $(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT) +endif install-coq-info: install-coq-manpages install-emacs install-latex diff --git a/Makefile.common b/Makefile.common index b560bae5..3740b52e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -79,7 +79,7 @@ SRCDIRS:=\ pretyping interp toplevel/utils toplevel parsing \ ide/utils ide \ $(addprefix plugins/, \ - omega romega micromega quote ring dp \ + omega romega micromega quote ring \ setoid_ring xml extraction fourier \ cc funind firstorder field subtac \ rtauto nsatz syntax decl_mode) @@ -125,14 +125,15 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ RefMan-cic.v.tex RefMan-lib.v.tex \ RefMan-tacex.v.tex RefMan-syn.v.tex \ RefMan-oth.v.tex RefMan-ltac.v.tex \ - RefMan-decl.v.tex \ + RefMan-decl.v.tex RefMan-sch.v.tex \ + RefMan-pro.v.tex \ Cases.v.tex Coercion.v.tex Extraction.v.tex \ Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \ Setoid.v.tex Helm.tex Classes.v.tex ) REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ - RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \ + RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \ $(REFMANCOQTEXFILES) \ @@ -176,7 +177,6 @@ QUOTECMA:=plugins/quote/quote_plugin.cma RINGCMA:=plugins/ring/ring_plugin.cma NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma NSATZCMA:=plugins/nsatz/nsatz_plugin.cma -DPCMA:=plugins/dp/dp_plugin.cma FIELDCMA:=plugins/field/field_plugin.cma XMLCMA:=plugins/xml/xml_plugin.cma FOURIERCMA:=plugins/fourier/fourier_plugin.cma @@ -196,14 +196,14 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \ DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \ - $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \ + $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \ $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \ $(CCCMA) $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \ $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) ifneq ($(HASNATDYNLINK),false) STATICPLUGINS:= - INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \ + INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ $(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA) INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) PLUGINS:=$(PLUGINSCMA) @@ -314,7 +314,6 @@ NEWRINGVO:=$(call cat_vo_itarget, plugins/setoid_ring) NSATZVO:=$(call cat_vo_itarget, plugins/nsatz) FOURIERVO:=$(call cat_vo_itarget, plugins/fourier) FUNINDVO:=$(call cat_vo_itarget, plugins/funind) -DPVO:=$(call cat_vo_itarget, plugins/dp) RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto) EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction) XMLVO:= @@ -322,7 +321,7 @@ CCVO:= PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \ $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \ - $(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \ + $(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \ $(NSATZVO) $(EXTRACTIONVO) ALLVO:= $(THEORIESVO) $(PLUGINSVO) @@ -347,8 +346,6 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ man/coqwc.1 man/coqdoc.1 man/coqide.1 \ man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 -DATE=$(shell LANG=C date +"%B %Y") - ########################################################################### # Source documentation ########################################################################### diff --git a/Makefile.doc b/Makefile.doc index 59eb2fe8..685887f5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -12,7 +12,7 @@ ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib faq rectutorial +.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt @@ -126,14 +126,16 @@ doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html ALLINDEXES:= doc/refman/html/index.html $(INDEXES) -$(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ +$(ALLINDEXES): refman-html-dir + +refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html (cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html - $(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html + -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ @@ -200,40 +202,32 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html ### Standard library (browsable html format) ifdef QUICK -doc/stdlib/index-body.html: - - rm -rf doc/stdlib/html - $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ - -R theories Coq $(THEORIESVO:.vo=.v) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html +doc/stdlib/html/genindex.html: else -doc/stdlib/index-body.html: $(COQDOC) $(THEORIESVO) +doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) +endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ + $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ -R theories Coq $(THEORIESVO:.vo=.v) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html -endif + mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index - ./doc/stdlib/make-library-index doc/stdlib/index-list.html + ./doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files -doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html - cat doc/stdlib/index-list.html > $@ - sed -n -e '//,/<\/table>/p' doc/stdlib/index-body.html >> $@ - cat doc/stdlib/index-trailer.html >> $@ +doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html + cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@ + cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@ ### Standard library (light version, full version is definitely too big) ifdef QUICK doc/stdlib/Library.coqdoc.tex: - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ else -doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO) - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ +doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) endif + $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ + -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ @@ -255,12 +249,12 @@ ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp endif doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex diff --git a/README b/README index 4f4afa5b..9bf63c43 100644 --- a/README +++ b/README @@ -38,7 +38,7 @@ THE COQ CLUB. discuss questions about the Coq system and related topics. The submission address is: - coq-club@coq.inria.fr + coq-club@inria.fr The topics to be discussed in the club should include: @@ -55,7 +55,7 @@ THE COQ CLUB. To be added to, or removed from, the mailing list, please write to: - coq-club-request@coq.inria.fr + coq-club-request@inria.fr Please use also this address for any questions/suggestions about the Coq Club. It might sometimes take a few days before your messages get @@ -67,7 +67,7 @@ BUGS REPORT. Send your bug reports by filling a form at - http://logical.saclay.inria.fr/coq-bugs + http://coq.inria.fr/bugs To be effective, bug reports should mention the Caml version used to compile and run Coq, the Coq version (coqtop -v), the configuration diff --git a/TODO b/TODO deleted file mode 100644 index d6891e5f..00000000 --- a/TODO +++ /dev/null @@ -1,53 +0,0 @@ -Langage: - -Distribution: - -Environnement: - -- Porter SearchIsos - -Noyau: - -Tactic: - -- Que contradiction raisonne a isomorphisme pres de False - -Vernac: - -- Print / Print Proof en fait identiques ; Print ne devrait pas afficher - les constantes opaques (devrait afficher qqchose comme ) - -Theories: - -- Rendre transparent tous les theoremes prouvant {A}+{B} -- Faire demarrer PolyList.nth a` l'indice 0 - Renommer l'actuel nth en nth1 ?? - -Doc: - -- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection -- Documenter le filtrage sur les types inductifs avec let-ins (dont la - compatibilite V6) - -- Ajouter let dans les règles du CIC - -> FAIT, mais reste a documenter le let dans les inductifs - et les champs manifestes dans les Record -- revoir le chapitre sur les tactiques utilisateur -- faut-il mieux spécifier la sémantique de Simpl (??) - -- Préciser la clarification syntaxique de IntroPattern -- preciser que Goal vient en dernier dans une clause pattern list et - qu'il doit apparaitre si il y a un "in" - -- Omega Time debranche mais Omega System et Omega Action remarchent ? -- Ajout "Replace in" (mais TODO) -- Syntaxe Conditional tac Rewrite marche, à documenter -- Documenter Dependent Rewrite et CutRewrite ? -- Ajouter les motifs sous-termes de ltac - -- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.) -- mettre à jour la doc de induction (arguments multiples) (Pierre C.) -- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.) ---> mettre à jour le CHANGES (vers la ligne 72) - - diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9942816d..e3431fec 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -53,10 +53,14 @@ let path_of_mexpr = function | SEBident mp -> mp | _ -> raise Not_path -let rec list_split_assoc k rev_before = function +let is_modular = function + | SFBmodule _ | SFBmodtype _ -> true + | SFBconst _ | SFBmind _ -> false + +let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail + | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after + | h::tail -> list_split_assoc km (h::rev_before) tail let check_definition_sub env cb1 cb2 = let check_type env t1 t2 = @@ -131,38 +135,35 @@ let lookup_modtype mp env = let rec check_with env mtb with_decl mp= match with_decl with - | With_definition_body _ -> - check_with_aux_def env mtb with_decl mp; + | With_definition_body (idl,c) -> + check_with_def env mtb (idl,c) mp; mtb - | With_module_body _ -> - check_with_aux_mod env mtb with_decl mp; + | With_module_body (idl,mp1) -> + check_with_mod env mtb (idl,mp1) mp; mtb -and check_with_aux_def env mtb with_decl mp = +and check_with_def env mtb (idl,c) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_definition_body ([],_) -> assert false - | With_definition_body ([id],c) -> + if idl = [] then let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l in check_definition_sub env' c cb - | With_definition_body (_::_,_) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -170,49 +171,36 @@ and check_with_aux_def env mtb with_decl mp = begin match old.mod_expr with | None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l)) + check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl mp = +and check_with_mod env mtb (idl,mp1) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in let before = List.rev rev_before in - let rec mp_rec = function - | [] -> mp - | i::r -> MPdot(mp_rec r,label_of_id i) - in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_module_body ([],_) -> assert false - | With_module_body ([id], mp1) -> + if idl = [] then let _ = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in let (_:module_body) = (lookup_module mp1 env) in () - | With_module_body (_::_,mp) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -220,17 +208,11 @@ and check_with_aux_mod env mtb with_decl mp = begin match old.mod_expr with None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_mod env' - old.mod_type new_with_decl (MPdot(mp,l)) + check_with_mod env' + old.mod_type (idl,mp1) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 0c97254b..9870ba13 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -28,15 +28,18 @@ type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body + +type namedmodule = | Module of module_body | Modtype of module_type_body (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = - let add_nameobjects_of_one j oib map = - let ip = (ln,j) in +let add_mib_nameobjects mp l mib map = + let ind = make_mind mp empty_dirpath l in + let add_mip_nameobjects j oib map = + let ip = (ind,j) in let map = array_fold_right_i (fun i id map -> @@ -46,22 +49,32 @@ let add_nameobjects_of_mib ln mib map = in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in - array_fold_right_i add_nameobjects_of_one mib.mind_packets map + array_fold_right_i add_mip_nameobjects mib.mind_packets map + + +(* creates (namedobject/namedmodule) map for the whole signature *) +type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } -(* creates namedobject map for the whole signature *) +let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } -let make_label_map mp list = +let get_obj mp map l = + try Labmap.find l map.objs + with Not_found -> error_no_such_label_sub l mp + +let get_mod mp map l = + try Labmap.find l map.mods + with Not_found -> error_no_such_label_sub l mp + +let make_labmap mp list = let add_one (l,e) map = - let add_map obj = Labmap.add l obj map in match e with - | SFBconst cb -> add_map (Constant cb) - | SFBmind mib -> - add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map - | SFBmodule mb -> add_map (Module mb) - | SFBmodtype mtb -> add_map (Modtype mtb) + | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } + | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } + | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } + | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in - List.fold_right add_one list Labmap.empty + List.fold_right add_one list empty_labmap let check_conv_error error f env a1 a2 = @@ -282,7 +295,6 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 - | _ -> error () let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in @@ -291,29 +303,25 @@ let rec check_modules env msb1 msb2 subst1 subst2 = and check_signatures env mp1 sig1 sig2 subst1 subst2 = - let map1 = make_label_map mp1 sig1 in + let map1 = make_labmap mp1 sig1 in let check_one_body (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l mp1 - in match spec2 with | SFBconst cb2 -> - check_constant env mp1 l info1 cb2 spec2 subst1 subst2 + check_constant env mp1 l (get_obj mp1 map1 l) + cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive env mp1 l info1 mib2 spec2 subst1 subst2 + check_inductive env mp1 l (get_obj mp1 map1 l) + mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin - match info1 with + match get_mod mp1 map1 l with | Module msb -> check_modules env msb msb2 subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> let mtb1 = - match info1 with + match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in diff --git a/configure b/configure index 867ee935..44170b99 100755 --- a/configure +++ b/configure @@ -6,10 +6,10 @@ # ################################## -VERSION=8.4beta +VERSION=8.4beta2 VOMAGIC=08400 STATEMAGIC=58400 -DATE="December 2011" +DATE=`LC_ALL=C LANG=C date +"%B %Y"` # Create the bin/ directory if non-existent test -d bin || mkdir bin @@ -292,7 +292,7 @@ case $DATEPGM in "") echo "I can't find the program \"date\" in your path." echo "Please give me the current date" read COMPILEDATE;; - *) COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;; + *) COMPILEDATE=`LC_ALL=C LANG=C date +"%h %d %Y %H:%M:%S"`;; esac # Architecture @@ -388,7 +388,7 @@ fi if [ "$browser_spec" = "no" ]; then case $ARCH in - win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;; + win32) BROWSER='start %s' ;; Darwin) BROWSER='open %s' ;; *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;; esac @@ -445,16 +445,16 @@ esac CAMLVERSION=`"$bytecamlc" -version` case $CAMLVERSION in - 1.*|2.*|3.0*) + 1.*|2.*|3.0*|3.10*|3.11.[01]) echo "Your version of Objective-Caml is $CAMLVERSION." if [ "$force_caml_version" = "yes" ]; then echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml." else - echo " You need Objective-Caml 3.10.0 or later." + echo " You need Objective-Caml 3.11.2 or later." echo " Configuration script failed!" exit 1 fi;; - 3.1*) + 3.11.2|3.12*) CAMLP4COMPAT="-loc loc" echo "You have Objective-Caml $CAMLVERSION. Good!";; *) @@ -742,7 +742,7 @@ case $ARCH$CYGWIN in bindir_def=${W32PREF}bin libdir_def=${W32PREF}lib configdir_def=${W32PREF}config - datadir_def=${W32PREF}data + datadir_def=${W32PREF}share mandir_def=${W32PREF}man docdir_def=${W32PREF}doc emacslib_def=${W32PREF}emacs @@ -795,10 +795,15 @@ case $libdir_spec in *) LIBDIR_OPTION="None";; esac -case $configdir_spec/$local in - yes/*) CONFIGDIR=$configdir;; - */true) CONFIGDIR=$COQTOP/ide - configdir_spec=yes;; +case $configdir_spec/$prefix_spec/$local in + yes/*/*) CONFIGDIR=$configdir;; + */yes/*) configdir_spec=yes + case $ARCH in + win32) CONFIGDIR=$prefix/config;; + *) CONFIGDIR=$prefix/etc/xdg/coq;; + esac;; + */*/true) CONFIGDIR=$COQTOP/ide + configdir_spec=yes;; *) printf "Where should I install the Coqide configuration files [$configdir_def]? " read CONFIGDIR case $CONFIGDIR in diff --git a/dev/base_include b/dev/base_include index d1125965..ad2a3aec 100644 --- a/dev/base_include +++ b/dev/base_include @@ -123,7 +123,6 @@ open Decl_mode open Auto open Autorewrite open Contradiction -open Dhyp open Eauto open Elim open Equality @@ -199,6 +198,11 @@ let current_goal () = get_nth_goal 1;; let pf_e gl s = Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);; +(* Set usual printing since the global env is available from the tracer *) +let _ = Constrextern.in_debugger := false +let _ = Constrextern.set_debug_global_reference_printer + (fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; + open Toplevel let go = loop diff --git a/dev/printers.mllib b/dev/printers.mllib index 6a42678e..40a5a822 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -105,12 +105,12 @@ Notation Dumpglob Reserve Impargs -Constrextern Syntax_def Implicit_quantifiers Smartlocate Constrintern Modintern +Constrextern Tacexpr Proof_type Goal diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 3fc90761..3116cbf2 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -487,5 +487,9 @@ let short_string_of_ref loc = function [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) +(* Anticipate that printers can be used from ocamldebug and that + pretty-printer should not make calls to the global env since ocamldebug + runs in a different process and does not have the proper env at hand *) +let _ = Constrextern.in_debugger := true let _ = Constrextern.set_debug_global_reference_printer (if !rawdebug then raw_string_of_ref else short_string_of_ref) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index f0fb0883..ce998a9b 100755 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -206,6 +206,7 @@ %END LATEX %HEVEA \renewcommand{\proof}{\nterm{proof}} \newcommand{\record}{\nterm{record}} +\newcommand{\recordkw}{\nterm{record\_keyword}} \newcommand{\rewrule}{\nterm{rewriting\_rule}} \newcommand{\sentence}{\nterm{sentence}} \newcommand{\simplepattern}{\nterm{simple\_pattern}} diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index f4809a48..62ee00ac 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -27,7 +27,6 @@
  • Home
    • -
  • About Coq
  • Get Coq
  • Documentation
    • @@ -64,9 +63,11 @@
    • V7.x © INRIA 1999-2004
      • -
    • V8.0 © INRIA 2004-2006
      • -
    • V8.1 © INRIA 2006-2008
      • -
    • V8.2 © INRIA 2008-2009
      • +
    • V8.0 © INRIA 2004-2008
      • +
    • V8.1 © INRIA 2006-2011
      • +
    • V8.2 © INRIA 2008-2011
      • +
    • V8.3 © INRIA 2010-2011
      • +
    • V8.4 © INRIA 2012

    This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub). Options A and B are not elected.

    diff --git a/doc/common/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html new file mode 100644 index 00000000..138c3025 --- /dev/null +++ b/doc/common/styles/html/coqremote/footer.html @@ -0,0 +1,45 @@ +
    + +
    + + +
    + + + + + + + + + + diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html new file mode 100644 index 00000000..afcdbe73 --- /dev/null +++ b/doc/common/styles/html/coqremote/header.html @@ -0,0 +1,49 @@ + + + + + +Standard Library | The Coq Proof Assistant + + + + + + + + + + + + + + + +
    + + + + +
    + diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 75b938f9..39dfd4ab 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -25,7 +25,7 @@

    Reference Manual

    - Version 8.21

    + Version 8.41





    The Coq Development Team

    @@ -35,9 +35,11 @@
    • V7.x © INRIA 1999-2004
      • -
    • V8.0 © INRIA 2004-2006
      • -
    • V8.1 © INRIA 2006-2008
      • -
    • V8.2 © INRIA 2008-2009
      • +
    • V8.0 © INRIA 2004-2008
      • +
    • V8.1 © INRIA 2006-2011
      • +
    • V8.2 © INRIA 2008-2011
      • +
    • V8.3 © INRIA 2010-2011
      • +
    • V8.4 © INRIA 2012

    This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub). Options A and B are not elected.

    diff --git a/doc/common/styles/html/simple/footer.html b/doc/common/styles/html/simple/footer.html new file mode 100644 index 00000000..308b1d01 --- /dev/null +++ b/doc/common/styles/html/simple/footer.html @@ -0,0 +1,2 @@ + + diff --git a/doc/common/styles/html/simple/header.html b/doc/common/styles/html/simple/header.html new file mode 100644 index 00000000..14d2f988 --- /dev/null +++ b/doc/common/styles/html/simple/header.html @@ -0,0 +1,13 @@ + + + + + + +The Coq Standard Library + + + + diff --git a/doc/common/title.tex b/doc/common/title.tex index 1dc52432..809b1046 100755 --- a/doc/common/title.tex +++ b/doc/common/title.tex @@ -45,7 +45,7 @@ V\coqversion, \today %END LATEX \copyright INRIA 1999-2004 ({\Coq} versions 7.x) -\copyright INRIA 2004-2009 ({\Coq} versions 8.x) +\copyright INRIA 2004-2012 ({\Coq} versions 8.x) #3 \end{flushleft} diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index c0f8c087..0bd84992 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -379,15 +379,15 @@ This FAQ is unfinished (in the sense that there are some obvious sections that are missing). Please send contributions to Coq-Club. \Question{Is there any mailing list about {\Coq}?} -The main {\Coq} mailing list is \url{coq-club@pauillac.inria.fr}, which +The main {\Coq} mailing list is \url{coq-club@inria.fr}, which broadcasts questions and suggestions about the implementation, the logical formalism or proof developments. See -\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{http://pauillac.inria.fr/mailman/listinfo/coq-club}} for +\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{http://sympa-roc.inria.fr/wws/info/coq-club}} for subscription. For bugs reports see question \ref{coqbug}. \Question{Where can I find an archive of the list?} The archives of the {\Coq} mailing list are available at -\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{http://coq.inria.fr/pipermail/coq-club}}. +\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{http://sympa-roc.inria.fr/wws/arc/coq-club}}. \Question{How can I be kept informed of new releases of {\Coq}?} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index 6f58269f..3ff4e25d 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -14,7 +14,7 @@ This section describes the full form of pattern-matching in {\Coq} terms. match} is presented in Figures~\ref{term-syntax} and~\ref{term-syntax-aux}. Identifiers in patterns are either constructor names or variables. Any identifier that is not the -constructor of an inductive or coinductive type is considered to be a +constructor of an inductive or co-inductive type is considered to be a variable. A variable name cannot occur more than once in a given pattern. It is recommended to start variable names by a lowercase letter. diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9660a04b..6a132eba 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -41,7 +41,7 @@ The beginner can skip them. The reader seeking a background on the Calculus of Inductive Constructions may read several papers. Giménez and Castéran~\cite{GimCas05} provide -an introduction to inductive and coinductive definitions in Coq. In +an introduction to inductive and co-inductive definitions in Coq. In their book~\cite{CoqArt}, Bertot and Castéran give a precise description of the \CIC{} based on numerous practical examples. Barras~\cite{Bar99}, Werner~\cite{Wer94} and @@ -80,35 +80,48 @@ type $(P~n)$ and consequently represent proofs of the formula \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} -Types are seen as terms of the language and then should belong to -another type. The type of a type is always a constant of the language -called a {\em sort}. - -The two basic sorts in the language of \CIC\ are \Set\ and \Prop. - -The sort \Prop\ intends to be the type of logical propositions. If -$M$ is a logical proposition then it denotes a class, namely the class -of terms representing proofs of $M$. An object $m$ belonging to $M$ -witnesses the fact that $M$ is true. An object of type \Prop\ is -called a {\em proposition}. - -The sort \Set\ intends to be the type of specifications. This includes -programs and the usual sets such as booleans, naturals, lists -etc. - -These sorts themselves can be manipulated as ordinary terms. -Consequently sorts also should be given a type. Because assuming -simply that \Set\ has type \Set\ leads to an inconsistent theory, we -have infinitely many sorts in the language of \CIC. These are, in -addition to \Set\ and \Prop\, a hierarchy of universes \Type$(i)$ -for any integer $i$. We call \Sort\ the set of sorts -which is defined by: +When manipulated as terms, types have themselves a type which is called a sort. + +There is an infinite well-founded typing hierarchy of sorts whose base +sorts are {\Prop} and {\Set}. + +The sort {\Prop} intends to be the type of logical propositions. If +$M$ is a logical proposition then it denotes the class of terms +representing proofs of $M$. An object $m$ belonging to $M$ witnesses +the fact that $M$ is provable. An object of type {\Prop} is called a +proposition. + +The sort {\Set} intends to be the type of small sets. This includes data +types such as booleans and naturals, but also products, subsets, and +function types over these data types. + +{\Prop} and {\Set} themselves can be manipulated as ordinary +terms. Consequently they also have a type. Because assuming simply +that {\Set} has type {\Set} leads to an inconsistent theory, the +language of {\CIC} has infinitely many sorts. There are, in addition +to {\Set} and {\Prop} a hierarchy of universes {\Type$(i)$} for any +integer $i$. + +Like {\Set}, all of the sorts {\Type$(i)$} contain small sets such as +booleans, natural numbers, as well as products, subsets and function +types over small sets. But, unlike {\Set}, they also contain large +sets, namely the sorts {\Set} and {\Type$(j)$} for $j! \emph{$id_i$} \verb!! - -Where: - -\begin{itemize} -\item \emph{$id_i$} is the name of the current proof (if there is - one, otherwise \texttt{Coq} is displayed, see -Chapter~\ref{Proof-handling}). -\item $\num_1$ is the environment state number after the last - command. -\item $\num_2$ is the proof state number after the last - command. -\item $id_1$ $id_2$ {\dots} $id_n$ are the currently opened proof names - (order not significant). +\item $\num_1$: State label to reach, as for {\tt BackTo}. \end{itemize} - -It is then possible to compute the \texttt{Backtrack} command to -unbury the state corresponding to a particular prompt. For example, -suppose the current prompt is: - -\verb!! - -and we want to backtrack to a state labeled by: - -\verb!! - -We have to perform \verb!Backtrack 32 12 2! , i.e. perform 2 -\texttt{Abort}s (to cancel goal4 and goal3), then rewind proof until -state 12 and finally go back to environment state 32. Notice that this -supposes that proofs are nested in a regular way (no \texttt{Resume} or -\texttt{Suspend} commands). - -\begin{Variants} -\item {\tt BackTo n}. \comindex{BackTo}\\ - Is a more basic form of \texttt{Backtrack} where only the first - argument (global environment number) is given, no \texttt{abort} and - no \texttt{Undo} is performed. \end{Variants} -\subsection[\tt Restore State \str.]{\tt Restore State \str.\comindex{Restore State}} - Restores the state contained in the file \str. +\begin{ErrMsgs} +\item \errindex{Invalid backtrack} \\ + The destination state label is unknown. +\end{ErrMsgs} -\begin{Variants} -\item {\tt Restore State \ident}\\ - Equivalent to {\tt Restore State "}{\ident}{\tt .coq"}. -\item {\tt Reset Initial.}\comindex{Reset Initial}\\ - Goes back to the initial state (like after the command {\tt coqtop}, - when the interactive session began). This command is only available - interactively. -\end{Variants} +\section{State files} \subsection[\tt Write State \str.]{\tt Write State \str.\comindex{Write State}} Writes the current state into a file \str{} for @@ -870,6 +836,14 @@ use in a further session. This file can be given as the {\tt The state is saved in the current directory (see Section~\ref{Pwd}). \end{Variants} +\subsection[\tt Restore State \str.]{\tt Restore State \str.\comindex{Restore State}} + Restores the state contained in the file \str. + +\begin{Variants} +\item {\tt Restore State \ident}\\ + Equivalent to {\tt Restore State "}{\ident}{\tt .coq"}. +\end{Variants} + \section{Quitting and debugging} \subsection[\tt Quit.]{\tt Quit.\comindex{Quit}} diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index e5dc669d..ca3a9cc9 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -34,9 +34,6 @@ isomorphism} \cite{How80,Bar91,Gir89,Hue89}, \Coq~ stores proofs as terms of {\sc Cic}. Those terms are called {\em proof terms}\index{Proof term}. -It is possible to edit several proofs in parallel: see Section -\ref{Resume}. - \ErrMsg When one attempts to use a proof editing command out of the proof editing mode, \Coq~ raises the error message : \errindex{No focused proof}. @@ -173,35 +170,6 @@ proof was edited. \end{Variants} -%%%% -\subsection[\tt Suspend.]{\tt Suspend.\comindex{Suspend}} - -This command applies in proof editing mode. It switches back to the -\Coq\ toplevel, but without canceling the current proofs. - -%%%% -\subsection[\tt Resume.]{\tt Resume.\comindex{Resume}\label{Resume}} - -This commands switches back to the editing of the last edited proof. - -\begin{ErrMsgs} -\item \errindex{No proof-editing in progress} -\end{ErrMsgs} - -\begin{Variants} - -\item {\tt Resume {\ident}.} - - Restarts the editing of the proof named {\ident}. This can be used - to navigate between currently edited proofs. - -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{No such proof} -\end{ErrMsgs} - - %%%% \subsection[\tt Existential {\num} := {\term}.]{\tt Existential {\num} := {\term}.\comindex{Existential} \label{Existential}} @@ -216,7 +184,14 @@ existential variables remain. To instantiate existential variables during proof edition, you should use the tactic {\tt instantiate}. \SeeAlso {\tt instantiate (\num:= \term).} in Section~\ref{instantiate}. +\SeeAlso {\tt Grab Existential Variables.} below. + +\subsection[\tt Grab Existential Variables.]{\tt Grab Existential Variables.\comindex{Grab Existential Variables} +\label{GrabEvars}} +This command can be run when a proof has no more goal to be solved but has remaining +uninstantiated existential variables. It takes every uninstantiated existential variable +and turns it into a goal. %%%%%%%% \section{Navigation in the proof tree} @@ -259,7 +234,45 @@ This focuses the attention on the $\num^{th}$ subgoal to prove. \end{Variant} \subsection[\tt Unfocus.]{\tt Unfocus.\comindex{Unfocus}} -Turns off the focus mode. +This command restores to focus the goal that were suspended by the +last {\tt Focus} command. + +\subsection[\tt Unfocused.]{\tt Unfocused.\comindex{Unfocused}} +Succeeds in the proof is fully unfocused, fails is there are some +goals out of focus. + +\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}} +The command {\tt \{} (without a terminating period) focuses on the +first goal, much like {\tt Focus.} does, however, the subproof can +only be unfocused when it has been fully solved (\emph{i.e.} when +there is no focused goal left). Unfocusing is then handled by {\tt \}} +(again, without a terminating period). See also example in next section. + +\subsection[Bullets]{Bullets\comindex{+ (command)}\comindex{- (command)}\comindex{* (command)}\index{Bullets}} +Alternatively to {\tt \{} and {\tt \}}, proofs can be structured with +bullets. The use of a bullet for the first time focuses on the first +goal, the same bullet cannot be used again until the subproof in +completed, then it focuses on the next goal. Different bullets can be +used to nest levels. The scope of bullet does not go beyond enclosing +{\tt \{} and {\tt \}}, so bullets can be reused as further nesting +level provided they are delimited by these. Available bullets are +{\tt -}, {\tt +} and {\tt *} (without a terminating period). + +The following example script illustrates all these features: +\begin{coq_example*} +Goal (((True/\True)/\True)/\True)/\True. +Proof. + split. + - split. + + split. + * { split. + - trivial. + - trivial. + } + * trivial. + + trivial. + - trivial. +\end{coq_example*} \section{Requesting information} diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex new file mode 100644 index 00000000..707ee824 --- /dev/null +++ b/doc/refman/RefMan-sch.tex @@ -0,0 +1,418 @@ +\chapter{Proof schemes} + +\section{Generation of induction principles with {\tt Scheme}} +\label{Scheme} +\index{Schemes} +\comindex{Scheme} + +The {\tt Scheme} command is a high-level tool for generating +automatically (possibly mutual) induction principles for given types +and sorts. Its syntax follows the schema: +\begin{quote} +{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type +identifiers belonging to the same package of mutual inductive +definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$} +to be mutually recursive definitions. Each term {\ident$_i$} proves a +general principle of mutual induction for objects in type {\term$_i$}. + +\begin{Variants} +\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Minimality for {\ident'$_m$} Sort + {\sort$_m$}} + + Same as before but defines a non-dependent elimination principle more + natural in case of inductively defined relations. + +\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}} + + Tries to generate a boolean equality and a proof of the + decidability of the usual equality. If \ident$_i$ involves + some other inductive types, their equality has to be defined first. + +\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with Induction for {\ident$_m$} Sort + {\sort$_m$}} + + If you do not provide the name of the schemes, they will be automatically + computed from the sorts involved (works also with Minimality). + +\end{Variants} +\label{Scheme-examples} + +\firstexample +\example{Induction scheme for \texttt{tree} and \texttt{forest}} + +The definition of principle of mutual induction for {\tt tree} and +{\tt forest} over the sort {\tt Set} is defined by the command: + +\begin{coq_eval} +Reset Initial. +Variables A B : Set. +\end{coq_eval} + +\begin{coq_example*} +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | leaf : B -> forest + | cons : tree -> forest -> forest. + +Scheme tree_forest_rec := Induction for tree Sort Set + with forest_tree_rec := Induction for forest Sort Set. +\end{coq_example*} + +You may now look at the type of {\tt tree\_forest\_rec}: + +\begin{coq_example} +Check tree_forest_rec. +\end{coq_example} + +This principle involves two different predicates for {\tt trees} and +{\tt forests}; it also has three premises each one corresponding to a +constructor of one of the inductive definitions. + +The principle {\tt forest\_tree\_rec} shares exactly the same +premises, only the conclusion now refers to the property of forests. + +\begin{coq_example} +Check forest_tree_rec. +\end{coq_example} + +\example{Predicates {\tt odd} and {\tt even} on naturals} + +Let {\tt odd} and {\tt even} be inductively defined as: + +% Reset Initial. +\begin{coq_eval} +Open Scope nat_scope. +\end{coq_eval} + +\begin{coq_example*} +Inductive odd : nat -> Prop := + oddS : forall n:nat, even n -> odd (S n) +with even : nat -> Prop := + | evenO : even 0 + | evenS : forall n:nat, odd n -> even (S n). +\end{coq_example*} + +The following command generates a powerful elimination +principle: + +\begin{coq_example} +Scheme odd_even := Minimality for odd Sort Prop + with even_odd := Minimality for even Sort Prop. +\end{coq_example} + +The type of {\tt odd\_even} for instance will be: + +\begin{coq_example} +Check odd_even. +\end{coq_example} + +The type of {\tt even\_odd} shares the same premises but the +conclusion is {\tt (n:nat)(even n)->(Q n)}. + +\subsection{Automatic declaration of schemes} +\comindex{Set Equality Schemes} +\comindex{Set Elimination Schemes} + +It is possible to deactivate the automatic declaration of the induction + principles when defining a new inductive type with the + {\tt Unset Elimination Schemes} command. It may be +reactivated at any time with {\tt Set Elimination Schemes}. +\\ + +You can also activate the automatic declaration of those boolean equalities +(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes} + command. However you have to be careful with this option since +\Coq~ may now reject well-defined inductive types because it cannot compute +a boolean equality for them. + +\subsection{\tt Combined Scheme} +\label{CombinedScheme} +\comindex{Combined Scheme} + +The {\tt Combined Scheme} command is a tool for combining +induction principles generated by the {\tt Scheme} command. +Its syntax follows the schema : +\begin{quote} +{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}} +\end{quote} +where +\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to +the same package of mutual inductive principle definitions. This command +generates {\ident$_0$} to be the conjunction of the principles: it is +built from the common premises of the principles and concluded by the +conjunction of their conclusions. + +\Example +We can define the induction principles for trees and forests using: +\begin{coq_example} +Scheme tree_forest_ind := Induction for tree Sort Prop + with forest_tree_ind := Induction for forest Sort Prop. +\end{coq_example} + +Then we can build the combined induction principle which gives the +conjunction of the conclusions of each individual principle: +\begin{coq_example} +Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind. +\end{coq_example} + +The type of {\tt tree\_forest\_mutrec} will be: +\begin{coq_example} +Check tree_forest_mutind. +\end{coq_example} + +\section{Generation of induction principles with {\tt Functional Scheme}} +\label{FunScheme} +\comindex{Functional Scheme} + +The {\tt Functional Scheme} command is a high-level experimental +tool for generating automatically induction principles +corresponding to (possibly mutually recursive) functions. Its +syntax follows the schema: +\begin{quote} +{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function +names (they must be in the same order as when they were defined). +This command generates the induction principles +\ident$_1$\dots\ident$_m$, following the recursive structure and case +analyses of the functions \ident'$_1$ \dots\ \ident'$_m$. + +\Rem +There is a difference between obtaining an induction scheme by using +\texttt{Functional Scheme} on a function defined by \texttt{Function} +or not. Indeed \texttt{Function} generally produces smaller +principles, closer to the definition written by the user. + +\firstexample +\example{Induction scheme for \texttt{div2}} +\label{FunScheme-examples} + +We define the function \texttt{div2} as follows: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Require Import Arith. +Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. +\end{coq_example*} + +The definition of a principle of induction corresponding to the +recursive structure of \texttt{div2} is defined by the command: + +\begin{coq_example} +Functional Scheme div2_ind := Induction for div2 Sort Prop. +\end{coq_example} + +You may now look at the type of {\tt div2\_ind}: + +\begin{coq_example} +Check div2_ind. +\end{coq_example} + +We can now prove the following lemma using this principle: + +\begin{coq_example*} +Lemma div2_le' : forall n:nat, div2 n <= n. +intro n. + pattern n , (div2 n). +\end{coq_example*} + +\begin{coq_example} +apply div2_ind; intros. +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +simpl; auto with arith. +Qed. +\end{coq_example*} + +We can use directly the \texttt{functional induction} +(\ref{FunInduction}) tactic instead of the pattern/apply trick: +\tacindex{functional induction} + +\begin{coq_example*} +Reset div2_le'. +Lemma div2_le : forall n:nat, div2 n <= n. +intro n. +\end{coq_example*} + +\begin{coq_example} +functional induction (div2 n). +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +auto with arith. +Qed. +\end{coq_example*} + +\Rem There is a difference between obtaining an induction scheme for a +function by using \texttt{Function} (see Section~\ref{Function}) and by +using \texttt{Functional Scheme} after a normal definition using +\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for +details. + + +\example{Induction scheme for \texttt{tree\_size}} + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +We define trees by the following mutual inductive type: + +\begin{coq_example*} +Variable A : Set. +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. +\end{coq_example*} + +We define the function \texttt{tree\_size} that computes the size +of a tree or a forest. Note that we use \texttt{Function} which +generally produces better principles. + +\begin{coq_example*} +Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. +\end{coq_example*} + +\Rem \texttt{Function} generates itself non mutual induction +principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}: + +\begin{coq_example} +Check tree_size_ind. +\end{coq_example} + +The definition of mutual induction principles following the recursive +structure of \texttt{tree\_size} and \texttt{forest\_size} is defined +by the command: + +\begin{coq_example*} +Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop +with forest_size_ind2 := Induction for forest_size Sort Prop. +\end{coq_example*} + +You may now look at the type of {\tt tree\_size\_ind2}: + +\begin{coq_example} +Check tree_size_ind2. +\end{coq_example} + +\section{Generation of inversion principles with \tt Derive Inversion} +\label{Derive-Inversion} +\comindex{Derive Inversion} + +The syntax of {\tt Derive Inversion} follows the schema: +\begin{quote} +{\tt Derive Inversion {\ident} with forall + $(\vec{x} : \vec{T})$, $I~\vec{t}$ Sort \sort} +\end{quote} + +This command generates an inversion principle for the +\texttt{inversion \dots\ using} tactic. +\tacindex{inversion \dots\ using} +Let $I$ be an inductive predicate and $\vec{x}$ the variables +occurring in $\vec{t}$. This command generates and stocks the +inversion lemma for the sort \sort~ corresponding to the instance +$\forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf +global} environment. When applied, it is equivalent to having inverted +the instance with the tactic {\tt inversion}. + +\begin{Variants} +\item \texttt{Derive Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{inversion} + replaced by the tactic \texttt{inversion\_clear}. +\item \texttt{Derive Dependent Inversion {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion}. +\item \texttt{Derive Dependent Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion\_clear}. +\end{Variants} + +\Example + +Let us consider the relation \texttt{Le} over natural numbers and the +following variable: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Inductive Le : nat -> nat -> Set := + | LeO : forall n:nat, Le 0 n + | LeS : forall n m:nat, Le n m -> Le (S n) (S m). +Variable P : nat -> nat -> Prop. +\end{coq_example*} + +To generate the inversion lemma for the instance +\texttt{(Le (S n) m)} and the sort \texttt{Prop}, we do: + +\begin{coq_example*} +Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort Prop. +\end{coq_example*} + +\begin{coq_example} +Check leminv. +\end{coq_example} + +Then we can use the proven inversion lemma: + +\begin{coq_eval} +Lemma ex : forall n m:nat, Le (S n) m -> P n m. +intros. +\end{coq_eval} + +\begin{coq_example} +Show. +\end{coq_example} + +\begin{coq_example} +inversion H using leminv. +\end{coq_example} + diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index ea3d55f2..fd608f06 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -369,7 +369,7 @@ reserved. Hence their precedence and associativity cannot be changed. \comindex{CoFixpoint {\ldots} where {\ldots}} \comindex{Inductive {\ldots} where {\ldots}}} -Thanks to reserved notations, the inductive, coinductive, recursive +Thanks to reserved notations, the inductive, co-inductive, recursive and corecursive definitions can benefit of customized notations. To do this, insert a {\tt where} notation clause after the definition of the (co)inductive type or (co)recursive term (or after the definition of diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 198f8f30..b630772b 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -6,15 +6,15 @@ A deduction rule is a link between some (unique) formula, that we call the {\em conclusion} and (several) formulas that we call the {\em -premises}. Indeed, a deduction rule can be read in two ways. The first -one has the shape: {\it ``if I know this and this then I can deduce +premises}. A deduction rule can be read in two ways. The first +one says: {\it ``if I know this and this then I can deduce this''}. For instance, if I have a proof of $A$ and a proof of $B$ then I have a proof of $A \land B$. This is forward reasoning from premises to conclusion. The other way says: {\it ``to prove this I have to prove this and this''}. For instance, to prove $A \land B$, I have to prove $A$ and I have to prove $B$. This is backward reasoning -which proceeds from conclusion to premises. We say that the conclusion -is {\em the goal}\index{goal} to prove and premises are {\em the +from conclusion to premises. We say that the conclusion +is the {\em goal}\index{goal} to prove and premises are the {\em subgoals}\index{subgoal}. The tactics implement {\em backward reasoning}. When applied to a goal, a tactic replaces this goal with the subgoals it generates. We say that a tactic reduces a goal to its @@ -25,29 +25,23 @@ Each (sub)goal is denoted with a number. The current goal is numbered address a particular goal in the list by writing {\sl n:\tac} which means {\it ``apply tactic {\tac} to goal number {\sl n}''}. We can show the list of subgoals by typing {\tt Show} (see -Section~\ref{Show}). +Section~\ref{Show}). Since not every rule applies to a given statement, every tactic cannot be used to reduce any goal. In other words, before applying a tactic to a given goal, the system checks that some {\em preconditions} are satisfied. If it is not the case, the tactic raises an error message. -Tactics are build from atomic tactics and tactic expressions (which +Tactics are built from atomic tactics and tactic expressions (which extends the folklore notion of tactical) to combine those atomic tactics. This chapter is devoted to atomic tactics. The tactic language will be described in Chapter~\ref{TacticLanguage}. -There are, at least, three levels of atomic tactics. The simplest one -implements basic rules of the logical framework. The second level is -the one of {\em derived rules} which are built by combination of other -tactics. The third one implements heuristics or decision procedures to -build a complete proof of a goal. - \section{Invocation of tactics \label{tactic-syntax} \index{tactic@{\tac}}} -A tactic is applied as an ordinary command. If the tactic does not +A tactic is applied as an ordinary command. If the tactic is not meant to address the first subgoal, the command may be preceded by the wished subgoal number as shown below: @@ -56,11 +50,107 @@ subgoal number as shown below: & $|$ & {\tac} {\tt .} \end{tabular} -\section{Explicit proof as a term} +\subsection{Bindings list +\index{Binding list} +\label{Binding-list}} + +Tactics that take a term as argument may also support a bindings list, so +as to instantiate some parameters of the term by name or position. +The general form of a term equipped with a bindings list is {\tt +{\term} with {\bindinglist}} where {\bindinglist} may be of two +different forms: + +\begin{itemize} +\item In a bindings list of the form {\tt (\vref$_1$ := \term$_1$) + \dots\ (\vref$_n$ := \term$_n$)}, {\vref} is either an {\ident} or a + {\num}. The references are determined according to the type of + {\term}. If \vref$_i$ is an identifier, this identifier has to be + bound in the type of {\term} and the binding provides the tactic + with an instance for the parameter of this name. If \vref$_i$ is + some number $n$, this number denotes the $n$-th non dependent + premise of the {\term}, as determined by the type of {\term}. + + \ErrMsg \errindex{No such binder} + +\item A bindings list can also be a simple list of terms {\tt + \term$_1$ \dots\ \term$_n$}. In that case the references to + which these terms correspond are determined by the tactic. In case + of {\tt induction}, {\tt destruct}, {\tt elim} and {\tt case} (see + Section~\ref{elim}) the terms have to provide instances for all the + dependent products in the type of \term\ while in the case of {\tt + apply}, or of {\tt constructor} and its variants, only instances for + the dependent products that are not bound in the conclusion of the + type are required. + + \ErrMsg \errindex{Not the right number of missing arguments} +\end{itemize} + +\subsection{Occurrences sets and occurrences clauses} +\label{Occurrences clauses} +\index{Occurrences clauses} + +An occurrences clause is a modifier to some tactics that obeys the +following syntax: + +\begin{tabular}{lcl} +{\occclause} & ::= & {\tt in} {\occgoalset} \\ +{\occgoalset} & ::= & + \zeroone{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ +& & {\dots} {\tt ,}\\ +& & {\ident$_m$} \zeroone{\atoccurrences}}\\ +& & \zeroone{{\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}}\\ +& | & + {\tt *} {\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}\\ +& | & + {\tt *}\\ +{\atoccurrences} & ::= & {\tt at} {\occlist}\\ +{\occlist} & ::= & \zeroone{{\tt -}} {\num$_1$} \dots\ {\num$_n$} +\end{tabular} + +The role of an occurrence clause is to select a set of occurrences of +a {\term} in a goal. In the first case, the {{\ident$_i$} +\zeroone{{\tt at} {\num$_1^i$} \dots\ {\num$_{n_i}^i$}}} parts +indicate that occurrences have to be selected in the hypotheses named +{\ident$_i$}. If no numbers are given for hypothesis {\ident$_i$}, +then all the occurrences of {\term} in the hypothesis are selected. If +numbers are given, they refer to occurrences of {\term} when the term +is printed using option {\tt Set Printing All} (see +Section~\ref{SetPrintingAll}), counting from left to right. In +particular, occurrences of {\term} in implicit arguments (see +Section~\ref{Implicit Arguments}) or coercions (see +Section~\ref{Coercions}) are counted. + +If a minus sign is given between {\tt at} and the list of occurrences, +it negates the condition so that the clause denotes all the occurrences except +the ones explicitly mentioned after the minus sign. + +As an exception to the left-to-right order, the occurrences in the +{\tt return} subexpression of a {\tt match} are considered {\em +before} the occurrences in the matched term. + +In the second case, the {\tt *} on the left of {\tt |-} means that +all occurrences of {\term} are selected in every hypothesis. + +In the first and second case, if {\tt *} is mentioned on the right of +{\tt |-}, the occurrences of the conclusion of the goal have to be +selected. If some numbers are given, then only the occurrences denoted +by these numbers are selected. In no numbers are given, all +occurrences of {\term} in the goal are selected. + +Finally, the last notation is an abbreviation for {\tt * |- *}. Note +also that {\tt |-} is optional in the first case when no {\tt *} is +given. + +Here are some tactics that understand occurrences clauses: +{\tt set}, {\tt remember}, {\tt induction}, {\tt destruct}. + +\SeeAlso~Sections~\ref{tactic:set}, \ref{Tac-induction}, \ref{SetPrintingAll}. + +\section{Applying theorems} -\subsection{\tt exact \term +\subsection{\tt exact \term} \tacindex{exact} -\label{exact}} +\label{exact} This tactic applies to any goal. It gives directly the exact proof term of the goal. Let {\T} be our goal, let {\tt p} be a term of type @@ -72,48 +162,17 @@ convertible (see Section~\ref{conv-rules}). \end{ErrMsgs} \begin{Variants} - \item \texttt{eexact \term}\tacindex{eexact} - - This tactic behaves like \texttt{exact} but is able to handle terms with meta-variables. - -\end{Variants} + \item \texttt{eexact \term}\tacindex{eexact} + This tactic behaves like \texttt{exact} but is able to handle terms + and goals with meta-variables. -\subsection{\tt refine \term -\tacindex{refine} -\label{refine} -\index{?@{\texttt{?}}}} - -This tactic allows to give an exact proof but still with some -holes. The holes are noted ``\texttt{\_}''. - -\begin{ErrMsgs} -\item \errindex{invalid argument}: - the tactic \texttt{refine} doesn't know what to do - with the term you gave. -\item \texttt{Refine passed ill-formed term}: the term you gave is not - a valid proof (not easy to debug in general). - This message may also occur in higher-level tactics, which call - \texttt{refine} internally. -\item \errindex{Cannot infer a term for this placeholder} - there is a hole in the term you gave - which type cannot be inferred. Put a cast around it. -\end{ErrMsgs} - -An example of use is given in Section~\ref{refine-example}. - -\section{Basics -\index{Typing rules}} - -Tactics presented in this section implement the basic typing rules of -{\CIC} given in Chapter~\ref{Cic}. +\end{Variants} -\subsection{{\tt assumption} -\tacindex{assumption}} +\subsection{\tt assumption} +\tacindex{assumption} -This tactic applies to any goal. It implements the -``Var''\index{Typing rules!Var} rule given in -Section~\ref{Typed-terms}. It looks in the local context for an +This tactic looks in the local context for an hypothesis which type is equal to the goal. If it is the case, the subgoal is proved. Otherwise, it fails. @@ -130,134 +189,470 @@ subgoal is proved. Otherwise, it fails. \end{Variants} +\subsection{\tt refine \term} +\tacindex{refine} +\label{refine} +\label{refine-example} +\index{?@{\texttt{?}}} -\subsection{\tt clear {\ident} -\tacindex{clear} -\label{clear}} - -This tactic erases the hypothesis named {\ident} in the local context -of the current goal. Then {\ident} is no more displayed and no more -usable in the proof development. +This tactic applies to any goal. It behaves like {\tt exact} with a big +difference: the user can leave some holes (denoted by \texttt{\_} or +{\tt (\_:\type)}) in the term. {\tt refine} will generate as +many subgoals as there are holes in the term. The type of holes must be +either synthesized by the system or declared by an +explicit cast like \verb|(_:nat->Prop)|. This low-level +tactic can be useful to advanced users. -\begin{Variants} +\Example -\item {\tt clear {\ident$_1$} {\ldots} {\ident$_n$}} - - This is equivalent to {\tt clear {\ident$_1$}. {\ldots} clear - {\ident$_n$}.} - -\item {\tt clearbody {\ident}}\tacindex{clearbody} +\begin{coq_example*} +Inductive Option : Set := + | Fail : Option + | Ok : bool -> Option. +\end{coq_example} +\begin{coq_example} +Definition get : forall x:Option, x <> Fail -> bool. +refine + (fun x:Option => + match x return x <> Fail -> bool with + | Fail => _ + | Ok b => fun _ => b + end). +intros; absurd (Fail = Fail); trivial. +\end{coq_example} +\begin{coq_example*} +Defined. +\end{coq_example*} - This tactic expects {\ident} to be a local definition then clears - its body. Otherwise said, this tactic turns a definition into an - assumption. +\begin{ErrMsgs} +\item \errindex{invalid argument}: + the tactic \texttt{refine} does not know what to do + with the term you gave. +\item \texttt{Refine passed ill-formed term}: the term you gave is not + a valid proof (not easy to debug in general). + This message may also occur in higher-level tactics that call + \texttt{refine} internally. +\item \errindex{Cannot infer a term for this placeholder}: + there is a hole in the term you gave + which type cannot be inferred. Put a cast around it. +\end{ErrMsgs} -\item \texttt{clear - {\ident$_1$} {\ldots} {\ident$_n$}} +\subsection{\tt apply \term} +\tacindex{apply} +\label{apply} - This tactic clears all hypotheses except the ones depending in - the hypotheses named {\ident$_1$} {\ldots} {\ident$_n$} and in the - goal. +This tactic applies to any goal. The argument {\term} is a term +well-formed in the local context. The tactic {\tt apply} tries to +match the current goal against the conclusion of the type of {\term}. +If it succeeds, then the tactic returns as many subgoals as the number +of non-dependent premises of the type of {\term}. If the conclusion of +the type of {\term} does not match the goal {\em and} the conclusion +is an inductive type isomorphic to a tuple type, then each component +of the tuple is recursively matched to the goal in the left-to-right +order. -\item \texttt{clear} +The tactic {\tt apply} relies on first-order unification with +dependent types unless the conclusion of the type of {\term} is of the +form {\tt ($P$ $t_1$ \dots\ $t_n$)} with $P$ to be instantiated. In +the latter case, the behavior depends on the form of the goal. If the +goal is of the form {\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$} and the +$t_i$ and $u_i$ unifies, then $P$ is taken to be {\tt (fun $x$ => $Q$)}. +Otherwise, {\tt apply} tries to define $P$ by abstracting over +$t_1$~\ldots ~$t_n$ in the goal. See {\tt pattern} in +Section~\ref{pattern} to transform the goal so that it gets the form +{\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$}. - This tactic clears all hypotheses except the ones depending in - goal. +\begin{ErrMsgs} +\item \errindex{Impossible to unify \dots\ with \dots} -\item {\tt clear dependent \ident \tacindex{clear dependent}} + The {\tt apply} + tactic failed to match the conclusion of {\term} and the current goal. + You can help the {\tt apply} tactic by transforming your + goal with the {\tt change} or {\tt pattern} tactics (see + sections~\ref{pattern},~\ref{change}). - This clears the hypothesis \ident\ and all hypotheses - which depend on it. +\item \errindex{Unable to find an instance for the variables +{\ident} \dots\ {\ident}} -\end{Variants} + This occurs when some instantiations of the premises of {\term} are not + deducible from the unification. This is the case, for instance, when + you want to apply a transitivity property. In this case, you have to + use one of the variants below: -\begin{ErrMsgs} -\item \errindex{{\ident} not found} -\item \errindexbis{{\ident} is used in the conclusion}{is used in the - conclusion} -\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is - used in the hypothesis} \end{ErrMsgs} -\subsection{\tt move {\ident$_1$} after {\ident$_2$} -\tacindex{move} -\label{move}} +\begin{Variants} -This moves the hypothesis named {\ident$_1$} in the local context -after the hypothesis named {\ident$_2$}. +\item{\tt apply {\term} with {\term$_1$} \dots\ {\term$_n$}} + \tacindex{apply \dots\ with} -If {\ident$_1$} comes before {\ident$_2$} in the order of dependences, -then all hypotheses between {\ident$_1$} and {\ident$_2$} which -(possibly indirectly) depend on {\ident$_1$} are moved also. + Provides {\tt apply} with explicit instantiations for all dependent + premises of the type of {\term} which do not occur in the conclusion + and consequently cannot be found by unification. Notice that + {\term$_1$} \dots\ {\term$_n$} must be given according to the order + of these dependent premises of the type of {\term}. -If {\ident$_1$} comes after {\ident$_2$} in the order of dependences, -then all hypotheses between {\ident$_1$} and {\ident$_2$} which -(possibly indirectly) occur in {\ident$_1$} are moved also. + \ErrMsg \errindex{Not the right number of missing arguments} -\begin{Variants} +\item{\tt apply {\term} with ({\vref$_1$} := {\term$_1$}) \dots\ ({\vref$_n$} + := {\term$_n$})} -\item {\tt move {\ident$_1$} before {\ident$_2$}} + This also provides {\tt apply} with values for instantiating + premises. Here, variables are referred by names and non-dependent + products by increasing numbers (see syntax in Section~\ref{Binding-list}). -This moves {\ident$_1$} towards and just before the hypothesis named {\ident$_2$}. +\item {\tt apply} {\term$_1$} {\tt ,} \ldots {\tt ,} {\term$_n$} -\item {\tt move {\ident} at top} + This is a shortcut for {\tt apply} {\term$_1$} {\tt ; [ ..~|} + \ldots~{\tt ; [ ..~| {\tt apply} {\term$_n$} ]} \ldots~{\tt ]}, i.e. for the + successive applications of {\term$_{i+1}$} on the last subgoal + generated by {\tt apply} {\term$_i$}, starting from the application + of {\term$_1$}. -This moves {\ident} at the top of the local context (at the beginning of the context). +\item {\tt eapply \term}\tacindex{eapply}\label{eapply} -\item {\tt move {\ident} at bottom} + The tactic {\tt eapply} behaves like {\tt apply} but it does not fail + when no instantiations are deducible for some variables in the + premises. Rather, it turns these variables into so-called + existential variables which are variables still to instantiate. An + existential variable is identified by a name of the form {\tt ?$n$} + where $n$ is a number. The instantiation is intended to be found + later in the proof. -This moves {\ident} at the bottom of the local context (at the end of the context). +\item {\tt simple apply {\term}} \tacindex{simple apply} -\end{Variants} + This behaves like {\tt apply} but it reasons modulo conversion only + on subterms that contain no variables to instantiate. For instance, + the following example does not succeed because it would require the + conversion of {\tt id ?1234} and {\tt O}. -\begin{ErrMsgs} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example*} +Definition id (x : nat) := x. +Hypothesis H : forall y, id y = y. +Goal O = O. +\end{coq_example*} +\begin{coq_example} +simple apply H. +\end{coq_example} -\item \errindex{{\ident$_i$} not found} + Because it reasons modulo a limited amount of conversion, {\tt + simple apply} fails quicker than {\tt apply} and it is then + well-suited for uses in used-defined tactics that backtrack often. + Moreover, it does not traverse tuples as {\tt apply} does. -\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: - it occurs in {\ident$_2$}} +\item \zeroone{{\tt simple}} {\tt apply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}}\\ + \zeroone{{\tt simple}} {\tt eapply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}} -\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: - it depends on {\ident$_2$}} + This summarizes the different syntaxes for {\tt apply} and {\tt eapply}. -\end{ErrMsgs} +\item {\tt lapply {\term}} \tacindex{lapply} -\subsection{\tt rename {\ident$_1$} into {\ident$_2$} -\tacindex{rename}} + This tactic applies to any goal, say {\tt G}. The argument {\term} + has to be well-formed in the current context, its type being + reducible to a non-dependent product {\tt A -> B} with {\tt B} + possibly containing products. Then it generates two subgoals {\tt + B->G} and {\tt A}. Applying {\tt lapply H} (where {\tt H} has type + {\tt A->B} and {\tt B} does not start with a product) does the same + as giving the sequence {\tt cut B. 2:apply H.} where {\tt cut} is + described below. -This renames hypothesis {\ident$_1$} into {\ident$_2$} in the current -context\footnote{but it does not rename the hypothesis in the - proof-term...} + \Warning When {\term} contains more than one non + dependent product the tactic {\tt lapply} only takes into account the + first product. -\begin{Variants} +\end{Variants} -\item {\tt rename {\ident$_1$} into {\ident$_2$}, \ldots, - {\ident$_{2k-1}$} into {\ident$_{2k}$}} +\Example +Assume we have a transitive relation {\tt R} on {\tt nat}: +\label{eapply-example} - Is equivalent to the sequence of the corresponding atomic {\tt rename}. +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example*} +Variable R : nat -> nat -> Prop. +Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. +Variables n m p : nat. +Hypothesis Rnm : R n m. +Hypothesis Rmp : R m p. +\end{coq_example*} -\end{Variants} +Consider the goal {\tt (R n p)} provable using the transitivity of +{\tt R}: + +\begin{coq_example*} +Goal R n p. +\end{coq_example*} + +The direct application of {\tt Rtrans} with {\tt apply} fails because +no value for {\tt y} in {\tt Rtrans} is found by {\tt apply}: + +%\begin{coq_eval} +%Set Printing Depth 50. +%(********** The following is not correct and should produce **********) +%(**** Error: generated subgoal (R n ?17) has metavariables in it *****) +%\end{coq_eval} +\begin{coq_example} +apply Rtrans. +\end{coq_example} + +A solution is to apply {\tt (Rtrans n m p)} or {\tt (Rtrans n m)}. + +\begin{coq_example} +apply (Rtrans n m p). +\end{coq_example} + +\begin{coq_eval} +Undo. +\end{coq_eval} + +Note that {\tt n} can be inferred from the goal, so the following would +work too. + +\begin{coq_example*} +apply (Rtrans _ m). +\end{coq_example*} +\begin{coq_eval} +Undo. +\end{coq_eval} + +More elegantly, {\tt apply Rtrans with (y:=m)} allows to only mention +the unknown {\tt m}: + +\begin{coq_example*} +apply Rtrans with (y := m). +\end{coq_example*} +\begin{coq_eval} +Undo. +\end{coq_eval} + +Another solution is to mention the proof of {\tt (R x y)} in {\tt +Rtrans} \ldots + +\begin{coq_example} +apply Rtrans with (1 := Rnm). +\end{coq_example} +\begin{coq_eval} +Undo. +\end{coq_eval} + +\ldots or the proof of {\tt (R y z)}. + +\begin{coq_example} +apply Rtrans with (2 := Rmp). +\end{coq_example} +\begin{coq_eval} +Undo. +\end{coq_eval} + +On the opposite, one can use {\tt eapply} which postpone the problem +of finding {\tt m}. Then one can apply the hypotheses {\tt Rnm} and {\tt +Rmp}. This instantiates the existential variable and completes the proof. + +\begin{coq_example} +eapply Rtrans. +apply Rnm. +apply Rmp. +\end{coq_example} + +\begin{coq_eval} +Reset R. +\end{coq_eval} + +\subsection{\tt apply {\term} in {\ident}} +\tacindex{apply \dots\ in} + +This tactic applies to any goal. The argument {\term} is a term +well-formed in the local context and the argument {\ident} is an +hypothesis of the context. The tactic {\tt apply {\term} in {\ident}} +tries to match the conclusion of the type of {\ident} against a +non-dependent premise of the type of {\term}, trying them from right to +left. If it succeeds, the statement of hypothesis {\ident} is +replaced by the conclusion of the type of {\term}. The tactic also +returns as many subgoals as the number of other non-dependent premises +in the type of {\term} and of the non-dependent premises of the type +of {\ident}. If the conclusion of the type of {\term} does not match +the goal {\em and} the conclusion is an inductive type isomorphic to a +tuple type, then the tuple is (recursively) decomposed and the first +component of the tuple of which a non-dependent premise matches the +conclusion of the type of {\ident}. Tuples are decomposed in a +width-first left-to-right order (for instance if the type of {\tt H1} +is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A= +then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt + B}). The tactic {\tt apply} relies on first-order pattern-matching +with dependent types. \begin{ErrMsgs} +\item \errindex{Statement without assumptions} -\item \errindex{{\ident$_1$} not found} +This happens if the type of {\term} has no non dependent premise. -\item \errindexbis{{\ident$_2$} is already used}{is already used} +\item \errindex{Unable to apply} + +This happens if the conclusion of {\ident} does not match any of the +non dependent premises of the type of {\term}. +\end{ErrMsgs} + +\begin{Variants} +\item {\tt apply \nelist{\term}{,} in {\ident}} + +This applies each of {\term} in sequence in {\ident}. + +\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} + +This does the same but uses the bindings in each {\bindinglist} to +instantiate the parameters of the corresponding type of {\term} +(see syntax of bindings in Section~\ref{Binding-list}). + +\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} +\tacindex{eapply \dots\ in} + +This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in +{\ident}} but turns unresolved bindings into existential variables, if +any, instead of failing. + +\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} + +This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in +{\ident}} then destructs the hypothesis {\ident} along +{\disjconjintropattern} as {\tt destruct {\ident} as +{\disjconjintropattern}} would. + +\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} + +This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}. + +\item {\tt simple apply {\term} in {\ident}} +\tacindex{simple apply \dots\ in} +\tacindex{simple eapply \dots\ in} + +This behaves like {\tt apply {\term} in {\ident}} but it reasons +modulo conversion only on subterms that contain no variables to +instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H : + forall y, id y = y -> True} and {\tt H0 :\ O = O} then {\tt simple + apply H in H0} does not succeed because it would require the +conversion of {\tt id ?1234} and {\tt O} where {\tt ?1234} is a variable to +instantiate. Tactic {\tt simple apply {\term} in {\ident}} does not +either traverse tuples as {\tt apply {\term} in {\ident}} does. + +\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\ +{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}} + +This summarizes the different syntactic variants of {\tt apply {\term} + in {\ident}} and {\tt eapply {\term} in {\ident}}. +\end{Variants} + +\subsection{\tt constructor \num} +\label{constructor} +\tacindex{constructor} + +This tactic applies to a goal such that its conclusion is +an inductive type (say {\tt I}). The argument {\num} must be less +or equal to the numbers of constructor(s) of {\tt I}. Let {\tt ci} be +the {\tt i}-th constructor of {\tt I}, then {\tt constructor i} is +equivalent to {\tt intros; apply ci}. +\begin{ErrMsgs} +\item \errindex{Not an inductive product} +\item \errindex{Not enough constructors} \end{ErrMsgs} -\subsection{\tt intro +\begin{Variants} +\item \texttt{constructor} + + This tries \texttt{constructor 1} then \texttt{constructor 2}, + \dots\ , then \texttt{constructor} \textit{n} where \textit{n} is + the number of constructors of the head of the goal. + +\item {\tt constructor \num~with} {\bindinglist} + + Let {\tt ci} be the {\tt i}-th constructor of {\tt I}, then {\tt + constructor i with \bindinglist} is equivalent to {\tt intros; + apply ci with \bindinglist}. + + \Warning the terms in the \bindinglist\ are checked + in the context where {\tt constructor} is executed and not in the + context where {\tt apply} is executed (the introductions are not + taken into account). + +% To document? +% \item {\tt constructor {\tactic}} + +\item {\tt split}\tacindex{split} + + This applies only if {\tt I} has a single constructor. It is then + equivalent to {\tt constructor 1}. It is typically used in the case + of a conjunction $A\land B$. + + \ErrMsg \errindex{Not an inductive goal with 1 constructor} + +\item {\tt exists {\bindinglist}}\tacindex{exists} + + This applies only if {\tt I} has a single constructor. It is then + equivalent to {\tt intros; constructor 1 with \bindinglist}. It is + typically used in the case of an existential quantification $\exists + x, P(x)$. + + \ErrMsg \errindex{Not an inductive goal with 1 constructor} + +\item {\tt exists \nelist{\bindinglist}{,}} + + This iteratively applies {\tt exists {\bindinglist}}. + +\item {\tt left}\tacindex{left}\\ + {\tt right}\tacindex{right} + + These tactics apply only if {\tt I} has two constructors, for instance + in the case of a + disjunction $A\lor B$. Then, they are respectively equivalent to {\tt + constructor 1} and {\tt constructor 2}. + + \ErrMsg \errindex{Not an inductive goal with 2 constructors} + +\item {\tt left with \bindinglist}\\ + {\tt right with \bindinglist}\\ + {\tt split with \bindinglist} + + As soon as the inductive type has the right number of constructors, + these expressions are equivalent to calling {\tt + constructor $i$ with \bindinglist} for the appropriate $i$. + +\item \texttt{econstructor}\tacindex{econstructor}\\ + \texttt{eexists}\tacindex{eexists}\\ + \texttt{esplit}\tacindex{esplit}\\ + \texttt{eleft}\tacindex{eleft}\\ + \texttt{eright}\tacindex{eright} + + These tactics and their variants behave like \texttt{constructor}, + \texttt{exists}, \texttt{split}, \texttt{left}, \texttt{right} and + their variants but they introduce existential variables instead of + failing when the instantiation of a variable cannot be found (cf + \texttt{eapply} and Section~\ref{eapply-example}). + +\end{Variants} + +\section{Managing the local context} + +\subsection{\tt intro} \tacindex{intro} -\label{intro}} +\label{intro} -This tactic applies to a goal which is either a product or starts with +This tactic applies to a goal that is either a product or starts with a let binder. If the goal is a product, the tactic implements the ``Lam''\index{Typing rules!Lam} rule given in Section~\ref{Typed-terms}\footnote{Actually, only the second subgoal will be generated since the other one can be automatically checked.}. If the -goal starts with a let binder then the tactic implements a mix of the +goal starts with a let binder, then the tactic implements a mix of the ``Let''\index{Typing rules!Let} and ``Conv''\index{Typing rules!Conv}. -If the current goal is a dependent product {\tt forall $x$:$T$, $U$} (resp {\tt +If the current goal is a dependent product $\forall x:T,~U$ (resp {\tt let $x$:=$t$ in $U$}) then {\tt intro} puts {\tt $x$:$T$} (resp {\tt $x$:=$t$}) in the local context. % Obsolete (quantified names already avoid hypotheses names): @@ -265,15 +660,15 @@ let $x$:=$t$ in $U$}) then {\tt intro} puts {\tt $x$:$T$} (resp {\tt $x$:=$t$}) % {\tt x}{\it n}{\tt :T} where {\it n} is such that {\tt x}{\it n} is a %fresh name. The new subgoal is $U$. -% If the {\tt x} has been renamed {\tt x}{\it n} then it is replaced -% by {\tt x}{\it n} in {\tt U}. +% If the {\tt x} has been renamed {\tt x}{\it n} then it is replaced +% by {\tt x}{\it n} in {\tt U}. -If the goal is a non dependent product {\tt $T$ -> $U$}, then it puts +If the goal is a non-dependent product $T \to U$, then it puts in the local context either {\tt H}{\it n}{\tt :$T$} (if $T$ is of type {\tt Set} or {\tt Prop}) or {\tt X}{\it n}{\tt :$T$} (if the type of $T$ is {\tt Type}). The optional index {\it n} is such that {\tt H}{\it n} or {\tt X}{\it n} is a fresh identifier. -In both cases the new subgoal is $U$. +In both cases, the new subgoal is $U$. If the goal is neither a product nor starting with a let definition, the tactic {\tt intro} applies the tactic {\tt red} until the tactic @@ -288,12 +683,12 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic \item {\tt intros}\tacindex{intros} - Repeats {\tt intro} until it meets the head-constant. It never reduces + This repeats {\tt intro} until it meets the head-constant. It never reduces head-constants and it never fails. \item {\tt intro {\ident}} - Applies {\tt intro} but forces {\ident} to be the name of the + This applies {\tt intro} but forces {\ident} to be the name of the introduced hypothesis. \ErrMsg \errindex{name {\ident} is already used} @@ -302,28 +697,28 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic constant then the latter can still be referred to by a qualified name (see \ref{LongNames}). -\item {\tt intros \ident$_1$ \dots\ \ident$_n$} - - Is equivalent to the composed tactic {\tt intro \ident$_1$; \dots\ ; +\item {\tt intros \ident$_1$ \dots\ \ident$_n$} + + This is equivalent to the composed tactic {\tt intro \ident$_1$; \dots\ ; intro \ident$_n$}. More generally, the \texttt{intros} tactic takes a pattern as argument in order to introduce names for components of an inductive - definition or to clear introduced hypotheses; This is explained + definition or to clear introduced hypotheses. This is explained in~\ref{intros-pattern}. \item {\tt intros until {\ident}} \tacindex{intros until} - - Repeats {\tt intro} until it meets a premise of the goal having form + + This repeats {\tt intro} until it meets a premise of the goal having form {\tt (} {\ident}~{\tt :}~{\term} {\tt )} and discharges the variable named {\ident} of the current goal. \ErrMsg \errindex{No such hypothesis in current goal} - + \item {\tt intros until {\num}} \tacindex{intros until} - - Repeats {\tt intro} until the {\num}-th non-dependent product. For - instance, on the subgoal % + + This repeats {\tt intro} until the {\num}-th non-dependent product. For + instance, on the subgoal % \verb+forall x y:nat, x=y -> y=x+ the tactic \texttt{intros until 1} is equivalent to \texttt{intros x y H}, as \verb+x=y -> y=x+ is the first non-dependent product. And on the subgoal % @@ -335,7 +730,7 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic \ErrMsg \errindex{No such hypothesis in current goal} - Happens when {\num} is 0 or is greater than the number of non-dependent + This happens when {\num} is 0 or is greater than the number of non-dependent products of the goal. \item {\tt intro after \ident} \tacindex{intro after}\\ @@ -343,7 +738,7 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic {\tt intro at top} \tacindex{intro at top}\\ {\tt intro at bottom} \tacindex{intro at bottom} - Applies {\tt intro} and moves the freshly introduced hypothesis + These tactics apply {\tt intro} and move the freshly introduced hypothesis respectively after the hypothesis \ident{}, before the hypothesis \ident{}, at the top of the local context, or at the bottom of the local context. All hypotheses on which the new hypothesis depends @@ -351,337 +746,412 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic hypotheses. Note that {\tt intro at bottom} is a synonym for {\tt intro} with no argument. -\begin{ErrMsgs} -\item \errindex{No product even after head-reduction} -\item \errindex{No such hypothesis} : {\ident} -\end{ErrMsgs} + \ErrMsg \errindex{No such hypothesis} : {\ident} \item {\tt intro \ident$_1$ after \ident$_2$}\\ {\tt intro \ident$_1$ before \ident$_2$}\\ {\tt intro \ident$_1$ at top}\\ {\tt intro \ident$_1$ at bottom} - - Behaves as previously but naming the introduced hypothesis + + These tactics behave as previously but naming the introduced hypothesis \ident$_1$. It is equivalent to {\tt intro \ident$_1$} followed by the appropriate call to {\tt move}~(see Section~\ref{move}). -\begin{ErrMsgs} -\item \errindex{No product even after head-reduction} -\item \errindex{No such hypothesis} : {\ident} -\end{ErrMsgs} - \end{Variants} -\subsection{\tt apply \term -\tacindex{apply} -\label{apply}} - -This tactic applies to any goal. The argument {\term} is a term -well-formed in the local context. The tactic {\tt apply} tries to -match the current goal against the conclusion of the type of {\term}. -If it succeeds, then the tactic returns as many subgoals as the number -of non dependent premises of the type of {\term}. If the conclusion of -the type of {\term} does not match the goal {\em and} the conclusion -is an inductive type isomorphic to a tuple type, then each component -of the tuple is recursively matched to the goal in the left-to-right -order. - -The tactic {\tt apply} relies on first-order unification with -dependent types unless the conclusion of the type of {\term} is of the -form {\tt ($P$~ $t_1$~\ldots ~$t_n$)} with $P$ to be instantiated. In -the latter case, the behavior depends on the form of the goal. If the -goal is of the form {\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$} and the -$t_i$ and $u_i$ unifies, then $P$ is taken to be (fun $x$ => $Q$). -Otherwise, {\tt apply} tries to define $P$ by abstracting over -$t_1$~\ldots ~$t_n$ in the goal. See {\tt pattern} in -Section~\ref{pattern} to transform the goal so that it gets the form -{\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$}. - -\begin{ErrMsgs} -\item \errindex{Impossible to unify \dots\ with \dots} - - The {\tt apply} - tactic failed to match the conclusion of {\term} and the current goal. - You can help the {\tt apply} tactic by transforming your - goal with the {\tt change} or {\tt pattern} tactics (see - sections~\ref{pattern},~\ref{change}). - -\item \errindex{Unable to find an instance for the variables -{\ident} \ldots {\ident}} +\subsection{\tt intros {\intropattern} {\ldots} {\intropattern}} +\label{intros-pattern} +\tacindex{intros \intropattern} +\index{Introduction patterns} +\index{Naming introduction patterns} +\index{Disjunctive/conjunctive introduction patterns} - This occurs when some instantiations of the premises of {\term} are not - deducible from the unification. This is the case, for instance, when - you want to apply a transitivity property. In this case, you have to - use one of the variants below: +This extension of the tactic {\tt intros} combines introduction of +variables or hypotheses and case analysis. An {\em introduction pattern} is +either: +\begin{itemize} +\item a {\em naming introduction pattern}, i.e. either one of: + \begin{itemize} + \item the pattern \texttt{?} + \item the pattern \texttt{?\ident} + \item an identifier + \end{itemize} +\item a {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: + \begin{itemize} + \item a disjunction of lists of patterns: + {\tt [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + \item a conjunction of patterns: {\tt ($p_1$ , \dots\ , $p_n$)} + \item a list of patterns {\tt ($p_1$ \&\ \dots\ \&\ $p_n$)} + for sequence of right-associative binary constructs + \end{itemize} +\item the wildcard: {\tt \_} +\item the rewriting orientations: {\tt ->} or {\tt <-} +\end{itemize} -\end{ErrMsgs} +Assuming a goal of type $Q \to P$ (non-dependent product), or +of type $\forall x:T,~P$ (dependent product), the behavior of +{\tt intros $p$} is defined inductively over the structure of the +introduction pattern~$p$: +\begin{itemize} +\item introduction on \texttt{?} performs the introduction, and lets {\Coq} + choose a fresh name for the variable; +\item introduction on \texttt{?\ident} performs the introduction, and + lets {\Coq} choose a fresh name for the variable based on {\ident}; +\item introduction on \texttt{\ident} behaves as described in + Section~\ref{intro}; +\item introduction over a disjunction of list of patterns {\tt + [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + expects the product to be over an inductive type + whose number of constructors is $n$ (or more generally over a type + of conclusion an inductive type built from $n$ constructors, + e.g. {\tt C -> A\textbackslash/B if $n=2$}): it destructs the introduced + hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and + applies on each generated subgoal the corresponding tactic; + \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive + pattern is part of a sequence of patterns and is not the last + pattern of the sequence, then {\Coq} completes the pattern so that all + the argument of the constructors of the inductive type are + introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} + applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as + the list of patterns {\tt [$\,$|$\,$?$\,$] H}); +\item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, + $p_n$)} expects the goal to be a product over an inductive type $I$ with a + single constructor that itself has at least $n$ arguments: it + performs a case analysis over the hypothesis, as {\tt destruct} + would, and applies the patterns $p_1$~\ldots~$p_n$ to the arguments + of the constructor of $I$ (observe that {\tt ($p_1$, {\ldots}, + $p_n$)} is an alternative notation for {\tt [$p_1$ {\ldots} + $p_n$]}); +\item introduction via {\tt ($p_1$ \& \dots\ \& $p_n$)} + is a shortcut for introduction via + {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the + hypothesis to be a sequence of right-associative binary inductive + constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an + hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be + introduced via pattern {\tt (a \& x \& b \& c \& d)}; +\item introduction on the wildcard depends on whether the product is + dependent or not: in the non-dependent case, it erases the + corresponding hypothesis (i.e. it behaves as an {\tt intro} followed + by a {\tt clear}, cf Section~\ref{clear}) while in the dependent + case, it succeeds and erases the variable only if the wildcard is + part of a more complex list of introduction patterns that also + erases the hypotheses depending on this variable; +\item introduction over {\tt ->} (respectively {\tt <-}) expects the + hypothesis to be an equality and the right-hand-side (respectively + the left-hand-side) is replaced by the left-hand-side (respectively + the right-hand-side) in both the conclusion and the context of the goal; + if moreover the term to substitute is a variable, the hypothesis is + removed. +\end{itemize} -\begin{Variants} +\Example -\item{\tt apply {\term} with {\term$_1$} \dots\ {\term$_n$}} - \tacindex{apply \dots\ with} - - Provides {\tt apply} with explicit instantiations for all dependent - premises of the type of {\term} which do not occur in the conclusion - and consequently cannot be found by unification. Notice that - {\term$_1$} \dots\ {\term$_n$} must be given according to the order - of these dependent premises of the type of {\term}. +\begin{coq_example} +Goal forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. +intros A B C [a| [_ c]] f. +apply (f a). +exact c. +Qed. +\end{coq_example} - \ErrMsg \errindex{Not the right number of missing arguments} +\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros + $p_1$;\ldots; intros $p_n$} for the following reasons: +\begin{itemize} +\item A wildcard pattern never succeeds when applied isolated on a + dependent product, while it succeeds as part of a list of + introduction patterns if the hypotheses that depends on it are + erased too. +\item A disjunctive or conjunctive pattern followed by an introduction + pattern forces the introduction in the context of all arguments of + the constructors before applying the next pattern while a terminal + disjunctive or conjunctive pattern does not. Here is an example -\item{\tt apply {\term} with ({\vref$_1$} := {\term$_1$}) \dots\ ({\vref$_n$} - := {\term$_n$})} - - This also provides {\tt apply} with values for instantiating - premises. Here, variables are referred by names and non-dependent - products by increasing numbers (see syntax in Section~\ref{Binding-list}). +\begin{coq_example} +Goal forall n:nat, n = 0 -> n = 0. +intros [ | ] H. +Show 2. +Undo. +intros [ | ]; intros H. +Show 2. +\end{coq_example} -\item {\tt apply} {\term$_1$} {\tt ,} \ldots {\tt ,} {\term$_n$} +\end{itemize} - This is a shortcut for {\tt apply} {\term$_1$} {\tt ; [ ..~|} - \ldots~{\tt ; [ ..~| {\tt apply} {\term$_n$} ]} \ldots~{\tt ]}, i.e. for the - successive applications of {\term$_{i+1}$} on the last subgoal - generated by {\tt apply} {\term$_i$}, starting from the application - of {\term$_1$}. +\subsection{\tt clear \ident} +\tacindex{clear} +\label{clear} -\item {\tt eapply \term}\tacindex{eapply}\label{eapply} - - The tactic {\tt eapply} behaves as {\tt apply} but does not fail - when no instantiation are deducible for some variables in the - premises. Rather, it turns these variables into so-called - existential variables which are variables still to instantiate. An - existential variable is identified by a name of the form {\tt ?$n$} - where $n$ is a number. The instantiation is intended to be found - later in the proof. +This tactic erases the hypothesis named {\ident} in the local context +of the current goal. As a consequence, {\ident} is no more displayed and no more +usable in the proof development. - An example of use of {\tt eapply} is given in - Section~\ref{eapply-example}. +\begin{ErrMsgs} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident} is used in the conclusion}{is used in the + conclusion} +\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is + used in the hypothesis} +\end{ErrMsgs} -\item {\tt simple apply {\term}} \tacindex{simple apply} +\begin{Variants} - This behaves like {\tt apply} but it reasons modulo conversion only - on subterms that contain no variables to instantiate. For instance, - if {\tt id := fun x:nat => x} and {\tt H : forall y, id y = y} then - {\tt simple apply H} on goal {\tt O = O} does not succeed because it - would require the conversion of {\tt f ?y} and {\tt O} where {\tt - ?y} is a variable to instantiate. Tactic {\tt simple apply} does not - either traverse tuples as {\tt apply} does. +\item {\tt clear {\ident$_1$} \dots\ {\ident$_n$}} - Because it reasons modulo a limited amount of conversion, {\tt - simple apply} fails quicker than {\tt apply} and it is then - well-suited for uses in used-defined tactics that backtrack often. + This is equivalent to {\tt clear {\ident$_1$}. {\ldots} clear + {\ident$_n$}.} -\item \zeroone{{\tt simple}} {\tt apply} {\term$_1$} \zeroone{{\tt with} - {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} - {\bindinglist$_n$}}\\ - \zeroone{{\tt simple}} {\tt eapply} {\term$_1$} \zeroone{{\tt with} - {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} - {\bindinglist$_n$}} +\item {\tt clearbody {\ident}}\tacindex{clearbody} - This summarizes the different syntaxes for {\tt apply} and {\tt eapply}. + This tactic expects {\ident} to be a local definition then clears + its body. Otherwise said, this tactic turns a definition into an + assumption. -\item {\tt lapply {\term}} \tacindex{lapply} + \ErrMsg \errindexbis{{\ident} is not a local definition}{is not a local definition} - This tactic applies to any goal, say {\tt G}. The argument {\term} - has to be well-formed in the current context, its type being - reducible to a non-dependent product {\tt A -> B} with {\tt B} - possibly containing products. Then it generates two subgoals {\tt - B->G} and {\tt A}. Applying {\tt lapply H} (where {\tt H} has type - {\tt A->B} and {\tt B} does not start with a product) does the same - as giving the sequence {\tt cut B. 2:apply H.} where {\tt cut} is - described below. +\item \texttt{clear - {\ident$_1$} \dots\ {\ident$_n$}} - \Warning When {\term} contains more than one non - dependent product the tactic {\tt lapply} only takes into account the - first product. + This tactic clears all the hypotheses except the ones depending in + the hypotheses named {\ident$_1$} {\ldots} {\ident$_n$} and in the + goal. + +\item \texttt{clear} + + This tactic clears all the hypotheses except the ones the goal depends on. + +\item {\tt clear dependent \ident \tacindex{clear dependent}} + + This clears the hypothesis \ident\ and all the hypotheses + that depend on it. \end{Variants} -\subsection{{\tt apply {\term} in {\ident}} -\tacindex{apply \ldots\ in}} +\subsection{\tt revert \ident$_1$ \dots\ \ident$_n$} +\tacindex{revert} +\label{revert} -This tactic applies to any goal. The argument {\term} is a term -well-formed in the local context and the argument {\ident} is an -hypothesis of the context. The tactic {\tt apply {\term} in {\ident}} -tries to match the conclusion of the type of {\ident} against a non -dependent premise of the type of {\term}, trying them from right to -left. If it succeeds, the statement of hypothesis {\ident} is -replaced by the conclusion of the type of {\term}. The tactic also -returns as many subgoals as the number of other non dependent premises -in the type of {\term} and of the non dependent premises of the type -of {\ident}. If the conclusion of the type of {\term} does not match -the goal {\em and} the conclusion is an inductive type isomorphic to a -tuple type, then the tuple is (recursively) decomposed and the first -component of the tuple of which a non dependent premise matches the -conclusion of the type of {\ident}. Tuples are decomposed in a -width-first left-to-right order (for instance if the type of {\tt H1} -is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A= -then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt - B}). The tactic {\tt apply} relies on first-order pattern-matching -with dependent types. +This applies to any goal with variables \ident$_1$ \dots\ \ident$_n$. +It moves the hypotheses (possibly defined) to the goal, if this respects +dependencies. This tactic is the inverse of {\tt intro}. \begin{ErrMsgs} -\item \errindex{Statement without assumptions} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is + used in the hypothesis} +\end{ErrMsgs} -This happens if the type of {\term} has no non dependent premise. +\begin{Variants} +\item {\tt revert dependent \ident \tacindex{revert dependent}} -\item \errindex{Unable to apply} + This moves to the goal the hypothesis \ident\ and all hypotheses + which depend on it. -This happens if the conclusion of {\ident} does not match any of the -non dependent premises of the type of {\term}. -\end{ErrMsgs} +\end{Variants} + +\subsection{\tt move {\ident$_1$} after {\ident$_2$}} +\tacindex{move} +\label{move} + +This moves the hypothesis named {\ident$_1$} in the local context +after the hypothesis named {\ident$_2$}. The proof term is not changed. + +If {\ident$_1$} comes before {\ident$_2$} in the order of dependences, +then all hypotheses between {\ident$_1$} and {\ident$_2$} that +(possibly indirectly) depend on {\ident$_1$} are moved also. + +If {\ident$_1$} comes after {\ident$_2$} in the order of dependences, +then all hypotheses between {\ident$_1$} and {\ident$_2$} that +(possibly indirectly) occur in {\ident$_1$} are moved also. \begin{Variants} -\item {\tt apply \nelist{\term}{,} in {\ident}} -This applies each of {\term} in sequence in {\ident}. +\item {\tt move {\ident$_1$} before {\ident$_2$}} -\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} +This moves {\ident$_1$} towards and just before the hypothesis named {\ident$_2$}. -This does the same but uses the bindings in each {\bindinglist} to -instantiate the parameters of the corresponding type of {\term} -(see syntax of bindings in Section~\ref{Binding-list}). +\item {\tt move {\ident} at top} -\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} -\tacindex{eapply {\ldots} in} +This moves {\ident} at the top of the local context (at the beginning of the context). -This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in -{\ident}} but turns unresolved bindings into existential variables, if -any, instead of failing. +\item {\tt move {\ident} at bottom} -\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} +This moves {\ident} at the bottom of the local context (at the end of the context). -This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in -{\ident}} then destructs the hypothesis {\ident} along -{\disjconjintropattern} as {\tt destruct {\ident} as -{\disjconjintropattern}} would. +\end{Variants} -\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} +\begin{ErrMsgs} -This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}. +\item \errindex{No such hypothesis} -\item {\tt simple apply {\term} in {\ident}} -\tacindex{simple apply {\ldots} in} -\tacindex{simple eapply {\ldots} in} +\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: + it occurs in {\ident$_2$}} -This behaves like {\tt apply {\term} in {\ident}} but it reasons -modulo conversion only on subterms that contain no variables to -instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H : - forall y, id y = y -> True} and {\tt H0 : O = O} then {\tt simple - apply H in H0} does not succeed because it would require the -conversion of {\tt f ?y} and {\tt O} where {\tt ?y} is a variable to -instantiate. Tactic {\tt simple apply {\term} in {\ident}} does not -either traverse tuples as {\tt apply {\term} in {\ident}} does. +\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: + it depends on {\ident$_2$}} -\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\ -{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}} +\end{ErrMsgs} + +\subsection{\tt rename {\ident$_1$} into {\ident$_2$}} +\tacindex{rename} + +This renames hypothesis {\ident$_1$} into {\ident$_2$} in the current +context. The name of the hypothesis in the proof-term, however, is left +unchanged. + +\begin{Variants} + +\item {\tt rename {\ident$_1$} into {\ident$_2$}, \ldots, + {\ident$_{2k-1}$} into {\ident$_{2k}$}} + +This is equivalent to the sequence of the corresponding atomic {\tt rename}. -This summarizes the different syntactic variants of {\tt apply {\term} - in {\ident}} and {\tt eapply {\term} in {\ident}}. \end{Variants} -\subsection{{\tt set ( {\ident} {\tt :=} {\term} \tt )} +\begin{ErrMsgs} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident$_2$} is already used}{is already used} +\end{ErrMsgs} + +\subsection{\tt set ( {\ident} := {\term} )} \label{tactic:set} \tacindex{set} -\tacindex{pose} -\tacindex{remember}} -This replaces {\term} by {\ident} in the conclusion or in the -hypotheses of the current goal and adds the new definition {\ident -{\tt :=} \term} to the local context. The default is to make this -replacement only in the conclusion. +This replaces {\term} by {\ident} in the conclusion of the current goal +and adds the new definition {\tt {\ident} := \term} to the local context. If {\term} has holes (i.e. subexpressions of the form ``\_''), the tactic first checks that all subterms matching the pattern are compatible before doing the replacement using the leftmost subterm matching the pattern. +\begin{ErrMsgs} +\item \errindex{The variable {\ident} is already defined} +\end{ErrMsgs} + \begin{Variants} -\item {\tt set (} {\ident} {\tt :=} {\term} {\tt ) in {\occgoalset}} +\item {\tt set ( {\ident} := {\term} ) in {\occgoalset}} This notation allows to specify which occurrences of {\term} have to be substituted in the context. The {\tt in {\occgoalset}} clause is an -occurrence clause whose syntax and behavior is described in +occurrence clause whose syntax and behavior are described in Section~\ref{Occurrences clauses}. -\item {\tt set (} {\ident} \nelist{\binder}{} {\tt :=} {\term} {\tt )} +\item {\tt set ( {\ident} \nelist{\binder}{} := {\term} )} - This is equivalent to {\tt set (} {\ident} {\tt :=} {\tt fun} - \nelist{\binder}{} {\tt =>} {\term} {\tt )}. + This is equivalent to {\tt set ( {\ident} := fun + \nelist{\binder}{} => {\term} )}. -\item {\tt set } {\term} +\item {\tt set \term} This behaves as {\tt set (} {\ident} := {\term} {\tt )} but {\ident} is generated by {\Coq}. This variant also supports an occurrence clause. -\item {\tt set (} {\ident$_0$} \nelist{\binder}{} {\tt :=} {\term} - {\tt ) in {\occgoalset}}\\ +\item {\tt set ( {\ident$_0$} \nelist{\binder}{} := {\term} ) in {\occgoalset}}\\ {\tt set {\term} in {\occgoalset}} These are the general forms which combine the previous possibilities. -\item {\tt remember {\term} {\tt as} {\ident}} +\item {\tt remember {\term} as {\ident}}\tacindex{remember} - This behaves as {\tt set (} {\ident} := {\term} {\tt ) in *} and using a + This behaves as {\tt set ( {\ident} := {\term} ) in *} and using a logical (Leibniz's) equality instead of a local definition. -\item {\tt remember {\term} {\tt as} {\ident} in {\occgoalset}} +\item {\tt remember {\term} as {\ident} in {\occgoalset}} This is a more general form of {\tt remember} that remembers the occurrences of {\term} specified by an occurrences set. -\item {\tt pose ( {\ident} := {\term} )} - +\item {\tt pose ( {\ident} := {\term} )}\tacindex{pose} + This adds the local definition {\ident} := {\term} to the current context without performing any replacement in the goal or in the hypotheses. It is equivalent to {\tt set ( {\ident} {\tt :=} {\term} {\tt ) in |-}}. -\item {\tt pose (} {\ident} \nelist{\binder}{} {\tt :=} {\term} {\tt )} +\item {\tt pose ( {\ident} \nelist{\binder}{} := {\term} )} This is equivalent to {\tt pose (} {\ident} {\tt :=} {\tt fun} \nelist{\binder}{} {\tt =>} {\term} {\tt )}. \item{\tt pose {\term}} - This behaves as {\tt pose (} {\ident} := {\term} {\tt )} but + This behaves as {\tt pose ( {\ident} := {\term} )} but {\ident} is generated by {\Coq}. \end{Variants} -\subsection{{\tt assert ( {\ident} : {\form} \tt )} -\tacindex{assert}} - -This tactic applies to any goal. {\tt assert (H : U)} adds a new -hypothesis of name \texttt{H} asserting \texttt{U} to the current goal -and opens a new subgoal \texttt{U}\footnote{This corresponds to the - cut rule of sequent calculus.}. The subgoal {\texttt U} comes first -in the list of subgoals remaining to prove. - -\begin{ErrMsgs} -\item \errindex{Not a proposition or a type} - - Arises when the argument {\form} is neither of type {\tt Prop}, {\tt - Set} nor {\tt Type}. +\subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term} +\label{decompose} +\tacindex{decompose} -\end{ErrMsgs} +This tactic allows to recursively decompose a +complex proposition in order to obtain atomic ones. -\begin{Variants} +\Example + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Goal forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C. +intros A B C H; decompose [and or] H; assumption. +\end{coq_example} +\begin{coq_example*} +Qed. +\end{coq_example*} + +{\tt decompose} does not work on right-hand sides of implications or products. + +\begin{Variants} + +\item {\tt decompose sum \term}\tacindex{decompose sum} + + This decomposes sum types (like \texttt{or}). + +\item {\tt decompose record \term}\tacindex{decompose record} + + This decomposes record types (inductive types with one constructor, + like \texttt{and} and \texttt{exists} and those defined with the + \texttt{Record} macro, see Section~\ref{Record}). + +\end{Variants} + +\section{Controlling the proof flow} + +\subsection{\tt assert ( {\ident} :\ {\form} )} +\tacindex{assert} + +This tactic applies to any goal. {\tt assert (H : U)} adds a new +hypothesis of name \texttt{H} asserting \texttt{U} to the current goal +and opens a new subgoal \texttt{U}\footnote{This corresponds to the + cut rule of sequent calculus.}. The subgoal {\texttt U} comes first +in the list of subgoals remaining to prove. + +\begin{ErrMsgs} +\item \errindex{Not a proposition or a type} + + Arises when the argument {\form} is neither of type {\tt Prop}, {\tt + Set} nor {\tt Type}. + +\end{ErrMsgs} + +\begin{Variants} \item{\tt assert {\form}} - - This behaves as {\tt assert (} {\ident} : {\form} {\tt )} but + + This behaves as {\tt assert ( {\ident} :\ {\form} )} but {\ident} is generated by {\Coq}. -\item{\tt assert (} {\ident} := {\term} {\tt )} - - This behaves as {\tt assert ({\ident} : {\type});[exact +\item{\tt assert ( {\ident} := {\term} )} + + This behaves as {\tt assert ({\ident} :\ {\type});[exact {\term}|idtac]} where {\type} is the type of {\term}. -\item {\tt cut {\form}}\tacindex{cut} - - This tactic applies to any goal. It implements the non dependent + \ErrMsg \errindex{Variable {\ident} is already declared} + +\item {\tt cut {\form}}\tacindex{cut} + + This tactic applies to any goal. It implements the non-dependent case of the ``App''\index{Typing rules!App} rule given in Section~\ref{Typed-terms}. (This is Modus Ponens inference rule.) {\tt cut U} transforms the current goal \texttt{T} into the two @@ -689,16 +1159,18 @@ in the list of subgoals remaining to prove. -> T} comes first in the list of remaining subgoal to prove. \item \texttt{assert {\form} by {\tac}}\tacindex{assert by} - + This tactic behaves like \texttt{assert} but applies {\tac} to solve the subgoals generated by \texttt{assert}. + \ErrMsg \errindex{Proof is not complete} + \item \texttt{assert {\form} as {\intropattern}\tacindex{assert as}} If {\intropattern} is a naming introduction pattern (see Section~\ref{intros-pattern}), the hypothesis is named after this introduction pattern (in particular, if {\intropattern} is {\ident}, - the tactic behaves like \texttt{assert ({\ident} : {\form})}). + the tactic behaves like \texttt{assert ({\ident} :\ {\form})}). If {\intropattern} is a disjunctive/conjunctive introduction pattern, the tactic behaves like \texttt{assert {\form}} then destructing the @@ -714,12 +1186,11 @@ in the list of subgoals remaining to prove. exact {\term}} where \texttt{T} is the type of {\term}. In particular, \texttt{pose proof {\term} as {\ident}} behaves as - \texttt{assert ({\ident}:T) by exact {\term}} (where \texttt{T} is - the type of {\term}) and \texttt{pose proof {\term} as + \texttt{assert ({\ident} := {\term})} and \texttt{pose proof {\term} as {\disjconjintropattern}\tacindex{pose proof}} behaves like \texttt{destruct {\term} as {\disjconjintropattern}}. -\item {\tt specialize ({\ident} \term$_1$ {\ldots} \term$_n$)\tacindex{specialize}} \\ +\item {\tt specialize ({\ident} \term$_1$ \dots\ \term$_n$)\tacindex{specialize}} \\ {\tt specialize {\ident} with \bindinglist} The tactic {\tt specialize} works on local hypothesis \ident. @@ -730,30 +1201,37 @@ in the list of subgoals remaining to prove. Section~\ref{Binding-list} for more about bindings lists). In the second form, all instantiation elements must be given, whereas in the first form the application to \term$_1$ {\ldots} - \term$_n$ can be partial. The first form is equivalent to - {\tt assert (\ident':=\ident \term$_1$ {\ldots} \term$_n$); - clear \ident; rename \ident' into \ident}. + \term$_n$ can be partial. The first form is equivalent to + {\tt assert (\ident' := {\ident} {\term$_1$} \dots\ \term$_n$); + clear \ident; rename \ident' into \ident}. The name {\ident} can also refer to a global lemma or hypothesis. In this case, for compatibility reasons, the behavior of {\tt specialize} is close to that of {\tt - generalize}: the instantiated statement becomes an additional - premise of the goal. + generalize}: the instantiated statement becomes an additional + premise of the goal. + + \begin{ErrMsgs} + \item \errindexbis{{\ident} is used in hypothesis \ident'}{is used in hypothesis} + \item \errindexbis{{\ident} is used in conclusion}{is used in conclusion} + \end{ErrMsgs} -%% Moreover, the old syntax allows the use of a number after {\tt specialize} -%% for controlling the number of premises to instantiate. Giving this +%% Moreover, the old syntax allows the use of a number after {\tt specialize} +%% for controlling the number of premises to instantiate. Giving this %% number should not be mandatory anymore (automatic detection of how -%% many premises can be eaten without leaving meta-variables). Hence +%% many premises can be eaten without leaving meta-variables). Hence %% no documentation for this integer optional argument of specialize \end{Variants} -\subsection{\tt generalize \term +\subsection{\tt generalize \term} \tacindex{generalize} -\label{generalize}} +\label{generalize} + +This tactic applies to any goal. It generalizes the conclusion with +respect to one of its subterms. -This tactic applies to any goal. It generalizes the conclusion w.r.t. -one subterm of it. For example: +\Example \begin{coq_eval} Goal forall x y:nat, (0 <= x + y + y). @@ -775,185 +1253,49 @@ where $G'$ is obtained from $G$ by replacing all occurrences of $t$ by \begin{Variants} \item {\tt generalize {\term$_1$ , \dots\ , \term$_n$}} - - Is equivalent to {\tt generalize \term$_n$; \dots\ ; generalize + + This is equivalent to {\tt generalize \term$_n$; \dots\ ; generalize \term$_1$}. Note that the sequence of \term$_i$'s are processed from $n$ to $1$. \item {\tt generalize {\term} at {\num$_1$ \dots\ \num$_i$}} - - Is equivalent to {\tt generalize \term} but generalizing only over + + This is equivalent to {\tt generalize \term} but it generalizes only over the specified occurrences of {\term} (counting from left to right on the expression printed using option {\tt Set Printing All}). \item {\tt generalize {\term} as {\ident}} - - Is equivalent to {\tt generalize \term} but use {\ident} to name the + + This is equivalent to {\tt generalize \term} but it uses {\ident} to name the generalized hypothesis. -\item {\tt generalize {\term$_1$} at {\num$_{11}$ \dots\ \num$_{1i_1}$} +\item {\tt generalize {\term$_1$} at {\num$_{11}$ \dots\ \num$_{1i_1}$} as {\ident$_1$} , {\ldots} , {\term$_n$} at {\num$_{n1}$ \dots\ \num$_{ni_n}$} as {\ident$_2$}} - + This is the most general form of {\tt generalize} that combines the previous behaviors. - -\item {\tt generalize dependent \term} \tacindex{generalize dependent} - - This generalizes {\term} but also {\em all} hypotheses which depend - on {\term}. It clears the generalized hypotheses. - -\end{Variants} - - -\subsection{\tt revert \ident$_1$ \dots\ \ident$_n$ -\tacindex{revert} -\label{revert}} - -This applies to any goal with variables \ident$_1$ \dots\ \ident$_n$. -It moves the hypotheses (possibly defined) to the goal, if this respects -dependencies. This tactic is the inverse of {\tt intro}. - -\begin{ErrMsgs} -\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is - used in the hypothesis} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt revert dependent \ident \tacindex{revert dependent}} - - This moves to the goal the hypothesis \ident\ and all hypotheses - which depend on it. - -\end{Variants} - -\subsection{\tt change \term -\tacindex{change} -\label{change}} - -This tactic applies to any goal. It implements the rule -``Conv''\index{Typing rules!Conv} given in Section~\ref{Conv}. {\tt - change U} replaces the current goal \T\ with \U\ providing that -\U\ is well-formed and that \T\ and \U\ are convertible. - -\begin{ErrMsgs} -\item \errindex{Not convertible} -\end{ErrMsgs} - -\tacindex{change \dots\ in} -\begin{Variants} -\item {\tt change \term$_1$ with \term$_2$} - - This replaces the occurrences of \term$_1$ by \term$_2$ in the - current goal. The terms \term$_1$ and \term$_2$ must be - convertible. - -\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$} - - This replaces the occurrences numbered \num$_1$ \dots\ \num$_i$ of - \term$_1$ by \term$_2$ in the current goal. - The terms \term$_1$ and \term$_2$ must be convertible. - - \ErrMsg {\tt Too few occurrences} - -\item {\tt change {\term} in {\ident}} - -\item {\tt change \term$_1$ with \term$_2$ in {\ident}} - -\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$ in - {\ident}} - - This applies the {\tt change} tactic not to the goal but to the - hypothesis {\ident}. - -\end{Variants} - -\SeeAlso \ref{Conversion-tactics} - -\subsection{\tt fix {\ident} {\num} -\tacindex{fix} -\label{tactic:fix}} - -This tactic is a primitive tactic to start a proof by induction. In -general, it is easier to rely on higher-level induction tactics such -as the ones described in Section~\ref{Tac-induction}. - -In the syntax of the tactic, the identifier {\ident} is the name given -to the induction hypothesis. The natural number {\num} tells on which -premise of the current goal the induction acts, starting -from 1 and counting both dependent and non dependent -products. Especially, the current lemma must be composed of at least -{\num} products. - -Like in a {\tt fix} expression, the induction -hypotheses have to be used on structurally smaller arguments. -The verification that inductive proof arguments are correct is done -only at the time of registering the lemma in the environment. To know -if the use of induction hypotheses is correct at some -time of the interactive development of a proof, use the command {\tt - Guarded} (see Section~\ref{Guarded}). - -\begin{Variants} - \item {\tt fix} {\ident}$_1$ {\num} {\tt with (} {\ident}$_2$ - \nelist{{\binder}$_{2}$}{} \zeroone{{\tt \{ struct {\ident$'_2$} - \}}} {\tt :} {\type}$_2$ {\tt )} {\ldots} {\tt (} {\ident}$_1$ - \nelist{{\binder}$_n$}{} \zeroone{{\tt \{ struct {\ident$'_n$} \}}} - {\tt :} {\type}$_n$ {\tt )} - -This starts a proof by mutual induction. The statements to be -simultaneously proved are respectively {\tt forall} - \nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} - \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers -{\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the induction -hypotheses. The identifiers {\ident}$'_2$ {\ldots} {\ident}$'_n$ are the -respective names of the premises on which the induction is performed -in the statements to be simultaneously proved (if not given, the -system tries to guess itself what they are). - -\end{Variants} - -\subsection{\tt cofix {\ident} -\tacindex{cofix} -\label{tactic:cofix}} - -This tactic starts a proof by coinduction. The identifier {\ident} is -the name given to the coinduction hypothesis. Like in a {\tt cofix} -expression, the use of induction hypotheses have to guarded by a -constructor. The verification that the use of coinductive hypotheses -is correct is done only at the time of registering the lemma in the -environment. To know if the use of coinduction hypotheses is correct -at some time of the interactive development of a proof, use the -command {\tt Guarded} (see Section~\ref{Guarded}). - -\begin{Variants} - \item {\tt cofix} {\ident}$_1$ {\tt with (} {\ident}$_2$ - \nelist{{\binder}$_2$}{} {\tt :} {\type}$_2$ {\tt )} {\ldots} {\tt - (} {\ident}$_1$ \nelist{{\binder}$_1$}{} {\tt :} {\type}$_n$ - {\tt )} +\item {\tt generalize dependent \term} \tacindex{generalize dependent} -This starts a proof by mutual coinduction. The statements to be -simultaneously proved are respectively {\tt forall} -\nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} - \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers - {\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the - coinduction hypotheses. + This generalizes {\term} but also {\em all} hypotheses that depend + on {\term}. It clears the generalized hypotheses. \end{Variants} -\subsection{\tt evar (\ident:\term) +\subsection{\tt evar ( {\ident} :\ {\term} )} \tacindex{evar} -\label{evar}} +\label{evar} The {\tt evar} tactic creates a new local definition named \ident\ with type \term\ in the context. The body of this binding is a fresh existential variable. -\subsection{\tt instantiate (\num:= \term) +\subsection{\tt instantiate ( {\num} := {\term} )} \tacindex{instantiate} -\label{instantiate}} +\label{instantiate} The {\tt instantiate} tactic allows to refine (see Section~\ref{refine}) an existential variable @@ -963,14 +1305,14 @@ the number of the existential variable since this number is different in every session. \begin{Variants} - \item {\tt instantiate (\num:=\term) in \ident} - - \item {\tt instantiate (\num:=\term) in (Value of \ident)} - - \item {\tt instantiate (\num:=\term) in (Type of \ident)} + \item {\tt instantiate ( {\num} := {\term} ) in \ident} + + \item {\tt instantiate ( {\num} := {\term} ) in ( Value of {\ident} )} -These allow to refer respectively to existential variables occurring in -a hypothesis or in the body or the type of a local definition. + \item {\tt instantiate ( {\num} := {\term} ) in ( Type of {\ident} )} + +These allow to refer respectively to existential variables occurring in +a hypothesis or in the body or the type of a local definition. \item {\tt instantiate} @@ -983,9 +1325,9 @@ a hypothesis or in the body or the type of a local definition. \end{Variants} -\subsection{\tt admit +\subsection{\tt admit} \tacindex{admit} -\label{admit}} +\label{admit} The {\tt admit} tactic ``solves'' the current subgoal by an axiom. This typically allows to temporarily skip a subgoal so as to @@ -995,1422 +1337,1165 @@ Assumptions} (see Section~\ref{PrintAssumptions}). Admitted subgoals have names of the form {\ident}\texttt{\_admitted} possibly followed by a number. -\subsection{\tt constr\_eq \term$_1$ \term$_2$ -\tacindex{constr\_eq} -\label{constreq}} +\subsection{\tt absurd \term} +\tacindex{absurd} +\label{absurd} -This tactic applies to any goal. It checks whether its arguments are -equal modulo alpha conversion and casts. +This tactic applies to any goal. The argument {\term} is any +proposition {\tt P} of type {\tt Prop}. This tactic applies {\tt + False} elimination, that is it deduces the current goal from {\tt + False}, and generates as subgoals {\tt $\sim$P} and {\tt P}. It is +very useful in proofs by cases, where some cases are impossible. In +most cases, \texttt{P} or $\sim$\texttt{P} is one of the hypotheses of +the local context. -\ErrMsg \errindex{Not equal} +\subsection{\tt contradiction} +\label{contradiction} +\tacindex{contradiction} -\subsection{\tt is\_evar \term -\tacindex{is\_evar} -\label{isevar}} +This tactic applies to any goal. The {\tt contradiction} tactic +attempts to find in the current context (after all {\tt intros}) one +hypothesis that is equivalent to {\tt False}. It permits to prune +irrelevant cases. This tactic is a macro for the tactics sequence +{\tt intros; elimtype False; assumption}. -This tactic applies to any goal. It checks whether its argument is an -existential variable. Existential variables are uninstantiated -variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). +\begin{ErrMsgs} +\item \errindex{No such assumption} +\end{ErrMsgs} -\ErrMsg \errindex{Not an evar} +\begin{Variants} +\item {\tt contradiction \ident} -\subsection{\tt has\_evar \term -\tacindex{has\_evar} -\label{hasevar}} +The proof of {\tt False} is searched in the hypothesis named \ident. +\end{Variants} -This tactic applies to any goal. It checks whether its argument has an -existential variable as a subterm. Unlike {\tt context} patterns -combined with {\tt is\_evar}, this tactic scans all subterms, -including those under binders. +\subsection{\tt contradict \ident} +\label{contradict} +\tacindex{contradict} -\ErrMsg \errindex{No evars} +This tactic allows to manipulate negated hypothesis and goals. The +name \ident\ should correspond to a hypothesis. With +{\tt contradict H}, the current goal and context is transformed in +the following way: +\begin{itemize} +\item {\tt H:$\neg$A $\vd$ B} \ becomes \ {\tt $\vd$ A} +\item {\tt H:$\neg$A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ A } +\item {\tt H: A $\vd$ B} \ becomes \ {\tt $\vd$ $\neg$A} +\item {\tt H: A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ $\neg$A} +\end{itemize} -\subsection{\tt is\_var \term -\tacindex{is\_var} -\label{isvar}} +\subsection{\tt exfalso} +\label{exfalso} +\tacindex{exfalso} -This tactic applies to any goal. It checks whether its argument is a -variable or hypothesis in the current goal context or in the opened sections. +This tactic implements the ``ex falso quodlibet'' logical principle: +an elimination of {\tt False} is performed on the current goal, and the +user is then required to prove that {\tt False} is indeed provable in +the current context. This tactic is a macro for {\tt elimtype False}. -\ErrMsg \errindex{Not a variable or hypothesis} +\section{Case analysis and induction} -\subsection{Bindings list -\index{Binding list} -\label{Binding-list}} +The tactics presented in this section implement induction or case +analysis on inductive or co-inductive objects (see +Section~\ref{Cic-inductive-definitions}). -Tactics that take a term as argument may also support a bindings list, so -as to instantiate some parameters of the term by name or position. -The general form of a term equipped with a bindings list is {\tt -{\term} with {\bindinglist}} where {\bindinglist} may be of two -different forms: +\subsection{\tt destruct \term} +\tacindex{destruct} +\label{destruct} -\begin{itemize} -\item In a bindings list of the form {\tt (\vref$_1$ := \term$_1$) - \dots\ (\vref$_n$ := \term$_n$)}, {\vref} is either an {\ident} or a - {\num}. The references are determined according to the type of - {\term}. If \vref$_i$ is an identifier, this identifier has to be - bound in the type of {\term} and the binding provides the tactic - with an instance for the parameter of this name. If \vref$_i$ is - some number $n$, this number denotes the $n$-th non dependent - premise of the {\term}, as determined by the type of {\term}. +This tactic applies to any goal. The argument {\term} must be of +inductive or co-inductive type and the tactic generates subgoals, one +for each possible form of {\term}, i.e. one for each constructor of +the inductive or co-inductive type. Unlike {\tt induction}, no +induction hypothesis is generated by {\tt destruct}. - \ErrMsg \errindex{No such binder} +If the argument is dependent in either the conclusion or some +hypotheses of the goal, the argument is replaced by the appropriate +constructor form in each of the resulting subgoals, thus performing +case analysis. If non-dependent, the tactic simply exposes the +inductive or co-inductive structure of the argument. -\item A bindings list can also be a simple list of terms {\tt - \term$_1$ \dots\term$_n$}. In that case the references to - which these terms correspond are determined by the tactic. In case - of {\tt induction}, {\tt destruct}, {\tt elim} and {\tt case} (see - Section~\ref{elim}) the terms have to provide instances for all the - dependent products in the type of \term\ while in the case of {\tt - apply}, or of {\tt constructor} and its variants, only instances for - the dependent products which are not bound in the conclusion of the - type are required. +There are special cases: - \ErrMsg \errindex{Not the right number of missing arguments} -\end{itemize} +\begin{itemize} -\subsection{Occurrences sets and occurrences clauses} -\label{Occurrences clauses} -\index{Occurrences clauses} +\item If {\term} is an identifier {\ident} denoting a quantified +variable of the conclusion of the goal, then {\tt destruct {\ident}} +behaves as {\tt intros until {\ident}; destruct {\ident}}. -An occurrences clause is a modifier to some tactics that obeys the -following syntax: +\item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as +{\tt intros until {\num}} followed by {\tt destruct} applied to the +last introduced hypothesis. Remark: For destruction of a numeral, use +syntax {\tt destruct ({\num})} (not very interesting anyway). -$\!\!\!$\begin{tabular}{lcl} -{\occclause} & ::= & {\tt in} {\occgoalset} \\ -{\occgoalset} & ::= & - \zeroone{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ -& & {\dots} {\tt ,}\\ -& & {\ident$_m$} \zeroone{\atoccurrences}}\\ -& & \zeroone{{\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}}\\ -& | & - {\tt *} {\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}\\ -& | & - {\tt *}\\ -{\atoccurrences} & ::= & {\tt at} {\occlist}\\ -{\occlist} & ::= & \zeroone{{\tt -}} {\num$_1$} \dots\ {\num$_n$} -\end{tabular} +\item The argument {\term} can also be a pattern of which holes are + denoted by ``\_''. In this case, the tactic checks that all subterms + matching the pattern in the conclusion and the hypotheses are + compatible and performs case analysis using this subterm. -The role of an occurrence clause is to select a set of occurrences of -a {\term} in a goal. In the first case, the {{\ident$_i$} -\zeroone{{\tt at} {\num$_1^i$} \dots\ {\num$_{n_i}^i$}}} parts -indicate that occurrences have to be selected in the hypotheses named -{\ident$_i$}. If no numbers are given for hypothesis {\ident$_i$}, -then all occurrences of {\term} in the hypothesis are selected. If -numbers are given, they refer to occurrences of {\term} when the term -is printed using option {\tt Set Printing All} (see -Section~\ref{SetPrintingAll}), counting from left to right. In -particular, occurrences of {\term} in implicit arguments (see -Section~\ref{Implicit Arguments}) or coercions (see -Section~\ref{Coercions}) are counted. +\end{itemize} -If a minus sign is given between {\tt at} and the list of occurrences, -it negates the condition so that the clause denotes all the occurrences except -the ones explicitly mentioned after the minus sign. +\begin{Variants} +\item{\tt destruct {\term} as {\disjconjintropattern}} -As an exception to the left-to-right order, the occurrences in the -{\tt return} subexpression of a {\tt match} are considered {\em -before} the occurrences in the matched term. + This behaves as {\tt destruct {\term}} but uses the names in + {\intropattern} to name the variables introduced in the context. + The {\intropattern} must have the form {\tt [} $p_{11}$ \ldots + $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt + ]} with $m$ being the number of constructors of the type of + {\term}. Each variable introduced by {\tt destruct} in the context + of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots + $p_{in_i}$ in order. If there are not enough names, {\tt destruct} + invents names for the remaining variables to introduce. More + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). This + provides a concise notation for nested destruction. -In the second case, the {\tt *} on the left of {\tt |-} means that -all occurrences of {\term} are selected in every hypothesis. +% It is recommended to use this variant of {\tt destruct} for +% robust proof scripts. -In the first and second case, if {\tt *} is mentioned on the right of -{\tt |-}, the occurrences of the conclusion of the goal have to be -selected. If some numbers are given, then only the occurrences denoted -by these numbers are selected. In no numbers are given, all -occurrences of {\term} in the goal are selected. +\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn} -Finally, the last notation is an abbreviation for {\tt * |- *}. Note -also that {\tt |-} is optional in the first case when no {\tt *} is -given. + This behaves as {\tt destruct {\term}} but adds an equation between + {\term} and the value that {\term} takes in each of the possible + cases. The name of the equation is chosen by Coq. If + {\disjconjintropattern} is simply {\tt []}, it is automatically considered + as a disjunctive pattern of the appropriate size. -Here are some tactics that understand occurrences clauses: -{\tt set}, {\tt remember}, {\tt induction}, {\tt destruct}. +\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn:~{\namingintropattern}} -\SeeAlso~Sections~\ref{tactic:set}, \ref{Tac-induction}, \ref{SetPrintingAll}. + This behaves as {\tt destruct {\term} as + {\disjconjintropattern} \_eqn} but use {\namingintropattern} to + name the equation (see Section~\ref{intros-pattern}). Note that spaces + can generally be removed around {\tt \_eqn}. +\item{\tt destruct {\term} with \bindinglist} -\section{Negation and contradiction} + This behaves like \texttt{destruct {\term}} providing explicit + instances for the dependent premises of the type of {\term} (see + syntax of bindings in Section~\ref{Binding-list}). -\subsection{\tt absurd \term -\tacindex{absurd} -\label{absurd}} +\item{\tt edestruct {\term}\tacindex{edestruct}} -This tactic applies to any goal. The argument {\term} is any -proposition {\tt P} of type {\tt Prop}. This tactic applies {\tt - False} elimination, that is it deduces the current goal from {\tt - False}, and generates as subgoals {\tt $\sim$P} and {\tt P}. It is -very useful in proofs by cases, where some cases are impossible. In -most cases, \texttt{P} or $\sim$\texttt{P} is one of the hypotheses of -the local context. + This tactic behaves like \texttt{destruct {\term}} except that it + does not fail if the instance of a dependent premises of the type of + {\term} is not inferable. Instead, the unresolved instances are left + as existential variables to be inferred later, in the same way as + {\tt eapply} does (see Section~\ref{eapply-example}). -\subsection{\tt contradiction -\label{contradiction} -\tacindex{contradiction}} +\item{\tt destruct {\term$_1$} using {\term$_2$}}\\ + {\tt destruct {\term$_1$} using {\term$_2$} with {\bindinglist}} -This tactic applies to any goal. The {\tt contradiction} tactic -attempts to find in the current context (after all {\tt intros}) one -hypothesis which is equivalent to {\tt False}. It permits to prune -irrelevant cases. This tactic is a macro for the tactics sequence -{\tt intros; elimtype False; assumption}. + These are synonyms of {\tt induction {\term$_1$} using {\term$_2$}} and + {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}}. -\begin{ErrMsgs} -\item \errindex{No such assumption} -\end{ErrMsgs} +\item \texttt{destruct {\term} in {\occgoalset}} -\begin{Variants} -\item {\tt contradiction \ident} + This syntax is used for selecting which occurrences of {\term} the + case analysis has to be done on. The {\tt in {\occgoalset}} clause is an + occurrence clause whose syntax and behavior is described in + Section~\ref{Occurrences clauses}. -The proof of {\tt False} is searched in the hypothesis named \ident. -\end{Variants} +% When an occurrence clause is given, an equation between {\term} and +% the value it gets in each case of the analysis is added to the +% context of the subgoals corresponding to the cases (even +% if no clause {\tt as {\namingintropattern}} is given). -\subsection {\tt contradict \ident} -\label{contradict} -\tacindex{contradict} +\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn:~{\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn:~{\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} -This tactic allows to manipulate negated hypothesis and goals. The -name \ident\ should correspond to a hypothesis. With -{\tt contradict H}, the current goal and context is transformed in -the following way: -\begin{itemize} -\item {\tt H:$\neg$A $\vd$ B} \ becomes \ {\tt $\vd$ A} -\item {\tt H:$\neg$A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ A } -\item {\tt H: A $\vd$ B} \ becomes \ {\tt $\vd$ $\neg$A} -\item {\tt H: A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ $\neg$A} -\end{itemize} + These are the general forms of {\tt destruct} and {\tt edestruct}. + They combine the effects of the {\tt with}, {\tt as}, {\tt using}, + and {\tt in} clauses. -\subsection{\tt exfalso} -\label{exfalso} -\tacindex{exfalso} +\item{\tt case \term}\label{case}\tacindex{case} -This tactic implements the ``ex falso quodlibet'' logical principle: -an elimination of {\tt False} is performed on the current goal, and the -user is then required to prove that {\tt False} is indeed provable in -the current context. This tactic is a macro for {\tt elimtype False}. + The tactic {\tt case} is a more basic tactic to perform case + analysis without recursion. It behaves as {\tt elim \term} but using + a case-analysis elimination principle and not a recursive one. -\section{Conversion tactics -\index{Conversion tactics} -\label{Conversion-tactics}} +\item {\tt case {\term} with {\bindinglist}} -This set of tactics implements different specialized usages of the -tactic \texttt{change}. + Analogous to {\tt elim {\term} with {\bindinglist}} above. -All conversion tactics (including \texttt{change}) can be -parameterized by the parts of the goal where the conversion can -occur. This is done using \emph{goal clauses} which consists in a list -of hypotheses and, optionally, of a reference to the conclusion of the -goal. For defined hypothesis it is possible to specify if the -conversion should occur on the type part, the body part or both -(default). +\item{\tt ecase {\term}\tacindex{ecase}}\\ + {\tt ecase {\term} with {\bindinglist}} -\index{Clauses} -\index{Goal clauses} -Goal clauses are written after a conversion tactic (tactics -\texttt{set}~\ref{tactic:set}, \texttt{rewrite}~\ref{rewrite}, -\texttt{replace}~\ref{tactic:replace} and -\texttt{autorewrite}~\ref{tactic:autorewrite} also use goal clauses) and -are introduced by the keyword \texttt{in}. If no goal clause is provided, -the default is to perform the conversion only in the conclusion. + In case the type of {\term} has dependent premises, or dependent + premises whose values are not inferable from the {\tt with + {\bindinglist}} clause, {\tt ecase} turns them into existential + variables to be resolved later on. -The syntax and description of the various goal clauses is the following: -\begin{description} -\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- } only in hypotheses {\ident}$_1$ - \ldots {\ident}$_n$ -\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- *} in hypotheses {\ident}$_1$ \ldots - {\ident}$_n$ and in the conclusion -\item[]\texttt{in * |-} in every hypothesis -\item[]\texttt{in *} (equivalent to \texttt{in * |- *}) everywhere -\item[]\texttt{in (type of {\ident}$_1$) (value of {\ident}$_2$) $\ldots$ |-} in - type part of {\ident}$_1$, in the value part of {\ident}$_2$, etc. -\end{description} +\item {\tt simple destruct \ident}\tacindex{simple destruct} -For backward compatibility, the notation \texttt{in}~{\ident}$_1$\ldots {\ident}$_n$ -performs the conversion in hypotheses {\ident}$_1$\ldots {\ident}$_n$. + This tactic behaves as {\tt intros until + {\ident}; case {\tt {\ident}}} when {\ident} is a quantified + variable of the goal. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%voir reduction__conv_x : histoires d'univers. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\item {\tt simple destruct {\num}} -\subsection[{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ -\dots\ \flag$_n$} and {\tt compute}] -{{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ -\dots\ \flag$_n$} and {\tt compute} -\tacindex{cbv} -\tacindex{lazy} -\tacindex{compute} -\tacindex{vm\_compute}\label{vmcompute}} + This tactic behaves as {\tt intros until + {\num}; case {\tt {\ident}}} where {\ident} is the name given by + {\tt intros until {\num}} to the {\num}-th non-dependent premise of + the goal. -These parameterized reduction tactics apply to any goal and perform -the normalization of the goal according to the specified flags. In -correspondence with the kinds of reduction considered in \Coq\, namely -$\beta$ (reduction of functional application), $\delta$ (unfolding of -transparent constants, see \ref{Transparent}), $\iota$ (reduction of -pattern-matching over a constructed term, and unfolding of {\tt fix} -and {\tt cofix} expressions) and $\zeta$ (contraction of local -definitions), the flag are either {\tt beta}, {\tt delta}, {\tt iota} -or {\tt zeta}. The {\tt delta} flag itself can be refined into {\tt -delta [\qualid$_1$\ldots\qualid$_k$]} or {\tt delta --[\qualid$_1$\ldots\qualid$_k$]}, restricting in the first case the -constants to unfold to the constants listed, and restricting in the -second case the constant to unfold to all but the ones explicitly -mentioned. Notice that the {\tt delta} flag does not apply to -variables bound by a let-in construction inside the term itself (use -here the {\tt zeta} flag). In any cases, opaque constants are not -unfolded (see Section~\ref{Opaque}). +\item{\tt case\_eq \term}\label{case_eq}\tacindex{case\_eq} -The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} -tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy -is a call-by-need strategy, with sharing of reductions: the arguments of a -function call are partially evaluated only when necessary, and if an -argument is used several times then it is computed only once. This -reduction is efficient for reducing expressions with dead code. For -instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a -pair of a witness $t$, and a proof that $t$ satisfies the predicate -$P$. Most of the time, $t$ may be computed without computing the proof -of $P(t)$, thanks to the lazy strategy. + The tactic {\tt case\_eq} is a variant of the {\tt case} tactic that + allow to perform case analysis on a term without completely + forgetting its original form. This is done by generating equalities + between the original form of the term and the outcomes of the case + analysis. -The call-by-value strategy is the one used in ML languages: the -arguments of a function call are evaluated first, using a weak -reduction (no reduction under the $\lambda$-abstractions). Despite the -lazy strategy always performs fewer reductions than the call-by-value -strategy, the latter is generally more efficient for evaluating purely -computational expressions (i.e. with few dead code). - -\begin{Variants} -\item {\tt compute} \tacindex{compute}\\ - {\tt cbv} - - These are synonyms for {\tt cbv beta delta iota zeta}. +% The effect of this tactic is similar to the effect of {\tt +% destruct {\term} in |- *} with the exception that no new hypotheses +% are introduced in the context. -\item {\tt lazy} - - This is a synonym for {\tt lazy beta delta iota zeta}. - -\item {\tt compute [\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt cbv [\qualid$_1$\ldots\qualid$_k$]} +\end{Variants} - These are synonyms of {\tt cbv beta delta - [\qualid$_1$\ldots\qualid$_k$] iota zeta}. - -\item {\tt compute -[\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt cbv -[\qualid$_1$\ldots\qualid$_k$]} +\subsection{\tt induction \term} +\tacindex{induction} +\label{Tac-induction} - These are synonyms of {\tt cbv beta delta - -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. +This tactic applies to any goal. The argument {\term} must be of +inductive type and the tactic {\tt induction} generates subgoals, +one for each possible form of {\term}, i.e. one for each constructor +of the inductive type. -\item {\tt lazy [\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt lazy -[\qualid$_1$\ldots\qualid$_k$]} +If the argument is dependent in either the conclusion or some +hypotheses of the goal, the argument is replaced by the appropriate +constructor form in each of the resulting subgoals and induction +hypotheses are added to the local context using names whose prefix is +{\tt IH}. - These are respectively synonyms of {\tt lazy beta delta - [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt lazy beta delta - -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. +There are particular cases: -\item {\tt vm\_compute} \tacindex{vm\_compute} +\begin{itemize} - This tactic evaluates the goal using the optimized call-by-value - evaluation bytecode-based virtual machine. This algorithm is - dramatically more efficient than the algorithm used for the {\tt - cbv} tactic, but it cannot be fine-tuned. It is specially - interesting for full evaluation of algebraic objects. This includes - the case of reflexion-based tactics. +\item If {\term} is an identifier {\ident} denoting a quantified +variable of the conclusion of the goal, then {\tt induction {\ident}} +behaves as {\tt intros until {\ident}; induction {\ident}}. -\end{Variants} +\item If {\term} is a {\num}, then {\tt induction {\num}} behaves as +{\tt intros until {\num}} followed by {\tt induction} applied to the +last introduced hypothesis. Remark: For simple induction on a numeral, +use syntax {\tt induction ({\num})} (not very interesting anyway). -% Obsolete? Anyway not very important message -%\begin{ErrMsgs} -%\item \errindex{Delta must be specified before} -% -% A list of constants appeared before the {\tt delta} flag. -%\end{ErrMsgs} +\item The argument {\term} can also be a pattern of which holes are + denoted by ``\_''. In this case, the tactic checks that all subterms + matching the pattern in the conclusion and the hypotheses are + compatible and performs induction using this subterm. +\end{itemize} -\subsection{{\tt red} -\tacindex{red}} +\Example -This tactic applies to a goal which has the form {\tt - forall (x:T1)\dots(xk:Tk), c t1 \dots\ tn} where {\tt c} is a constant. If -{\tt c} is transparent then it replaces {\tt c} with its definition -(say {\tt t}) and then reduces {\tt (t t1 \dots\ tn)} according to -$\beta\iota\zeta$-reduction rules. +\begin{coq_example} +Lemma induction_test : forall n:nat, n = n -> n <= n. +intros n H. +induction n. +\end{coq_example} \begin{ErrMsgs} -\item \errindex{Not reducible} -\end{ErrMsgs} +\item \errindex{Not an inductive product} +\item \errindex{Unable to find an instance for the variables +{\ident} \ldots {\ident}} -\subsection{{\tt hnf} -\tacindex{hnf}} + Use in this case + the variant {\tt elim \dots\ with \dots} below. +\end{ErrMsgs} -This tactic applies to any goal. It replaces the current goal with its -head normal form according to the $\beta\delta\iota\zeta$-reduction -rules, i.e. it reduces the head of the goal until it becomes a -product or an irreducible term. +\begin{Variants} +\item{\tt induction {\term} as {\disjconjintropattern}} -\Example -The term \verb+forall n:nat, (plus (S n) (S n))+ is not reduced by {\tt hnf}. + This behaves as {\tt induction {\term}} but uses the names in + {\disjconjintropattern} to name the variables introduced in the context. + The {\disjconjintropattern} must typically be of the form + {\tt [} $p_{11}$ \ldots + $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt + ]} with $m$ being the number of constructors of the type of + {\term}. Each variable introduced by {\tt induction} in the context + of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots + $p_{in_i}$ in order. If there are not enough names, {\tt induction} + invents names for the remaining variables to introduce. More + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). For instance, + for an inductive type with one constructor, the pattern notation + {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of + {\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. -\Rem The $\delta$ rule only applies to transparent constants -(see Section~\ref{Opaque} on transparency and opacity). +%\item{\tt induction {\term} as {\namingintropattern}} -\subsection{\tt simpl -\tacindex{simpl}} +% This behaves as {\tt induction {\term}} but adds an equation between +% {\term} and the value that {\term} takes in each of the induction +% case. The name of the equation is built according to +% {\namingintropattern} which can be an identifier, a ``?'', etc, as +% indicated in Section~\ref{intros-pattern}. -This tactic applies to any goal. The tactic {\tt simpl} first applies -$\beta\iota$-reduction rule. Then it expands transparent constants -and tries to reduce {\tt T'} according, once more, to $\beta\iota$ -rules. But when the $\iota$ rule is not applicable then possible -$\delta$-reductions are not applied. For instance trying to use {\tt -simpl} on {\tt (plus n O)=n} changes nothing. Notice that only -transparent constants whose name can be reused as such in the -recursive calls are possibly unfolded. For instance a constant defined -by {\tt plus' := plus} is possibly unfolded and reused in the -recursive calls, but a constant such as {\tt succ := plus (S O)} is -never unfolded. +%\item{\tt induction {\term} as {\namingintropattern} {\disjconjintropattern}} -The behaviour of {\tt simpl} can be tuned using the {\tt Arguments} vernacular -command as follows: -\begin{itemize} -\item -A constant can be marked to be never unfolded by {\tt simpl}: -\begin{coq_example*} -Arguments minus x y : simpl never -\end{coq_example*} -After that command an expression like {\tt (minus (S x) y)} is left untouched by -the {\tt simpl} tactic. -\item -A constant can be marked to be unfolded only if applied to enough arguments. -The number of arguments required can be specified using -the {\tt /} symbol in the arguments list of the {\tt Arguments} vernacular -command. -\begin{coq_example*} -Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). -Notation "f \o g" := (fcomp f g) (at level 50). -Arguments fcomp {A B C} f g x /. -\end{coq_example*} -After that command the expression {\tt (f \verb+\+o g)} is left untouched by -{\tt simpl} while {\tt ((f \verb+\+o g) t)} is reduced to {\tt (f (g t))}. -The same mechanism can be used to make a constant volatile, i.e. always -unfolded by {\tt simpl}. -\begin{coq_example*} -Definition volatile := fun x : nat => x. -Arguments volatile / x. -\end{coq_example*} -\item -A constant can be marked to be unfolded only if an entire set of arguments -evaluates to a constructor. The {\tt !} symbol can be used to mark such -arguments. -\begin{coq_example*} -Arguments minus !x !y. -\end{coq_example*} -After that command, the expression {\tt (minus (S x) y)} is left untouched by -{\tt simpl}, while {\tt (minus (S x) (S y))} is reduced to {\tt (minus x y)}. -\item -A special heuristic to determine if a constant has to be unfolded can be -activated with the following command: -\begin{coq_example*} -Arguments minus x y : simpl nomatch -\end{coq_example*} -The heuristic avoids to perform a simplification step that would -expose a {\tt match} construct in head position. For example the -expression {\tt (minus (S (S x)) (S y))} is simplified to -{\tt (minus (S x) y)} even if an extra simplification is possible. -\end{itemize} +% This combines the two previous forms. -\tacindex{simpl \dots\ in} -\begin{Variants} -\item {\tt simpl {\term}} - - This applies {\tt simpl} only to the occurrences of {\term} in the - current goal. +\item{\tt induction {\term} with \bindinglist} -\item {\tt simpl {\term} at \num$_1$ \dots\ \num$_i$} - - This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ - occurrences of {\term} in the current goal. + This behaves like \texttt{induction {\term}} providing explicit + instances for the premises of the type of {\term} (see the syntax of + bindings in Section~\ref{Binding-list}). - \ErrMsg {\tt Too few occurrences} +\item{\tt einduction {\term}\tacindex{einduction}} -\item {\tt simpl {\ident}} - - This applies {\tt simpl} only to the applicative subterms whose head - occurrence is {\ident}. + This tactic behaves like \texttt{induction {\term}} excepts that it + does not fail if some dependent premise of the type of {\term} is + not inferable. Instead, the unresolved premises are posed as + existential variables to be inferred later, in the same way as {\tt + eapply} does (see Section~\ref{eapply-example}). -\item {\tt simpl {\ident} at \num$_1$ \dots\ \num$_i$} - - This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ -applicative subterms whose head occurrence is {\ident}. +\item {\tt induction {\term$_1$} using {\term$_2$}} -\end{Variants} + This behaves as {\tt induction {\term$_1$}} but using {\term$_2$} as + induction scheme. It does not expect the conclusion of the type of + {\term$_1$} to be inductive. -\subsection{\tt unfold \qualid -\tacindex{unfold} -\label{unfold}} +\item {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}} -This tactic applies to any goal. The argument {\qualid} must denote a -defined transparent constant or local definition (see Sections~\ref{Basic-definitions} and~\ref{Transparent}). The tactic {\tt - unfold} applies the $\delta$ rule to each occurrence of the constant -to which {\qualid} refers in the current goal and then replaces it -with its $\beta\iota$-normal form. + This behaves as {\tt induction {\term$_1$} using {\term$_2$}} but + also providing instances for the premises of the type of {\term$_2$}. -\begin{ErrMsgs} -\item {\qualid} \errindex{does not denote an evaluable constant} +\item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}} -\end{ErrMsgs} + This syntax is used for the case {\qualid} denotes an induction principle + with complex predicates as the induction principles generated by + {\tt Function} or {\tt Functional Scheme} may be. -\begin{Variants} -\item {\tt unfold {\qualid}$_1$, \dots, \qualid$_n$} - \tacindex{unfold \dots\ in} - - Replaces {\em simultaneously} {\qualid}$_1$, \dots, {\qualid}$_n$ - with their definitions and replaces the current goal with its - $\beta\iota$ normal form. +\item \texttt{induction {\term} in {\occgoalset}} -\item {\tt unfold {\qualid}$_1$ at \num$_1^1$, \dots, \num$_i^1$, -\dots,\ \qualid$_n$ at \num$_1^n$ \dots\ \num$_j^n$} - - The lists \num$_1^1$, \dots, \num$_i^1$ and \num$_1^n$, \dots, - \num$_j^n$ specify the occurrences of {\qualid}$_1$, \dots, - \qualid$_n$ to be unfolded. Occurrences are located from left to - right. + This syntax is used for selecting which occurrences of {\term} the + induction has to be carried on. The {\tt in \occgoalset} clause is an + occurrence clause whose syntax and behavior is described in + Section~\ref{Occurrences clauses}. - \ErrMsg {\tt bad occurrence number of {\qualid}$_i$} +% When an occurrence clause is given, an equation between {\term} and +% the value it gets in each case of the induction is added to the +% context of the subgoals corresponding to the induction cases (even +% if no clause {\tt as {\namingintropattern}} is given). - \ErrMsg {\qualid}$_i$ {\tt does not occur} +\item {\tt induction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} -\item {\tt unfold {\qstring}} + These are the most general forms of {\tt induction} and {\tt + einduction}. It combines the effects of the {\tt with}, {\tt as}, + {\tt using}, and {\tt in} clauses. - If {\qstring} denotes the discriminating symbol of a notation (e.g. {\tt - "+"}) or an expression defining a notation (e.g. \verb!"_ + _"!), and - this notation refers to an unfoldable constant, then the tactic - unfolds it. +\item {\tt elim \term}\label{elim} -\item {\tt unfold {\qstring}\%{\delimkey}} + This is a more basic induction tactic. Again, the type of the + argument {\term} must be an inductive type. Then, according to + the type of the goal, the tactic {\tt elim} chooses the appropriate + destructor and applies it as the tactic {\tt apply} + would do. For instance, if the proof context contains {\tt + n:nat} and the current goal is {\tt T} of type {\tt + Prop}, then {\tt elim n} is equivalent to {\tt apply nat\_ind with + (n:=n)}. The tactic {\tt elim} does not modify the context of + the goal, neither introduces the induction loading into the context + of hypotheses. - This is variant of {\tt unfold {\qstring}} where {\qstring} gets its - interpretation from the scope bound to the delimiting key - {\delimkey} instead of its default interpretation (see - Section~\ref{scopechange}). - -\item {\tt unfold \qualidorstring$_1$ at \num$_1^1$, \dots, \num$_i^1$, -\dots,\ \qualidorstring$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + More generally, {\tt elim \term} also works when the type of {\term} + is a statement with premises and whose conclusion is inductive. In + that case the tactic performs induction on the conclusion of the + type of {\term} and leaves the non-dependent premises of the type as + subgoals. In the case of dependent products, the tactic tries to + find an instance for which the elimination lemma applies and fails + otherwise. - This is the most general form, where {\qualidorstring} is either a - {\qualid} or a {\qstring} referring to a notation. +\item {\tt elim {\term} with {\bindinglist}} -\end{Variants} + Allows to give explicit instances to the premises of the type + of {\term} (see Section~\ref{Binding-list}). -\subsection{{\tt fold} \term -\tacindex{fold}} +\item{\tt eelim {\term}\tacindex{eelim}} -This tactic applies to any goal. The term \term\ is reduced using the {\tt red} -tactic. Every occurrence of the resulting term in the goal is then -replaced by \term. + In case the type of {\term} has dependent premises, this turns them into + existential variables to be resolved later on. -\begin{Variants} -\item {\tt fold} \term$_1$ \dots\ \term$_n$ - - Equivalent to {\tt fold} \term$_1${\tt;}\ldots{\tt; fold} \term$_n$. -\end{Variants} +\item{\tt elim {\term$_1$} using {\term$_2$}}\\ + {\tt elim {\term$_1$} using {\term$_2$} with {\bindinglist}\tacindex{elim \dots\ using}} -\subsection{{\tt pattern {\term}} -\tacindex{pattern} -\label{pattern}} +Allows the user to give explicitly an elimination predicate +{\term$_2$} which is not the standard one for the underlying inductive +type of {\term$_1$}. The {\bindinglist} clause allows to +instantiate premises of the type of {\term$_2$}. -This command applies to any goal. The argument {\term} must be a free -subterm of the current goal. The command {\tt pattern} performs -$\beta$-expansion (the inverse of $\bt$-reduction) of the current goal -(say \T) by -\begin{enumerate} -\item replacing all occurrences of {\term} in {\T} with a fresh variable -\item abstracting this variable -\item applying the abstracted goal to {\term} -\end{enumerate} +\item{\tt elim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}}\\ + {\tt eelim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}} -For instance, if the current goal $T$ is expressible has $\phi(t)$ -where the notation captures all the instances of $t$ in $\phi(t)$, -then {\tt pattern $t$} transforms it into {\tt (fun x:$A$ => $\phi(${\tt -x}$)$) $t$}. This command can be used, for instance, when the tactic -{\tt apply} fails on matching. + These are the most general forms of {\tt elim} and {\tt eelim}. It + combines the effects of the {\tt using} clause and of the two uses + of the {\tt with} clause. -\begin{Variants} -\item {\tt pattern {\term} at {\num$_1$} \dots\ {\num$_n$}} - - Only the occurrences {\num$_1$} \dots\ {\num$_n$} of {\term} are - considered for $\beta$-expansion. Occurrences are located from left - to right. +\item {\tt elimtype \form}\tacindex{elimtype} -\item {\tt pattern {\term} at - {\num$_1$} \dots\ {\num$_n$}} - - All occurrences except the occurrences of indexes {\num$_1$} \dots\ - {\num$_n$} of {\term} are considered for - $\beta$-expansion. Occurrences are located from left to right. + The argument {\form} must be inductively defined. {\tt elimtype I} + is equivalent to {\tt cut I. intro H{\rm\sl n}; elim H{\rm\sl n}; + clear H{\rm\sl n}}. Therefore the hypothesis {\tt H{\rm\sl n}} will + not appear in the context(s) of the subgoal(s). Conversely, if {\tt + t} is a term of (inductive) type {\tt I} and which does not occur + in the goal then {\tt elim t} is equivalent to {\tt elimtype I; 2: + exact t.} -\item {\tt pattern {\term$_1$}, \dots, {\term$_m$}} - - Starting from a goal $\phi(t_1 \dots\ t_m)$, the tactic - {\tt pattern $t_1$, \dots,\ $t_m$} generates the equivalent goal {\tt - (fun (x$_1$:$A_1$) \dots\ (x$_m$:$A_m$) => $\phi(${\tt x$_1$\dots\ - x$_m$}$)$) $t_1$ \dots\ $t_m$}.\\ If $t_i$ occurs in one of the - generated types $A_j$ these occurrences will also be considered and - possibly abstracted. +\item {\tt simple induction \ident}\tacindex{simple induction} -\item {\tt pattern {\term$_1$} at {\num$_1^1$} \dots\ {\num$_{n_1}^1$}, \dots, - {\term$_m$} at {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} - - This behaves as above but processing only the occurrences \num$_1^1$, - \dots, \num$_i^1$ of \term$_1$, \dots, \num$_1^m$, \dots, \num$_j^m$ - of \term$_m$ starting from \term$_m$. + This tactic behaves as {\tt intros until + {\ident}; elim {\tt {\ident}}} when {\ident} is a quantified + variable of the goal. -\item {\tt pattern} {\term$_1$} \zeroone{{\tt at \zeroone{-}} {\num$_1^1$} \dots\ {\num$_{n_1}^1$}} {\tt ,} \dots {\tt ,} - {\term$_m$} \zeroone{{\tt at \zeroone{-}} {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} - - This is the most general syntax that combines the different variants. +\item {\tt simple induction {\num}} -\end{Variants} + This tactic behaves as {\tt intros until + {\num}; elim {\tt {\ident}}} where {\ident} is the name given by + {\tt intros until {\num}} to the {\num}-th non-dependent premise of + the goal. -\subsection{Conversion tactics applied to hypotheses} +%% \item {\tt simple induction {\term}}\tacindex{simple induction} -{\convtactic} {\tt in} \ident$_1$ \dots\ \ident$_n$ +%% If {\term} is an {\ident} corresponding to a quantified variable of +%% the goal then the tactic behaves as {\tt intros until {\ident}; elim +%% {\tt {\ident}}}. If {\term} is a {\num} then the tactic behaves as +%% {\tt intros until {\ident}; elim {\tt {\ident}}}. Otherwise, it is +%% a synonym for {\tt elim {\term}}. -Applies the conversion tactic {\convtactic} to the -hypotheses \ident$_1$, \ldots, \ident$_n$. The tactic {\convtactic} is -any of the conversion tactics listed in this section. +%% \Rem For simple induction on a numeral, use syntax {\tt simple +%% induction ({\num})}. -If \ident$_i$ is a local definition, then \ident$_i$ can be replaced -by (Type of \ident$_i$) to address not the body but the type of the -local definition. Example: {\tt unfold not in (Type of H1) (Type of H3).} +\end{Variants} -\begin{ErrMsgs} -\item \errindex{No such hypothesis} : {\ident}. -\end{ErrMsgs} +%\subsection[\tt FixPoint \dots]{\tt FixPoint \dots\tacindex{Fixpoint}} +%Not yet documented. +\subsection{\tt double induction \ident$_1$ \ident$_2$} +\tacindex{double induction} -\section{Introductions} +This tactic is deprecated and should be replaced by {\tt induction \ident$_1$; induction \ident$_2$} (or {\tt induction \ident$_1$; destruct \ident$_2$} depending on the exact needs). -Introduction tactics address goals which are inductive constants. -They are used when one guesses that the goal can be obtained with one -of its constructors' type. +%% This tactic applies to any goal. If the variables {\ident$_1$} and +%% {\ident$_2$} of the goal have an inductive type, then this tactic +%% performs double induction on these variables. For instance, if the +%% current goal is \verb+forall n m:nat, P n m+ then, {\tt double induction n +%% m} yields the four cases with their respective inductive hypotheses. -\subsection{\tt constructor \num -\label{constructor} -\tacindex{constructor}} +%% In particular, for proving \verb+(P (S n) (S m))+, the generated induction +%% hypotheses are \verb+(P (S n) m)+ and \verb+(m:nat)(P n m)+ (of the latter, +%% \verb+(P n m)+ and \verb+(P n (S m))+ are derivable). -This tactic applies to a goal such that the head of its conclusion is -an inductive constant (say {\tt I}). The argument {\num} must be less -or equal to the numbers of constructor(s) of {\tt I}. Let {\tt ci} be -the {\tt i}-th constructor of {\tt I}, then {\tt constructor i} is -equivalent to {\tt intros; apply ci}. +%% \Rem When the induction hypothesis \verb+(P (S n) m)+ is not +%% needed, {\tt induction \ident$_1$; destruct \ident$_2$} produces +%% more concise subgoals. -\begin{ErrMsgs} -\item \errindex{Not an inductive product} -\item \errindex{Not enough constructors} -\end{ErrMsgs} +\begin{Variant} -\begin{Variants} -\item \texttt{constructor} - - This tries \texttt{constructor 1} then \texttt{constructor 2}, - \dots\ , then \texttt{constructor} \textit{n} where \textit{n} if - the number of constructors of the head of the goal. +\item {\tt double induction \num$_1$ \num$_2$} -\item {\tt constructor \num~with} {\bindinglist} - - Let {\tt ci} be the {\tt i}-th constructor of {\tt I}, then {\tt - constructor i with \bindinglist} is equivalent to {\tt intros; - apply ci with \bindinglist}. +This tactic is deprecated and should be replaced by {\tt induction + \num$_1$; induction \num$_3$} where \num$_3$ is the result of +\num$_2$-\num$_1$. - \Warning the terms in the \bindinglist\ are checked - in the context where {\tt constructor} is executed and not in the - context where {\tt apply} is executed (the introductions are not - taken into account). +%% This tactic applies to any goal. If the variables {\ident$_1$} and -% To document? -% \item {\tt constructor {\tactic}} +%% This applies double induction on the \num$_1^{th}$ and \num$_2^{th}$ {\it +%% non dependent} premises of the goal. More generally, any combination of an +%% {\ident} and a {\num} is valid. -\item {\tt split}\tacindex{split} +\end{Variant} - Applies if {\tt I} has only one constructor, typically in the case - of conjunction $A\land B$. Then, it is equivalent to {\tt constructor 1}. +\subsection{\tt dependent induction \ident} +\tacindex{dependent induction} +\label{DepInduction} -\item {\tt exists {\bindinglist}}\tacindex{exists} +The \emph{experimental} tactic \texttt{dependent induction} performs +induction-inversion on an instantiated inductive predicate. +One needs to first require the {\tt Coq.Program.Equality} module to use +this tactic. The tactic is based on the BasicElim tactic by Conor +McBride \cite{DBLP:conf/types/McBride00} and the work of Cristina Cornes +around inversion \cite{DBLP:conf/types/CornesT95}. From an instantiated +inductive predicate and a goal, it generates an equivalent goal where the +hypothesis has been generalized over its indexes which are then +constrained by equalities to be the right instances. This permits to +state lemmas without resorting to manually adding these equalities and +still get enough information in the proofs. - Applies if {\tt I} has only one constructor, for instance in the - case of existential quantification $\exists x\cdot P(x)$. - Then, it is equivalent to {\tt intros; constructor 1 with \bindinglist}. +\Example -\item {\tt exists \nelist{\bindinglist}{,}} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Lemma le_minus : forall n:nat, n < 1 -> n = 0. +intros n H ; induction H. +\end{coq_example} - This iteratively applies {\tt exists {\bindinglist}}. +Here we did not get any information on the indexes to help fulfill this +proof. The problem is that, when we use the \texttt{induction} tactic, +we lose information on the hypothesis instance, notably that the second +argument is \texttt{1} here. Dependent induction solves this problem by +adding the corresponding equality to the context. -\item {\tt left}\tacindex{left}\\ - {\tt right}\tacindex{right} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Require Import Coq.Program.Equality. +Lemma le_minus : forall n:nat, n < 1 -> n = 0. +intros n H ; dependent induction H. +\end{coq_example} - Apply if {\tt I} has two constructors, for instance in the case of - disjunction $A\lor B$. Then, they are respectively equivalent to {\tt - constructor 1} and {\tt constructor 2}. - -\item {\tt left with \bindinglist}\\ - {\tt right with \bindinglist}\\ - {\tt split with \bindinglist} - - As soon as the inductive type has the right number of constructors, - these expressions are equivalent to calling {\tt - constructor $i$ with \bindinglist} for the appropriate $i$. +The subgoal is cleaned up as the tactic tries to automatically +simplify the subgoals with respect to the generated equalities. +In this enriched context, it becomes possible to solve this subgoal. +\begin{coq_example} +reflexivity. +\end{coq_example} -\item \texttt{econstructor}\tacindex{econstructor}\\ - \texttt{eexists}\tacindex{eexists}\\ - \texttt{esplit}\tacindex{esplit}\\ - \texttt{eleft}\tacindex{eleft}\\ - \texttt{eright}\tacindex{eright}\\ +Now we are in a contradictory context and the proof can be solved. +\begin{coq_example} +inversion H. +\end{coq_example} - These tactics and their variants behave like \texttt{constructor}, - \texttt{exists}, \texttt{split}, \texttt{left}, \texttt{right} and - their variants but they introduce existential variables instead of - failing when the instantiation of a variable cannot be found (cf - \texttt{eapply} and Section~\ref{eapply-example}). +This technique works with any inductive predicate. +In fact, the \texttt{dependent induction} tactic is just a wrapper around +the \texttt{induction} tactic. One can make its own variant by just +writing a new tactic based on the definition found in +\texttt{Coq.Program.Equality}. -\end{Variants} +\begin{Variants} +\item {\tt dependent induction {\ident} generalizing {\ident$_1$} \dots + {\ident$_n$}}\tacindex{dependent induction \dots\ generalizing} -\section[Induction and Case Analysis]{Induction and Case Analysis -\label{Tac-induction}} + This performs dependent induction on the hypothesis {\ident} but first + generalizes the goal by the given variables so that they are + universally quantified in the goal. This is generally what one wants + to do with the variables that are inside some constructors in the + induction hypothesis. The other ones need not be further generalized. -The tactics presented in this section implement induction or case -analysis on inductive or coinductive objects (see -Section~\ref{Cic-inductive-definitions}). +\item {\tt dependent destruction {\ident}}\tacindex{dependent destruction} -\subsection{\tt induction \term -\tacindex{induction}} + This performs the generalization of the instance {\ident} but uses {\tt destruct} + instead of {\tt induction} on the generalized hypothesis. This gives + results equivalent to {\tt inversion} or {\tt dependent inversion} if + the hypothesis is dependent. +\end{Variants} -This tactic applies to any goal. The argument {\term} must be of -inductive type and the tactic {\tt induction} generates subgoals, -one for each possible form of {\term}, i.e. one for each constructor -of the inductive type. +\SeeAlso \ref{dependent-induction-example} for a larger example of +dependent induction and an explanation of the underlying technique. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals and induction -hypotheses are added to the local context using names whose prefix is -{\tt IH}. +\subsection{\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$)} +\tacindex{functional induction} +\label{FunInduction} -There are particular cases: +The \emph{experimental} tactic \texttt{functional induction} performs +case analysis and induction following the definition of a function. It +makes use of a principle generated by \texttt{Function} +(see Section~\ref{Function}) or \texttt{Functional Scheme} +(see Section~\ref{FunScheme}). -\begin{itemize} - -\item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt induction {\ident}} -behaves as {\tt intros until {\ident}; induction {\ident}}. +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Functional Scheme minus_ind := Induction for minus Sort Prop. +Check minus_ind. +Lemma le_minus (n m:nat) : n - m <= n. +functional induction (minus n m); simpl; auto. +\end{coq_example} +\begin{coq_example*} +Qed. +\end{coq_example*} -\item If {\term} is a {\num}, then {\tt induction {\num}} behaves as -{\tt intros until {\num}} followed by {\tt induction} applied to the -last introduced hypothesis. Remark: For simple induction on a numeral, -use syntax {\tt induction ({\num})} (not very interesting anyway). +\Rem \texttt{(\qualid\ \term$_1$ \dots\ \term$_n$)} must be a correct +full application of \qualid. In particular, the rules for implicit +arguments are the same as usual. For example use \texttt{@\qualid} if +you want to write implicit arguments explicitly. -\item The argument {\term} can also be a pattern of which holes are - denoted by ``\_''. In this case, the tactic checks that all subterms - matching the pattern in the conclusion and the hypotheses are - compatible and performs induction using this subterm. +\Rem Parentheses over \qualid \dots \term$_n$ are mandatory. -\end{itemize} +\Rem \texttt{functional induction (f x1 x2 x3)} is actually a wrapper +for \texttt{induction x1 x2 x3 (f x1 x2 x3) using \qualid} followed by +a cleaning phase, where {\qualid} is the induction principle +registered for $f$ (by the \texttt{Function} (see Section~\ref{Function}) +or \texttt{Functional Scheme} (see Section~\ref{FunScheme}) command) +corresponding to the sort of the goal. Therefore \texttt{functional + induction} may fail if the induction scheme {\qualid} is +not defined. See also Section~\ref{Function} for the function terms +accepted by \texttt{Function}. -\Example +\Rem There is a difference between obtaining an induction scheme for a +function by using \texttt{Function} (see Section~\ref{Function}) and by +using \texttt{Functional Scheme} after a normal definition using +\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for +details. -\begin{coq_example} -Lemma induction_test : forall n:nat, n = n -> n <= n. -intros n H. -induction n. -\end{coq_example} +\SeeAlso{\ref{Function},\ref{FunScheme},\ref{FunScheme-examples}, + \ref{sec:functional-inversion}} \begin{ErrMsgs} -\item \errindex{Not an inductive product} -\item \errindex{Unable to find an instance for the variables -{\ident} \ldots {\ident}} - - Use in this case - the variant {\tt elim \dots\ with \dots} below. +\item \errindex{Cannot find induction information on \qualid} +\item \errindex{Not the right number of induction arguments} \end{ErrMsgs} \begin{Variants} -\item{\tt induction {\term} as {\disjconjintropattern}} - - This behaves as {\tt induction {\term}} but uses the names in - {\disjconjintropattern} to name the variables introduced in the context. - The {\disjconjintropattern} must typically be of the form - {\tt [} $p_{11}$ \ldots - $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt - ]} with $m$ being the number of constructors of the type of - {\term}. Each variable introduced by {\tt induction} in the context - of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots - $p_{in_i}$ in order. If there are not enough names, {\tt induction} - invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any disjunctive/conjunctive - introduction pattern (see Section~\ref{intros-pattern}). For instance, - for an inductive type with one constructor, the pattern notation - {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of - {\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. +\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) + as {\disjconjintropattern} using \term$_{m+1}$ with \bindinglist} -\item{\tt induction {\term} as {\namingintropattern}} + Similarly to \texttt{Induction} and \texttt{elim} + (see Section~\ref{Tac-induction}), this allows to give explicitly the + name of the introduced variables, the + induction principle, and the values of dependent premises of the + elimination scheme, including \emph{predicates} for mutual induction + when {\qualid} is part of a mutually recursive definition. - This behaves as {\tt induction {\term}} but adds an equation between - {\term} and the value that {\term} takes in each of the induction - case. The name of the equation is built according to - {\namingintropattern} which can be an identifier, a ``?'', etc, as - indicated in Section~\ref{intros-pattern}. +\end{Variants} -\item{\tt induction {\term} as {\namingintropattern} {\disjconjintropattern}} +\subsection{\tt discriminate \term} +\label{discriminate} +\tacindex{discriminate} - This combines the two previous forms. -\item{\tt induction {\term} with \bindinglist} +This tactic proves any goal from an assumption stating that two +structurally different terms of an inductive set are equal. For +example, from {\tt (S (S O))=(S O)} we can derive by absurdity any +proposition. - This behaves like \texttt{induction {\term}} providing explicit - instances for the premises of the type of {\term} (see the syntax of - bindings in Section~\ref{Binding-list}). +The argument {\term} is assumed to be a proof of a statement +of conclusion {\tt{\term$_1$} = {\term$_2$}} with {\term$_1$} and +{\term$_2$} being elements of an inductive set. To build the proof, +the tactic traverses the normal forms\footnote{Reminder: opaque + constants will not be expanded by $\delta$ reductions.} of +{\term$_1$} and {\term$_2$} looking for a couple of subterms {\tt u} +and {\tt w} ({\tt u} subterm of the normal form of {\term$_1$} and +{\tt w} subterm of the normal form of {\term$_2$}), placed at the same +positions and whose head symbols are two different constructors. If +such a couple of subterms exists, then the proof of the current goal +is completed, otherwise the tactic fails. -\item{\tt einduction {\term}\tacindex{einduction}} +\Rem The syntax {\tt discriminate {\ident}} can be used to refer to a +hypothesis quantified in the goal. In this case, the quantified +hypothesis whose name is {\ident} is first introduced in the local +context using \texttt{intros until \ident}. - This tactic behaves like \texttt{induction {\term}} excepts that it - does not fail if some dependent premise of the type of {\term} is - not inferable. Instead, the unresolved premises are posed as - existential variables to be inferred later, in the same way as {\tt - eapply} does (see Section~\ref{eapply-example}). +\begin{ErrMsgs} +\item \errindex{No primitive equality found} +\item \errindex{Not a discriminable equality} +\end{ErrMsgs} -\item {\tt induction {\term$_1$} using {\term$_2$}} +\begin{Variants} +\item \texttt{discriminate \num} - This behaves as {\tt induction {\term$_1$}} but using {\term$_2$} as - induction scheme. It does not expect the conclusion of the type of - {\term$_1$} to be inductive. + This does the same thing as \texttt{intros until \num} followed by + \texttt{discriminate \ident} where {\ident} is the identifier for + the last introduced hypothesis. -\item {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}} +\item \texttt{discriminate {\term} with \bindinglist} - This behaves as {\tt induction {\term$_1$} using {\term$_2$}} but - also providing instances for the premises of the type of {\term$_2$}. + This does the same thing as \texttt{discriminate {\term}} but using +the given bindings to instantiate parameters or hypotheses of {\term}. -\item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}} +\item \texttt{ediscriminate \num}\tacindex{ediscriminate}\\ + \texttt{ediscriminate {\term} \zeroone{with \bindinglist}} - This syntax is used for the case {\qualid} denotes an induction principle - with complex predicates as the induction principles generated by - {\tt Function} or {\tt Functional Scheme} may be. + This works the same as {\tt discriminate} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. -\item \texttt{induction {\term} in {\occgoalset}} +\item \texttt{discriminate} - This syntax is used for selecting which occurrences of {\term} the - induction has to be carried on. The {\tt in {\atoccurrences}} clause is an - occurrence clause whose syntax and behavior is described in - Section~\ref{Occurrences clauses}. + This behaves like {\tt discriminate {\ident}} if {\ident} is the + name of an hypothesis to which {\tt discriminate} is applicable; if + the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, + this behaves as {\tt intro {\ident}; injection {\ident}}. - When an occurrence clause is given, an equation between {\term} and - the value it gets in each case of the induction is added to the - context of the subgoals corresponding to the induction cases (even - if no clause {\tt as {\namingintropattern}} is given). + \ErrMsg \errindex{No discriminable equalities} +\end{Variants} -\item {\tt induction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\subsection{\tt injection \term} +\label{injection} +\tacindex{injection} - These are the most general forms of {\tt induction} and {\tt - einduction}. It combines the effects of the {\tt with}, {\tt as}, - {\tt using}, and {\tt in} clauses. +The {\tt injection} tactic is based on the fact that constructors of +inductive sets are injections. That means that if $c$ is a constructor +of an inductive set, and if $(c~\vec{t_1})$ and $(c~\vec{t_2})$ are two +terms that are equal then $~\vec{t_1}$ and $~\vec{t_2}$ are equal +too. -\item {\tt elim \term}\label{elim} - - This is a more basic induction tactic. Again, the type of the - argument {\term} must be an inductive type. Then, according to - the type of the goal, the tactic {\tt elim} chooses the appropriate - destructor and applies it as the tactic {\tt apply} - would do. For instance, if the proof context contains {\tt - n:nat} and the current goal is {\tt T} of type {\tt - Prop}, then {\tt elim n} is equivalent to {\tt apply nat\_ind with - (n:=n)}. The tactic {\tt elim} does not modify the context of - the goal, neither introduces the induction loading into the context - of hypotheses. +If {\term} is a proof of a statement of conclusion + {\tt {\term$_1$} = {\term$_2$}}, +then {\tt injection} applies injectivity as deep as possible to +derive the equality of all the subterms of {\term$_1$} and {\term$_2$} +placed in the same positions. For example, from {\tt (S + (S n))=(S (S (S m)))} we may derive {\tt n=(S m)}. To use this +tactic {\term$_1$} and {\term$_2$} should be elements of an inductive +set and they should be neither explicitly equal, nor structurally +different. We mean by this that, if {\tt n$_1$} and {\tt n$_2$} are +their respective normal forms, then: +\begin{itemize} +\item {\tt n$_1$} and {\tt n$_2$} should not be syntactically equal, +\item there must not exist any pair of subterms {\tt u} and {\tt w}, + {\tt u} subterm of {\tt n$_1$} and {\tt w} subterm of {\tt n$_2$} , + placed in the same positions and having different constructors as + head symbols. +\end{itemize} +If these conditions are satisfied, then, the tactic derives the +equality of all the subterms of {\term$_1$} and {\term$_2$} placed in +the same positions and puts them as antecedents of the current goal. - More generally, {\tt elim \term} also works when the type of {\term} - is a statement with premises and whose conclusion is inductive. In - that case the tactic performs induction on the conclusion of the - type of {\term} and leaves the non-dependent premises of the type as - subgoals. In the case of dependent products, the tactic tries to - find an instance for which the elimination lemma applies and fails - otherwise. +\Example Consider the following goal: -\item {\tt elim {\term} with {\bindinglist}} - - Allows to give explicit instances to the premises of the type - of {\term} (see Section~\ref{Binding-list}). +\begin{coq_example*} +Inductive list : Set := + | nil : list + | cons : nat -> list -> list. +Variable P : list -> Prop. +\end{coq_example*} +\begin{coq_eval} +Lemma ex : + forall (l:list) (n:nat), P nil -> cons n l = cons 0 nil -> P l. +intros l n H H0. +\end{coq_eval} +\begin{coq_example} +Show. +injection H0. +\end{coq_example} +\begin{coq_eval} +Abort. +\end{coq_eval} -\item{\tt eelim {\term}\tacindex{eelim}} +Beware that \texttt{injection} yields always an equality in a sigma type +whenever the injected object has a dependent type. - In case the type of {\term} has dependent premises, this turns them into - existential variables to be resolved later on. +\Rem There is a special case for dependent pairs. If we have a decidable +equality over the type of the first argument, then it is safe to do +the projection on the second one, and so {\tt injection} will work fine. +To define such an equality, you have to use the {\tt Scheme} command +(see \ref{Scheme}). -\item{\tt elim {\term$_1$} using {\term$_2$}}\\ - {\tt elim {\term$_1$} using {\term$_2$} with {\bindinglist}\tacindex{elim \dots\ using}} +\Rem If some quantified hypothesis of the goal is named {\ident}, then +{\tt injection {\ident}} first introduces the hypothesis in the local +context using \texttt{intros until \ident}. -Allows the user to give explicitly an elimination predicate -{\term$_2$} which is not the standard one for the underlying inductive -type of {\term$_1$}. The {\bindinglist} clause allows to -instantiate premises of the type of {\term$_2$}. +\begin{ErrMsgs} +\item \errindex{Not a projectable equality but a discriminable one} +\item \errindex{Nothing to do, it is an equality between convertible terms} +\item \errindex{Not a primitive equality} +\end{ErrMsgs} -\item{\tt elim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}}\\ - {\tt eelim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}} +\begin{Variants} +\item \texttt{injection \num} - These are the most general forms of {\tt elim} and {\tt eelim}. It - combines the effects of the {\tt using} clause and of the two uses - of the {\tt with} clause. + This does the same thing as \texttt{intros until \num} followed by +\texttt{injection \ident} where {\ident} is the identifier for the last +introduced hypothesis. -\item {\tt elimtype \form}\tacindex{elimtype} - - The argument {\form} must be inductively defined. {\tt elimtype I} - is equivalent to {\tt cut I. intro H{\rm\sl n}; elim H{\rm\sl n}; - clear H{\rm\sl n}}. Therefore the hypothesis {\tt H{\rm\sl n}} will - not appear in the context(s) of the subgoal(s). Conversely, if {\tt - t} is a term of (inductive) type {\tt I} and which does not occur - in the goal then {\tt elim t} is equivalent to {\tt elimtype I; 2: - exact t.} +\item \texttt{injection {\term} with \bindinglist} -\item {\tt simple induction \ident}\tacindex{simple induction} - - This tactic behaves as {\tt intros until - {\ident}; elim {\tt {\ident}}} when {\ident} is a quantified - variable of the goal. + This does the same as \texttt{injection {\term}} but using + the given bindings to instantiate parameters or hypotheses of {\term}. -\item {\tt simple induction {\num}} - - This tactic behaves as {\tt intros until - {\num}; elim {\tt {\ident}}} where {\ident} is the name given by - {\tt intros until {\num}} to the {\num}-th non-dependent premise of - the goal. +\item \texttt{einjection \num}\tacindex{einjection}\\ + \texttt{einjection {\term} \zeroone{with \bindinglist}} -%% \item {\tt simple induction {\term}}\tacindex{simple induction} - -%% If {\term} is an {\ident} corresponding to a quantified variable of -%% the goal then the tactic behaves as {\tt intros until {\ident}; elim -%% {\tt {\ident}}}. If {\term} is a {\num} then the tactic behaves as -%% {\tt intros until {\ident}; elim {\tt {\ident}}}. Otherwise, it is -%% a synonym for {\tt elim {\term}}. + This works the same as {\tt injection} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. -%% \Rem For simple induction on a numeral, use syntax {\tt simple -%% induction ({\num})}. +\item{\tt injection} + + If the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, + this behaves as {\tt intro {\ident}; injection {\ident}}. + + \ErrMsg \errindex{goal does not satisfy the expected preconditions} + +\item \texttt{injection {\term} \zeroone{with \bindinglist} as \nelist{\intropattern}{}}\\ +\texttt{injection {\num} as {\intropattern} \dots\ \intropattern}\\ +\texttt{injection as {\intropattern} \dots\ \intropattern}\\ +\texttt{einjection {\term} \zeroone{with \bindinglist} as \nelist{\intropattern}{}}\\ +\texttt{einjection {\num} as {\intropattern} \dots\ \intropattern}\\ +\texttt{einjection as {\intropattern} \dots\ \intropattern} +\tacindex{injection \dots\ as} + +These variants apply \texttt{intros} \nelist{\intropattern}{} after +the call to \texttt{injection} or \texttt{einjection}. \end{Variants} -\subsection{\tt destruct \term -\tacindex{destruct}} -\label{destruct} +\subsection{\tt inversion \ident} +\tacindex{inversion} -This tactic applies to any goal. The argument {\term} must be of -inductive or coinductive type and the tactic generates subgoals, one -for each possible form of {\term}, i.e. one for each constructor of -the inductive or coinductive type. Unlike {\tt induction}, no -induction hypothesis is generated by {\tt destruct}. +Let the type of {\ident} in the local context be $(I~\vec{t})$, +where $I$ is a (co)inductive predicate. Then, +\texttt{inversion} applied to \ident~ derives for each possible +constructor $c_i$ of $(I~\vec{t})$, {\bf all} the necessary +conditions that should hold for the instance $(I~\vec{t})$ to be +proved by $c_i$. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals, thus performing -case analysis. If non dependent, the tactic simply exposes the -inductive or coinductive structure of the argument. +\Rem If {\ident} does not denote a hypothesis in the local context +but refers to a hypothesis quantified in the goal, then the +latter is first introduced in the local context using +\texttt{intros until \ident}. -There are special cases: +\Rem As inversion proofs may be large in size, we recommend the user to +stock the lemmas whenever the same instance needs to be inverted +several times. See Section~\ref{Derive-Inversion}. -\begin{itemize} +\begin{Variants} +\item \texttt{inversion \num} -\item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt destruct {\ident}} -behaves as {\tt intros until {\ident}; destruct {\ident}}. + This does the same thing as \texttt{intros until \num} then + \texttt{inversion \ident} where {\ident} is the identifier for the + last introduced hypothesis. -\item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as -{\tt intros until {\num}} followed by {\tt destruct} applied to the -last introduced hypothesis. Remark: For destruction of a numeral, use -syntax {\tt destruct ({\num})} (not very interesting anyway). +\item \tacindex{inversion\_clear} \texttt{inversion\_clear \ident} -\item The argument {\term} can also be a pattern of which holes are - denoted by ``\_''. In this case, the tactic checks that all subterms - matching the pattern in the conclusion and the hypotheses are - compatible and performs case analysis using this subterm. + This behaves as \texttt{inversion} and then erases \ident~ from the + context. -\end{itemize} +\item \tacindex{inversion \dots\ as} \texttt{inversion {\ident} as \intropattern} -\begin{Variants} -\item{\tt destruct {\term} as {\disjconjintropattern}} - - This behaves as {\tt destruct {\term}} but uses the names in - {\intropattern} to name the variables introduced in the context. - The {\intropattern} must have the form {\tt [} $p_{11}$ \ldots - $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt - ]} with $m$ being the number of constructors of the type of - {\term}. Each variable introduced by {\tt destruct} in the context - of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots - $p_{in_i}$ in order. If there are not enough names, {\tt destruct} - invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any disjunctive/conjunctive - introduction pattern (see Section~\ref{intros-pattern}). This - provides a concise notation for nested destruction. + This behaves as \texttt{inversion} but using names in + {\intropattern} for naming hypotheses. The {\intropattern} must have + the form {\tt [} $p_{11}$ \ldots $p_{1n_1}$ {\tt |} {\ldots} {\tt |} + $p_{m1}$ \ldots $p_{mn_m}$ {\tt ]} with $m$ being the number of + constructors of the type of {\ident}. Be careful that the list must + be of length $m$ even if {\tt inversion} discards some cases (which + is precisely one of its roles): for the discarded cases, just use an + empty list (i.e. $n_i=0$). -% It is recommended to use this variant of {\tt destruct} for -% robust proof scripts. + The arguments of the $i^{th}$ constructor and the + equalities that {\tt inversion} introduces in the context of the + goal corresponding to the $i^{th}$ constructor, if it exists, get + their names from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If + there are not enough names, {\tt induction} invents names for the + remaining variables to introduce. In case an equation splits into + several equations (because {\tt inversion} applies {\tt injection} + on the equalities it generates), the corresponding name $p_{ij}$ in + the list must be replaced by a sublist of the form {\tt [$p_{ij1}$ + \ldots $p_{ijq}$]} (or, equivalently, {\tt ($p_{ij1}$, + \ldots, $p_{ijq}$)}) where $q$ is the number of subequalities + obtained from splitting the original equation. Here is an example. -\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn} +\begin{coq_eval} +Require Import List. +\end{coq_eval} - This behaves as {\tt destruct {\term}} but adds an equation between - {\term} and the value that {\term} takes in each of the possible - cases. The name of the equation is chosen by Coq. If - {\disjconjintropattern} is simply {\tt []}, it is automatically considered - as a disjunctive pattern of the appropriate size. +\begin{coq_example} +Inductive contains0 : list nat -> Prop := + | in_hd : forall l, contains0 (0 :: l) + | in_tl : forall l b, contains0 l -> contains0 (b :: l). +Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. +intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. +\end{coq_example} -\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn: {\namingintropattern}} +\begin{coq_eval} +Abort. +\end{coq_eval} - This behaves as {\tt destruct {\term} as - {\disjconjintropattern} \_eqn} but use {\namingintropattern} to - name the equation (see Section~\ref{intros-pattern}). Note that spaces - can generally be removed around {\tt \_eqn}. +\item \texttt{inversion {\num} as \intropattern} -\item{\tt destruct {\term} with \bindinglist} + This allows to name the hypotheses introduced by + \texttt{inversion \num} in the context. - This behaves like \texttt{destruct {\term}} providing explicit - instances for the dependent premises of the type of {\term} (see - syntax of bindings in Section~\ref{Binding-list}). +\item \tacindex{inversion\_clear \dots\ as} \texttt{inversion\_clear + {\ident} as \intropattern} -\item{\tt edestruct {\term}\tacindex{edestruct}} + This allows to name the hypotheses introduced by + \texttt{inversion\_clear} in the context. - This tactic behaves like \texttt{destruct {\term}} excepts that it - does not fail if the instance of a dependent premises of the type of - {\term} is not inferable. Instead, the unresolved instances are left - as existential variables to be inferred later, in the same way as - {\tt eapply} does (see Section~\ref{eapply-example}). +\item \tacindex{inversion \dots\ in} \texttt{inversion {\ident} + in \ident$_1$ \dots\ \ident$_n$} -\item{\tt destruct {\term$_1$} using {\term$_2$}}\\ - {\tt destruct {\term$_1$} using {\term$_2$} with {\bindinglist}} + Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This + tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and + then performing \texttt{inversion}. - These are synonyms of {\tt induction {\term$_1$} using {\term$_2$}} and - {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}}. +\item \tacindex{inversion \dots\ as \dots\ in} \texttt{inversion + {\ident} as {\intropattern} in \ident$_1$ \dots\ + \ident$_n$} -\item \texttt{destruct {\term} in {\occgoalset}} + This allows to name the hypotheses introduced in the context by + \texttt{inversion {\ident} in \ident$_1$ \dots\ \ident$_n$}. - This syntax is used for selecting which occurrences of {\term} the - case analysis has to be done on. The {\tt in {\occgoalset}} clause is an - occurrence clause whose syntax and behavior is described in - Section~\ref{Occurrences clauses}. +\item \tacindex{inversion\_clear \dots\ in} \texttt{inversion\_clear + {\ident} in \ident$_1$ \dots\ \ident$_n$} - When an occurrence clause is given, an equation between {\term} and - the value it gets in each case of the analysis is added to the - context of the subgoals corresponding to the cases (even - if no clause {\tt as {\namingintropattern}} is given). + Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This + tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and + then performing {\tt inversion\_clear}. -\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn: {\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn: {\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\item \tacindex{inversion\_clear \dots\ as \dots\ in} + \texttt{inversion\_clear {\ident} as {\intropattern} + in \ident$_1$ \dots\ \ident$_n$} - These are the general forms of {\tt destruct} and {\tt edestruct}. - They combine the effects of the {\tt with}, {\tt as}, {\tt using}, - and {\tt in} clauses. + This allows to name the hypotheses introduced in the context by + \texttt{inversion\_clear {\ident} in \ident$_1$ \dots\ \ident$_n$}. -\item{\tt case \term}\label{case}\tacindex{case} - - The tactic {\tt case} is a more basic tactic to perform case - analysis without recursion. It behaves as {\tt elim \term} but using - a case-analysis elimination principle and not a recursive one. +\item \tacindex{dependent inversion} \texttt{dependent inversion \ident} -\item{\tt case\_eq \term}\label{case_eq}\tacindex{case\_eq} + That must be used when \ident\ appears in the current goal. It acts + like \texttt{inversion} and then substitutes \ident\ for the + corresponding term in the goal. - The tactic {\tt case\_eq} is a variant of the {\tt case} tactic that - allow to perform case analysis on a term without completely - forgetting its original form. This is done by generating equalities - between the original form of the term and the outcomes of the case - analysis. The effect of this tactic is similar to the effect of {\tt - destruct {\term} in |- *} with the exception that no new hypotheses - are introduced in the context. +\item \tacindex{dependent inversion \dots\ as } \texttt{dependent + inversion {\ident} as \intropattern} -\item {\tt case {\term} with {\bindinglist}} + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion} {\ident}. - Analogous to {\tt elim {\term} with {\bindinglist}} above. +\item \tacindex{dependent inversion\_clear} \texttt{dependent + inversion\_clear \ident} -\item{\tt ecase {\term}\tacindex{ecase}}\\ - {\tt ecase {\term} with {\bindinglist}} - - In case the type of {\term} has dependent premises, or dependent - premises whose values are not inferable from the {\tt with - {\bindinglist}} clause, {\tt ecase} turns them into existential - variables to be resolved later on. + Like \texttt{dependent inversion}, except that {\ident} is cleared + from the local context. -\item {\tt simple destruct \ident}\tacindex{simple destruct} - - This tactic behaves as {\tt intros until - {\ident}; case {\tt {\ident}}} when {\ident} is a quantified - variable of the goal. +\item \tacindex{dependent inversion\_clear \dots\ as} + \texttt{dependent inversion\_clear {\ident} as \intropattern} -\item {\tt simple destruct {\num}} - - This tactic behaves as {\tt intros until - {\num}; case {\tt {\ident}}} where {\ident} is the name given by - {\tt intros until {\num}} to the {\num}-th non-dependent premise of - the goal. + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion\_clear} {\ident}. + +\item \tacindex{dependent inversion \dots\ with} \texttt{dependent + inversion {\ident} with \term} + + This variant allows you to specify the generalization of the goal. It + is useful when the system fails to generalize the goal automatically. If + {\ident} has type $(I~\vec{t})$ and $I$ has type + $\forall (\vec{x}:\vec{T}), s$, then \term~ must be of type + $I:\forall (\vec{x}:\vec{T}), I~\vec{x}\to s'$ where $s'$ is the + type of the goal. + +\item \tacindex{dependent inversion \dots\ as \dots\ with} + \texttt{dependent inversion {\ident} as {\intropattern} + with \term} + + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion {\ident} with \term}. + +\item \tacindex{dependent inversion\_clear \dots\ with} + \texttt{dependent inversion\_clear {\ident} with \term} + + Like \texttt{dependent inversion \dots\ with} but clears {\ident} from + the local context. + +\item \tacindex{dependent inversion\_clear \dots\ as \dots\ with} + \texttt{dependent inversion\_clear {\ident} as + {\intropattern} with \term} + + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion\_clear {\ident} with \term}. + +\item \tacindex{simple inversion} \texttt{simple inversion \ident} + It is a very primitive inversion tactic that derives all the necessary + equalities but it does not simplify the constraints as + \texttt{inversion} does. + +\item \tacindex{simple inversion \dots\ as} \texttt{simple inversion + {\ident} as \intropattern} + + This allows to name the hypotheses introduced in the context by + \texttt{simple inversion}. + +\item \tacindex{inversion \dots\ using} \texttt{inversion {\ident} + using \ident$'$} + + Let {\ident} have type $(I~\vec{t})$ ($I$ an inductive + predicate) in the local context, and \ident$'$ be a (dependent) inversion + lemma. Then, this tactic refines the current goal with the specified + lemma. + +\item \tacindex{inversion \dots\ using \dots\ in} \texttt{inversion + {\ident} using \ident$'$ in \ident$_1$\dots\ \ident$_n$} + + This tactic behaves as generalizing \ident$_1$\dots\ \ident$_n$, + then doing \texttt{inversion {\ident} using \ident$'$}. \end{Variants} -\subsection{\tt intros {\intropattern} {\ldots} {\intropattern} -\label{intros-pattern} -\tacindex{intros \intropattern}} -\index{Introduction patterns} -\index{Naming introduction patterns} -\index{Disjunctive/conjunctive introduction patterns} +\firstexample +\example{Non-dependent inversion} +\label{inversion-examples} -This extension of the tactic {\tt intros} combines introduction of -variables or hypotheses and case analysis. An {\em introduction pattern} is -either: -\begin{itemize} -\item A {\em naming introduction pattern}, i.e. either one of: - \begin{itemize} - \item the pattern \texttt{?} - \item the pattern \texttt{?\ident} - \item an identifier - \end{itemize} -\item A {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: - \begin{itemize} - \item a disjunction of lists of patterns: - {\tt [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} $p_{nm_n}$]} - \item a conjunction of patterns: {\tt (} $p_1$ {\tt ,} {\ldots} {\tt ,} $p_n$ {\tt )} - \item a list of patterns {\tt (} $p_1$\ {\tt \&}\ {\ldots}\ {\tt \&}\ $p_n$ {\tt )} - for sequence of right-associative binary constructs - \end{itemize} -\item the wildcard: {\tt \_} -\item the rewriting orientations: {\tt ->} or {\tt <-} -\end{itemize} +Let us consider the relation \texttt{Le} over natural numbers and the +following variables: -Assuming a goal of type {\tt $Q$ -> $P$} (non dependent product), or -of type {\tt forall $x$:$T$, $P$} (dependent product), the behavior of -{\tt intros $p$} is defined inductively over the structure of the -introduction pattern $p$: -\begin{itemize} -\item introduction on \texttt{?} performs the introduction, and lets {\Coq} - choose a fresh name for the variable; -\item introduction on \texttt{?\ident} performs the introduction, and - lets {\Coq} choose a fresh name for the variable based on {\ident}; -\item introduction on \texttt{\ident} behaves as described in - Section~\ref{intro}; -\item introduction over a disjunction of list of patterns {\tt - [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} - $p_{nm_n}$]} expects the product to be over an inductive type - whose number of constructors is $n$ (or more generally over a type - of conclusion an inductive type built from $n$ constructors, - e.g. {\tt C -> A$\backslash$/B if $n=2$}): it destructs the introduced - hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and - applies on each generated subgoal the corresponding tactic; - \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive - pattern is part of a sequence of patterns and is not the last - pattern of the sequence, then {\Coq} completes the pattern so as all - the argument of the constructors of the inductive type are - introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} - applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as - the list of patterns {\tt [$\,$|$\,$?$\,$] H}); -\item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, - $p_n$)} expects the goal to be a product over an inductive type $I$ with a - single constructor that itself has at least $n$ arguments: it - performs a case analysis over the hypothesis, as {\tt destruct} - would, and applies the patterns $p_1$~\ldots~$p_n$ to the arguments - of the constructor of $I$ (observe that {\tt ($p_1$, {\ldots}, - $p_n$)} is an alternative notation for {\tt [$p_1$ {\ldots} - $p_n$]}); -\item introduction via {\tt ( $p_1$ \& \ldots \& $p_n$ )} - is a shortcut for introduction via - {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the - hypothesis to be a sequence of right-associative binary inductive - constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an - hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be - introduced via pattern {\tt (a \& x \& b \& c \& d)}; -\item introduction on the wildcard depends on whether the product is - dependent or not: in the non dependent case, it erases the - corresponding hypothesis (i.e. it behaves as an {\tt intro} followed - by a {\tt clear}, cf Section~\ref{clear}) while in the dependent - case, it succeeds and erases the variable only if the wildcard is - part of a more complex list of introduction patterns that also - erases the hypotheses depending on this variable; -\item introduction over {\tt ->} (respectively {\tt <-}) expects the - hypothesis to be an equality and the right-hand-side (respectively - the left-hand-side) is replaced by the left-hand-side (respectively - the right-hand-side) in both the conclusion and the context of the goal; - if moreover the term to substitute is a variable, the hypothesis is - removed. -\end{itemize} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} -\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros - $p_1$;\ldots; intros $p_n$} for the following reasons: -\begin{itemize} -\item A wildcard pattern never succeeds when applied isolated on a - dependent product, while it succeeds as part of a list of - introduction patterns if the hypotheses that depends on it are - erased too. -\item A disjunctive or conjunctive pattern followed by an introduction - pattern forces the introduction in the context of all arguments of - the constructors before applying the next pattern while a terminal - disjunctive or conjunctive pattern does not. Here is an example +\begin{coq_example*} +Inductive Le : nat -> nat -> Set := + | LeO : forall n:nat, Le 0 n + | LeS : forall n m:nat, Le n m -> Le (S n) (S m). +Variable P : nat -> nat -> Prop. +Variable Q : forall n m:nat, Le n m -> Prop. +\end{coq_example*} -\begin{coq_example} -Goal forall n:nat, n = 0 -> n = 0. -intros [ | ] H. -Show 2. -Undo. -intros [ | ]; intros H. -Show 2. -\end{coq_example} +Let us consider the following goal: -\end{itemize} +\begin{coq_eval} +Lemma ex : forall n m:nat, Le (S n) m -> P n m. +intros. +\end{coq_eval} \begin{coq_example} -Lemma intros_test : forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. -intros A B C [a| [_ c]] f. -apply (f a). -exact c. -Qed. +Show. \end{coq_example} -%\subsection[\tt FixPoint \dots]{\tt FixPoint \dots\tacindex{Fixpoint}} -%Not yet documented. - -\subsection{\tt double induction \ident$_1$ \ident$_2$} -%\tacindex{double induction}} -This tactic is deprecated and should be replaced by {\tt induction \ident$_1$; induction \ident$_2$} (or {\tt induction \ident$_1$; destruct \ident$_2$} depending on the exact needs). - -%% This tactic applies to any goal. If the variables {\ident$_1$} and -%% {\ident$_2$} of the goal have an inductive type, then this tactic -%% performs double induction on these variables. For instance, if the -%% current goal is \verb+forall n m:nat, P n m+ then, {\tt double induction n -%% m} yields the four cases with their respective inductive hypotheses. - -%% In particular, for proving \verb+(P (S n) (S m))+, the generated induction -%% hypotheses are \verb+(P (S n) m)+ and \verb+(m:nat)(P n m)+ (of the latter, -%% \verb+(P n m)+ and \verb+(P n (S m))+ are derivable). - -%% \Rem When the induction hypothesis \verb+(P (S n) m)+ is not -%% needed, {\tt induction \ident$_1$; destruct \ident$_2$} produces -%% more concise subgoals. +To prove the goal, we may need to reason by cases on \texttt{H} and to +derive that \texttt{m} is necessarily of +the form $(S~m_0)$ for certain $m_0$ and that $(Le~n~m_0)$. +Deriving these conditions corresponds to prove that the +only possible constructor of \texttt{(Le (S n) m)} is +\texttt{LeS} and that we can invert the +\texttt{->} in the type of \texttt{LeS}. +This inversion is possible because \texttt{Le} is the smallest set closed by +the constructors \texttt{LeO} and \texttt{LeS}. -\begin{Variant} +\begin{coq_example} +inversion_clear H. +\end{coq_example} -\item {\tt double induction \num$_1$ \num$_2$} +Note that \texttt{m} has been substituted in the goal for \texttt{(S m0)} +and that the hypothesis \texttt{(Le n m0)} has been added to the +context. -This tactic is deprecated and should be replaced by {\tt induction - \num$_1$; induction \num$_3$} where \num$_3$ is the result of -\num$_2$-\num$_1$. +Sometimes it is +interesting to have the equality \texttt{m=(S m0)} in the +context to use it after. In that case we can use \texttt{inversion} that +does not clear the equalities: -%% This tactic applies to any goal. If the variables {\ident$_1$} and +\begin{coq_eval} +Undo. +\end{coq_eval} -%% This applies double induction on the \num$_1^{th}$ and \num$_2^{th}$ {\it -%% non dependent} premises of the goal. More generally, any combination of an -%% {\ident} and a {\num} is valid. +\begin{coq_example} +inversion H. +\end{coq_example} -\end{Variant} +\begin{coq_eval} +Abort. +\end{coq_eval} -\subsection{\tt dependent induction \ident - \tacindex{dependent induction} - \label{DepInduction}} +\example{Dependent inversion} -The \emph{experimental} tactic \texttt{dependent induction} performs -induction-inversion on an instantiated inductive predicate. -One needs to first require the {\tt Coq.Program.Equality} module to use -this tactic. The tactic is based on the BasicElim tactic by Conor -McBride \cite{DBLP:conf/types/McBride00} and the work of Cristina Cornes -around inversion \cite{DBLP:conf/types/CornesT95}. From an instantiated -inductive predicate and a goal it generates an equivalent goal where the -hypothesis has been generalized over its indexes which are then -constrained by equalities to be the right instances. This permits to -state lemmas without resorting to manually adding these equalities and -still get enough information in the proofs. -A simple example is the following: +Let us consider the following goal: \begin{coq_eval} -Reset Initial. +Lemma ex_dep : forall (n m:nat) (H:Le (S n) m), Q (S n) m H. +intros. \end{coq_eval} + \begin{coq_example} -Lemma le_minus : forall n:nat, n < 1 -> n = 0. -intros n H ; induction H. +Show. \end{coq_example} -Here we didn't get any information on the indexes to help fulfill this -proof. The problem is that when we use the \texttt{induction} tactic -we lose information on the hypothesis instance, notably that the second -argument is \texttt{1} here. Dependent induction solves this problem by -adding the corresponding equality to the context. +As \texttt{H} occurs in the goal, we may want to reason by cases on its +structure and so, we would like inversion tactics to +substitute \texttt{H} by the corresponding term in constructor form. +Neither \texttt{Inversion} nor {\tt Inversion\_clear} make such a +substitution. +To have such a behavior we use the dependent inversion tactics: -\begin{coq_eval} -Reset Initial. -\end{coq_eval} \begin{coq_example} -Require Import Coq.Program.Equality. -Lemma le_minus : forall n:nat, n < 1 -> n = 0. -intros n H ; dependent induction H. +dependent inversion_clear H. \end{coq_example} -The subgoal is cleaned up as the tactic tries to automatically -simplify the subgoals with respect to the generated equalities. -In this enriched context it becomes possible to solve this subgoal. -\begin{coq_example} -reflexivity. -\end{coq_example} +Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and +\texttt{m} by \texttt{(S m0)}. -Now we are in a contradictory context and the proof can be solved. -\begin{coq_example} -inversion H. -\end{coq_example} +\subsection{\tt fix {\ident} {\num}} +\tacindex{fix} +\label{tactic:fix} -This technique works with any inductive predicate. -In fact, the \texttt{dependent induction} tactic is just a wrapper around -the \texttt{induction} tactic. One can make its own variant by just -writing a new tactic based on the definition found in -\texttt{Coq.Program.Equality}. Common useful variants are the following, -defined in the same file: +This tactic is a primitive tactic to start a proof by induction. In +general, it is easier to rely on higher-level induction tactics such +as the ones described in Section~\ref{Tac-induction}. + +In the syntax of the tactic, the identifier {\ident} is the name given +to the induction hypothesis. The natural number {\num} tells on which +premise of the current goal the induction acts, starting +from 1 and counting both dependent and non dependent +products. Especially, the current lemma must be composed of at least +{\num} products. + +Like in a {\tt fix} expression, the induction +hypotheses have to be used on structurally smaller arguments. +The verification that inductive proof arguments are correct is done +only at the time of registering the lemma in the environment. To know +if the use of induction hypotheses is correct at some +time of the interactive development of a proof, use the command {\tt + Guarded} (see Section~\ref{Guarded}). \begin{Variants} -\item {\tt dependent induction {\ident} generalizing {\ident$_1$} \dots - {\ident$_n$}}\tacindex{dependent induction \dots\ generalizing} - - Does dependent induction on the hypothesis {\ident} but first - generalizes the goal by the given variables so that they are - universally quantified in the goal. This is generally what one wants - to do with the variables that are inside some constructors in the - induction hypothesis. The other ones need not be further generalized. + \item {\tt fix \ident$_1$ {\num} with ( \ident$_2$ + \nelist{\binder$_2$}{} \zeroone{\{ struct \ident$'_2$ + \}} :~\type$_2$ ) \dots\ ( \ident$_n$ + \nelist{\binder$_n$}{} \zeroone{\{ struct \ident$'_n$ \}} :~\type$_n$ )} + +This starts a proof by mutual induction. The statements to be +simultaneously proved are respectively {\tt forall} + \nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} + \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers +{\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the induction +hypotheses. The identifiers {\ident}$'_2$ {\ldots} {\ident}$'_n$ are the +respective names of the premises on which the induction is performed +in the statements to be simultaneously proved (if not given, the +system tries to guess itself what they are). -\item {\tt dependent destruction {\ident}}\tacindex{dependent destruction} - - Does the generalization of the instance {\ident} but uses {\tt destruct} - instead of {\tt induction} on the generalized hypothesis. This gives - results equivalent to {\tt inversion} or {\tt dependent inversion} if - the hypothesis is dependent. \end{Variants} -A larger example of dependent induction and an explanation of the -underlying technique are developed in section~\ref{dependent-induction-example}. +\subsection{\tt cofix \ident} +\tacindex{cofix} +\label{tactic:cofix} -\subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term -\label{decompose} -\tacindex{decompose}} +This tactic starts a proof by coinduction. The identifier {\ident} is +the name given to the coinduction hypothesis. Like in a {\tt cofix} +expression, the use of induction hypotheses have to guarded by a +constructor. The verification that the use of co-inductive hypotheses +is correct is done only at the time of registering the lemma in the +environment. To know if the use of coinduction hypotheses is correct +at some time of the interactive development of a proof, use the +command {\tt Guarded} (see Section~\ref{Guarded}). -This tactic allows to recursively decompose a -complex proposition in order to obtain atomic ones. -Example: -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Lemma ex1 : forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C. -intros A B C H; decompose [and or] H; assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} +\begin{Variants} + \item {\tt cofix \ident$_1$ with ( \ident$_2$ + \nelist{\binder$_2$}{} :~\type$_2$ ) \dots\ ( + \ident$_n$ \nelist{\binder$_n$}{} :~\type$_n$ )} -{\tt decompose} does not work on right-hand sides of implications or products. +This starts a proof by mutual coinduction. The statements to be +simultaneously proved are respectively {\tt forall} +\nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} + \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers + {\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the + coinduction hypotheses. -\begin{Variants} - -\item {\tt decompose sum \term}\tacindex{decompose sum} - This decomposes sum types (like \texttt{or}). -\item {\tt decompose record \term}\tacindex{decompose record} - This decomposes record types (inductive types with one constructor, - like \texttt{and} and \texttt{exists} and those defined with the - \texttt{Record} macro, see Section~\ref{Record}). \end{Variants} +\section{Rewriting expressions} -\subsection{\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$). -\tacindex{functional induction} -\label{FunInduction}} - -The \emph{experimental} tactic \texttt{functional induction} performs -case analysis and induction following the definition of a function. It -makes use of a principle generated by \texttt{Function} -(see Section~\ref{Function}) or \texttt{Functional Scheme} -(see Section~\ref{FunScheme}). -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Functional Scheme minus_ind := Induction for minus Sort Prop. +These tactics use the equality {\tt eq:forall A:Type, A->A->Prop} +defined in file {\tt Logic.v} (see Section~\ref{Equality}). The +notation for {\tt eq}~$T~t~u$ is simply {\tt $t$=$u$} dropping the +implicit type of $t$ and $u$. -Lemma le_minus : forall n m:nat, (n - m <= n). -intros n m. -functional induction (minus n m); simpl; auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} +\subsection{\tt rewrite \term +\label{rewrite} +\tacindex{rewrite}} -\Rem \texttt{(\qualid\ \term$_1$ \dots\ \term$_n$)} must be a correct -full application of \qualid. In particular, the rules for implicit -arguments are the same as usual. For example use \texttt{@\qualid} if -you want to write implicit arguments explicitly. +This tactic applies to any goal. The type of {\term} +must have the form -\Rem Parenthesis over \qualid \dots \term$_n$ are mandatory. +\texttt{forall (x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq} \term$_1$ \term$_2$. -\Rem \texttt{functional induction (f x1 x2 x3)} is actually a wrapper -for \texttt{induction x1 x2 x3 (f x1 x2 x3) using \qualid} followed by -a cleaning phase, where $\qualid$ is the induction principle -registered for $f$ (by the \texttt{Function} (see Section~\ref{Function}) -or \texttt{Functional Scheme} (see Section~\ref{FunScheme}) command) -corresponding to the sort of the goal. Therefore \texttt{functional - induction} may fail if the induction scheme (\texttt{\qualid}) is -not defined. See also Section~\ref{Function} for the function terms -accepted by \texttt{Function}. - -\Rem There is a difference between obtaining an induction scheme for a -function by using \texttt{Function} (see Section~\ref{Function}) and by -using \texttt{Functional Scheme} after a normal definition using -\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for -details. - -\SeeAlso{\ref{Function},\ref{FunScheme},\ref{FunScheme-examples}, - \ref{sec:functional-inversion}} - -\begin{ErrMsgs} -\item \errindex{Cannot find induction information on \qualid} - - ~ - -\item \errindex{Not the right number of induction arguments} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) - using \term$_{m+1}$ with {\term$_{n+1}$} \dots {\term$_m$}} - - Similar to \texttt{Induction} and \texttt{elim} - (see Section~\ref{Tac-induction}), allows to give explicitly the - induction principle and the values of dependent premises of the - elimination scheme, including \emph{predicates} for mutual induction - when {\qualid} is part of a mutually recursive definition. - -\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) - using \term$_{m+1}$ with {\vref$_1$} := {\term$_{n+1}$} \dots\ - {\vref$_m$} := {\term$_n$}} - - Similar to \texttt{induction} and \texttt{elim} - (see Section~\ref{Tac-induction}). - -\item All previous variants can be extended by the usual \texttt{as - \intropattern} construction, similar for example to - \texttt{induction} and \texttt{elim} (see Section~\ref{Tac-induction}). - -\end{Variants} - - - -\section{Equality} - -These tactics use the equality {\tt eq:forall A:Type, A->A->Prop} -defined in file {\tt Logic.v} (see Section~\ref{Equality}). The -notation for {\tt eq}~$T~t~u$ is simply {\tt $t$=$u$} dropping the -implicit type of $t$ and $u$. - -\subsection{\tt rewrite \term -\label{rewrite} -\tacindex{rewrite}} - -This tactic applies to any goal. The type of {\term} -must have the form - -\texttt{forall (x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq} \term$_1$ \term$_2$. - -\noindent where \texttt{eq} is the Leibniz equality or a registered -setoid equality. +\noindent where \texttt{eq} is the Leibniz equality or a registered +setoid equality. \noindent Then {\tt rewrite \term} finds the first subterm matching \term$_1$ in the goal, resulting in instances \term$_1'$ and \term$_2'$ @@ -2419,7 +2504,7 @@ Hence, some of the variables x$_i$ are solved by unification, and some of the types \texttt{A}$_1$, \dots, \texttt{A}$_n$ become new subgoals. -% \Rem In case the type of +% \Rem In case the type of % \term$_1$ contains occurrences of variables bound in the % type of \term, the tactic tries first to find a subterm of the goal % which matches this term in order to find a closed instance \term$'_1$ @@ -2449,13 +2534,13 @@ This happens if \term$_1$ does not occur in the goal. \texttt{H1} instead of the current goal. \item \texttt{rewrite H in H1 at 1, H2 at - 2 |- *} means \texttt{rewrite H; rewrite H in H1 at 1; rewrite H in H2 at - 2}. In particular a failure will happen if any of - these three simpler tactics fails. + these three simpler tactics fails. \item \texttt{rewrite H in * |- } will do \texttt{rewrite H in H$_i$} for all hypothesis \texttt{H$_i$ <> H}. A success will happen as soon as at least one of these simpler tactics succeeds. - \item \texttt{rewrite H in *} is a combination of \texttt{rewrite H} + \item \texttt{rewrite H in *} is a combination of \texttt{rewrite H} and \texttt{rewrite H in * |-} that succeeds if at - least one of these two tactics succeeds. + least one of these two tactics succeeds. \end{itemize} Orientation {\tt ->} or {\tt <-} can be inserted before the term to rewrite. @@ -2466,7 +2551,7 @@ This happens if \term$_1$ does not occur in the goal. Rewrite only the given occurrences of \term$_1'$. Occurrences are specified from left to right as for \texttt{pattern} (\S \ref{pattern}). The rewrite is always performed using setoid - rewriting, even for Leibniz's equality, so one has to + rewriting, even for Leibniz's equality, so one has to \texttt{Import Setoid} to use this variant. \item {\tt rewrite {\term} by {\tac}} @@ -2481,7 +2566,7 @@ This happens if \term$_1$ does not occur in the goal. generated by the previous one. Orientation {\tt ->} or {\tt <-} can be inserted before each term to rewrite. One unique \textit{clause} - can be added at the end after the keyword {\tt in}; it will + can be added at the end after the keyword {\tt in}; it will then affect all rewrite operations. \item In all forms of {\tt rewrite} described above, a term to rewrite @@ -2489,13 +2574,13 @@ This happens if \term$_1$ does not occur in the goal. \begin{itemize} \item {\tt ?} : the tactic {\tt rewrite ?$\term$} performs the rewrite of $\term$ as many times as possible (perhaps zero time). - This form never fails. - \item {\tt $n$?} : works similarly, except that it will do at most - $n$ rewrites. - \item {\tt !} : works as {\tt ?}, except that at least one rewrite - should succeed, otherwise the tactic fails. - \item {\tt $n$!} (or simply {\tt $n$}) : precisely $n$ rewrites - of $\term$ will be done, leading to failure if these $n$ rewrites are not possible. + This form never fails. + \item {\tt $n$?} : works similarly, except that it will do at most + $n$ rewrites. + \item {\tt !} : works as {\tt ?}, except that at least one rewrite + should succeed, otherwise the tactic fails. + \item {\tt $n$!} (or simply {\tt $n$}) : precisely $n$ rewrites + of $\term$ will be done, leading to failure if these $n$ rewrites are not possible. \end{itemize} \item {\tt erewrite {\term}\tacindex{erewrite}} @@ -2542,10 +2627,10 @@ n}| assumption || symmetry; try assumption]}. \item {\tt replace <- {\term}}\\ Replace {\term} with {\term'} using the first assumption whose type has the form {\tt \term'=\term} \item {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} }\\ - {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} by \tac }\\ - {\tt replace {\term} \textit{clause}}\\ - {\tt replace -> {\term} \textit{clause}}\\ - {\tt replace <- {\term} \textit{clause}}\\ + {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} by \tac }\\ + {\tt replace {\term} \textit{clause}}\\ + {\tt replace -> {\term} \textit{clause}}\\ + {\tt replace <- {\term} \textit{clause}}\\ Act as before but the replacements take place in \textit{clause}~(see Section~\ref{Conversion-tactics}) and not only in the conclusion of the goal.\\ @@ -2578,7 +2663,7 @@ the tactic changes it to {\tt u=t}. \subsection{\tt transitivity \term \tacindex{transitivity}} This tactic applies to a goal which has the form {\tt t=u} -and transforms it into the two subgoals +and transforms it into the two subgoals {\tt t={\term}} and {\tt {\term}=u}. \subsection{\tt subst {\ident} @@ -2586,13 +2671,13 @@ and transforms it into the two subgoals This tactic applies to a goal which has \ident\ in its context and (at least) one hypothesis, say {\tt H}, of type {\tt - \ident=t} or {\tt t=\ident}. Then it replaces -\ident\ by {\tt t} everywhere in the goal (in the hypotheses + \ident=t} or {\tt t=\ident}. Then it replaces +\ident\ by {\tt t} everywhere in the goal (in the hypotheses and in the conclusion) and clears \ident\ and {\tt H} from the context. -\Rem +\Rem When several hypotheses have the form {\tt \ident=t} or {\tt - t=\ident}, the first one is used. + t=\ident}, the first one is used. \begin{Variants} \item {\tt subst \ident$_1$ \dots \ident$_n$} \\ @@ -2612,7 +2697,7 @@ is typically a setoid equality. The application of {\tt stepl {\term}} then replaces the goal by ``$R$ {\term} {\term}$_2$'' and adds a new goal stating ``$eq$ {\term} {\term}$_1$''. -Lemmas are added to the database using the command +Lemmas are added to the database using the command \comindex{Declare Left Step} \begin{quote} {\tt Declare Left Step {\term}.} @@ -2640,710 +2725,1060 @@ and are registered using the command \end{quote} \end{Variants} +\subsection{\tt change \term +\tacindex{change} +\label{change}} -\subsection{\tt f\_equal -\label{f-equal} -\tacindex{f\_equal}} +This tactic applies to any goal. It implements the rule +``Conv''\index{Typing rules!Conv} given in Section~\ref{Conv}. {\tt + change U} replaces the current goal \T\ with \U\ providing that +\U\ is well-formed and that \T\ and \U\ are convertible. -This tactic applies to a goal of the form $f\ a_1\ \ldots\ a_n = f'\ -a'_1\ \ldots\ a'_n$. Using {\tt f\_equal} on such a goal leads to -subgoals $f=f'$ and $a_1=a'_1$ and so on up to $a_n=a'_n$. Amongst -these subgoals, the simple ones (e.g. provable by -reflexivity or congruence) are automatically solved by {\tt f\_equal}. +\begin{ErrMsgs} +\item \errindex{Not convertible} +\end{ErrMsgs} +\tacindex{change \dots\ in} +\begin{Variants} +\item {\tt change \term$_1$ with \term$_2$} -\section{Equality and inductive sets} + This replaces the occurrences of \term$_1$ by \term$_2$ in the + current goal. The terms \term$_1$ and \term$_2$ must be + convertible. -We describe in this section some special purpose tactics dealing with -equality and inductive sets or types. These tactics use the equality -{\tt eq:forall (A:Type), A->A->Prop}, simply written with the -infix symbol {\tt =}. +\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$} -\subsection{\tt decide equality -\label{decideequality} -\tacindex{decide equality}} + This replaces the occurrences numbered \num$_1$ \dots\ \num$_i$ of + \term$_1$ by \term$_2$ in the current goal. + The terms \term$_1$ and \term$_2$ must be convertible. -This tactic solves a goal of the form -{\tt forall $x$ $y$:$R$, \{$x$=$y$\}+\{\verb|~|$x$=$y$\}}, where $R$ -is an inductive type such that its constructors do not take proofs or -functions as arguments, nor objects in dependent types. -It solves goals of the form {\tt \{$x$=$y$\}+\{\verb|~|$x$=$y$\}} as well. + \ErrMsg {\tt Too few occurrences} -\subsection{\tt compare \term$_1$ \term$_2$ -\tacindex{compare}} +\item {\tt change {\term} in {\ident}} -This tactic compares two given objects \term$_1$ and \term$_2$ -of an inductive datatype. If $G$ is the current goal, it leaves the sub-goals -\term$_1${\tt =}\term$_2$ {\tt ->} $G$ and \verb|~|\term$_1${\tt =}\term$_2$ -{\tt ->} $G$. The type -of \term$_1$ and \term$_2$ must satisfy the same restrictions as in the tactic -\texttt{decide equality}. +\item {\tt change \term$_1$ with \term$_2$ in {\ident}} -\subsection{\tt discriminate {\term} -\label{discriminate} -\tacindex{discriminate} -\tacindex{ediscriminate}} +\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$ in + {\ident}} -This tactic proves any goal from an assumption stating that two -structurally different terms of an inductive set are equal. For -example, from {\tt (S (S O))=(S O)} we can derive by absurdity any -proposition. + This applies the {\tt change} tactic not to the goal but to the + hypothesis {\ident}. -The argument {\term} is assumed to be a proof of a statement -of conclusion {\tt{\term$_1$} = {\term$_2$}} with {\term$_1$} and -{\term$_2$} being elements of an inductive set. To build the proof, -the tactic traverses the normal forms\footnote{Reminder: opaque - constants will not be expanded by $\delta$ reductions} of -{\term$_1$} and {\term$_2$} looking for a couple of subterms {\tt u} -and {\tt w} ({\tt u} subterm of the normal form of {\term$_1$} and -{\tt w} subterm of the normal form of {\term$_2$}), placed at the same -positions and whose head symbols are two different constructors. If -such a couple of subterms exists, then the proof of the current goal -is completed, otherwise the tactic fails. +\end{Variants} -\Rem The syntax {\tt discriminate {\ident}} can be used to refer to a -hypothesis quantified in the goal. In this case, the quantified -hypothesis whose name is {\ident} is first introduced in the local -context using \texttt{intros until \ident}. +\SeeAlso \ref{Conversion-tactics} -\begin{ErrMsgs} -\item \errindex{No primitive equality found} -\item \errindex{Not a discriminable equality} -\end{ErrMsgs} -\begin{Variants} -\item \texttt{discriminate} \num +\section{Performing computations +\index{Conversion tactics} +\label{Conversion-tactics}} - This does the same thing as \texttt{intros until \num} followed by - \texttt{discriminate \ident} where {\ident} is the identifier for - the last introduced hypothesis. +This set of tactics implements different specialized usages of the +tactic \texttt{change}. -\item \texttt{discriminate} {\term} {\tt with} {\bindinglist} +All conversion tactics (including \texttt{change}) can be +parameterized by the parts of the goal where the conversion can +occur. This is done using \emph{goal clauses} which consists in a list +of hypotheses and, optionally, of a reference to the conclusion of the +goal. For defined hypothesis it is possible to specify if the +conversion should occur on the type part, the body part or both +(default). - This does the same thing as \texttt{discriminate {\term}} but using -the given bindings to instantiate parameters or hypotheses of {\term}. +\index{Clauses} +\index{Goal clauses} +Goal clauses are written after a conversion tactic (tactics +\texttt{set}~\ref{tactic:set}, \texttt{rewrite}~\ref{rewrite}, +\texttt{replace}~\ref{tactic:replace} and +\texttt{autorewrite}~\ref{tactic:autorewrite} also use goal clauses) and +are introduced by the keyword \texttt{in}. If no goal clause is provided, +the default is to perform the conversion only in the conclusion. -\item \texttt{ediscriminate} \num\\ - \texttt{ediscriminate} {\term} \zeroone{{\tt with} {\bindinglist}} +The syntax and description of the various goal clauses is the following: +\begin{description} +\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- } only in hypotheses {\ident}$_1$ + \ldots {\ident}$_n$ +\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- *} in hypotheses {\ident}$_1$ \ldots + {\ident}$_n$ and in the conclusion +\item[]\texttt{in * |-} in every hypothesis +\item[]\texttt{in *} (equivalent to \texttt{in * |- *}) everywhere +\item[]\texttt{in (type of {\ident}$_1$) (value of {\ident}$_2$) $\ldots$ |-} in + type part of {\ident}$_1$, in the value part of {\ident}$_2$, etc. +\end{description} - This works the same as {\tt discriminate} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. +For backward compatibility, the notation \texttt{in}~{\ident}$_1$\ldots {\ident}$_n$ +performs the conversion in hypotheses {\ident}$_1$\ldots {\ident}$_n$. -\item \texttt{discriminate} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%voir reduction__conv_x : histoires d'univers. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - This behaves like {\tt discriminate {\ident}} if {\ident} is the - name of an hypothesis to which {\tt discriminate} is applicable; if - the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, - this behaves as {\tt intro {\ident}; injection {\ident}}. +\subsection[{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ +\dots\ \flag$_n$} and {\tt compute}] +{{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ +\dots\ \flag$_n$} and {\tt compute} +\tacindex{cbv} +\tacindex{lazy} +\tacindex{compute} +\tacindex{vm\_compute}\label{vmcompute}} - \begin{ErrMsgs} - \item \errindex{No discriminable equalities} \\ - occurs when the goal does not verify the expected preconditions. - \end{ErrMsgs} -\end{Variants} +These parameterized reduction tactics apply to any goal and perform +the normalization of the goal according to the specified flags. In +correspondence with the kinds of reduction considered in \Coq\, namely +$\beta$ (reduction of functional application), $\delta$ (unfolding of +transparent constants, see \ref{Transparent}), $\iota$ (reduction of +pattern-matching over a constructed term, and unfolding of {\tt fix} +and {\tt cofix} expressions) and $\zeta$ (contraction of local +definitions), the flag are either {\tt beta}, {\tt delta}, {\tt iota} +or {\tt zeta}. The {\tt delta} flag itself can be refined into {\tt +delta [\qualid$_1$\ldots\qualid$_k$]} or {\tt delta +-[\qualid$_1$\ldots\qualid$_k$]}, restricting in the first case the +constants to unfold to the constants listed, and restricting in the +second case the constant to unfold to all but the ones explicitly +mentioned. Notice that the {\tt delta} flag does not apply to +variables bound by a let-in construction inside the term itself (use +here the {\tt zeta} flag). In any cases, opaque constants are not +unfolded (see Section~\ref{Opaque}). -\subsection{\tt injection {\term} -\label{injection} -\tacindex{injection} -\tacindex{einjection}} +The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} +tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy +is a call-by-need strategy, with sharing of reductions: the arguments of a +function call are partially evaluated only when necessary, and if an +argument is used several times then it is computed only once. This +reduction is efficient for reducing expressions with dead code. For +instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a +pair of a witness $t$, and a proof that $t$ satisfies the predicate +$P$. Most of the time, $t$ may be computed without computing the proof +of $P(t)$, thanks to the lazy strategy. -The {\tt injection} tactic is based on the fact that constructors of -inductive sets are injections. That means that if $c$ is a constructor -of an inductive set, and if $(c~\vec{t_1})$ and $(c~\vec{t_2})$ are two -terms that are equal then $~\vec{t_1}$ and $~\vec{t_2}$ are equal -too. +The call-by-value strategy is the one used in ML languages: the +arguments of a function call are evaluated first, using a weak +reduction (no reduction under the $\lambda$-abstractions). Despite the +lazy strategy always performs fewer reductions than the call-by-value +strategy, the latter is generally more efficient for evaluating purely +computational expressions (i.e. with few dead code). -If {\term} is a proof of a statement of conclusion - {\tt {\term$_1$} = {\term$_2$}}, -then {\tt injection} applies injectivity as deep as possible to -derive the equality of all the subterms of {\term$_1$} and {\term$_2$} -placed in the same positions. For example, from {\tt (S - (S n))=(S (S (S m)))} we may derive {\tt n=(S m)}. To use this -tactic {\term$_1$} and {\term$_2$} should be elements of an inductive -set and they should be neither explicitly equal, nor structurally -different. We mean by this that, if {\tt n$_1$} and {\tt n$_2$} are -their respective normal forms, then: -\begin{itemize} -\item {\tt n$_1$} and {\tt n$_2$} should not be syntactically equal, -\item there must not exist any pair of subterms {\tt u} and {\tt w}, - {\tt u} subterm of {\tt n$_1$} and {\tt w} subterm of {\tt n$_2$} , - placed in the same positions and having different constructors as - head symbols. -\end{itemize} -If these conditions are satisfied, then, the tactic derives the -equality of all the subterms of {\term$_1$} and {\term$_2$} placed in -the same positions and puts them as antecedents of the current goal. +\begin{Variants} +\item {\tt compute} \tacindex{compute}\\ + {\tt cbv} -\Example Consider the following goal: + These are synonyms for {\tt cbv beta delta iota zeta}. + +\item {\tt lazy} + + This is a synonym for {\tt lazy beta delta iota zeta}. + +\item {\tt compute [\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt cbv [\qualid$_1$\ldots\qualid$_k$]} + + These are synonyms of {\tt cbv beta delta + [\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt compute -[\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt cbv -[\qualid$_1$\ldots\qualid$_k$]} + + These are synonyms of {\tt cbv beta delta + -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt lazy [\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt lazy -[\qualid$_1$\ldots\qualid$_k$]} + + These are respectively synonyms of {\tt lazy beta delta + [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt lazy beta delta + -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt vm\_compute} \tacindex{vm\_compute} + + This tactic evaluates the goal using the optimized call-by-value + evaluation bytecode-based virtual machine. This algorithm is + dramatically more efficient than the algorithm used for the {\tt + cbv} tactic, but it cannot be fine-tuned. It is specially + interesting for full evaluation of algebraic objects. This includes + the case of reflexion-based tactics. + +\end{Variants} + +% Obsolete? Anyway not very important message +%\begin{ErrMsgs} +%\item \errindex{Delta must be specified before} +% +% A list of constants appeared before the {\tt delta} flag. +%\end{ErrMsgs} + + +\subsection{{\tt red} +\tacindex{red}} + +This tactic applies to a goal which has the form {\tt + forall (x:T1)\dots(xk:Tk), c t1 \dots\ tn} where {\tt c} is a constant. If +{\tt c} is transparent then it replaces {\tt c} with its definition +(say {\tt t}) and then reduces {\tt (t t1 \dots\ tn)} according to +$\beta\iota\zeta$-reduction rules. + +\begin{ErrMsgs} +\item \errindex{Not reducible} +\end{ErrMsgs} + +\subsection{{\tt hnf} +\tacindex{hnf}} + +This tactic applies to any goal. It replaces the current goal with its +head normal form according to the $\beta\delta\iota\zeta$-reduction +rules, i.e. it reduces the head of the goal until it becomes a +product or an irreducible term. + +\Example +The term \verb+forall n:nat, (plus (S n) (S n))+ is not reduced by {\tt hnf}. + +\Rem The $\delta$ rule only applies to transparent constants +(see Section~\ref{Opaque} on transparency and opacity). + +\subsection{\tt simpl +\tacindex{simpl}} + +This tactic applies to any goal. The tactic {\tt simpl} first applies +$\beta\iota$-reduction rule. Then it expands transparent constants +and tries to reduce {\tt T'} according, once more, to $\beta\iota$ +rules. But when the $\iota$ rule is not applicable then possible +$\delta$-reductions are not applied. For instance trying to use {\tt +simpl} on {\tt (plus n O)=n} changes nothing. Notice that only +transparent constants whose name can be reused as such in the +recursive calls are possibly unfolded. For instance a constant defined +by {\tt plus' := plus} is possibly unfolded and reused in the +recursive calls, but a constant such as {\tt succ := plus (S O)} is +never unfolded. + +The behavior of {\tt simpl} can be tuned using the {\tt Arguments} vernacular +command as follows: +\comindex{Arguments} +\begin{itemize} +\item +A constant can be marked to be never unfolded by {\tt simpl}: +\begin{coq_example*} +Arguments minus x y : simpl never +\end{coq_example*} +After that command an expression like {\tt (minus (S x) y)} is left untouched by +the {\tt simpl} tactic. +\item +A constant can be marked to be unfolded only if applied to enough arguments. +The number of arguments required can be specified using +the {\tt /} symbol in the arguments list of the {\tt Arguments} vernacular +command. +\begin{coq_example*} +Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). +Notation "f \o g" := (fcomp f g) (at level 50). +Arguments fcomp {A B C} f g x /. +\end{coq_example*} +After that command the expression {\tt (f \verb+\+o g)} is left untouched by +{\tt simpl} while {\tt ((f \verb+\+o g) t)} is reduced to {\tt (f (g t))}. +The same mechanism can be used to make a constant volatile, i.e. always +unfolded by {\tt simpl}. +\begin{coq_example*} +Definition volatile := fun x : nat => x. +Arguments volatile / x. +\end{coq_example*} +\item +A constant can be marked to be unfolded only if an entire set of arguments +evaluates to a constructor. The {\tt !} symbol can be used to mark such +arguments. +\begin{coq_example*} +Arguments minus !x !y. +\end{coq_example*} +After that command, the expression {\tt (minus (S x) y)} is left untouched by +{\tt simpl}, while {\tt (minus (S x) (S y))} is reduced to {\tt (minus x y)}. +\item +A special heuristic to determine if a constant has to be unfolded can be +activated with the following command: +\begin{coq_example*} +Arguments minus x y : simpl nomatch +\end{coq_example*} +The heuristic avoids to perform a simplification step that would +expose a {\tt match} construct in head position. For example the +expression {\tt (minus (S (S x)) (S y))} is simplified to +{\tt (minus (S x) y)} even if an extra simplification is possible. +\end{itemize} + +\tacindex{simpl \dots\ in} +\begin{Variants} +\item {\tt simpl {\term}} + + This applies {\tt simpl} only to the occurrences of {\term} in the + current goal. + +\item {\tt simpl {\term} at \num$_1$ \dots\ \num$_i$} + + This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ + occurrences of {\term} in the current goal. + + \ErrMsg {\tt Too few occurrences} + +\item {\tt simpl {\ident}} + + This applies {\tt simpl} only to the applicative subterms whose head + occurrence is {\ident}. + +\item {\tt simpl {\ident} at \num$_1$ \dots\ \num$_i$} + + This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ +applicative subterms whose head occurrence is {\ident}. + +\end{Variants} + +\subsection{\tt unfold \qualid +\tacindex{unfold} +\label{unfold}} + +This tactic applies to any goal. The argument {\qualid} must denote a +defined transparent constant or local definition (see Sections~\ref{Basic-definitions} and~\ref{Transparent}). The tactic {\tt + unfold} applies the $\delta$ rule to each occurrence of the constant +to which {\qualid} refers in the current goal and then replaces it +with its $\beta\iota$-normal form. + +\begin{ErrMsgs} +\item {\qualid} \errindex{does not denote an evaluable constant} + +\end{ErrMsgs} + +\begin{Variants} +\item {\tt unfold {\qualid}$_1$, \dots, \qualid$_n$} + \tacindex{unfold \dots\ in} + + Replaces {\em simultaneously} {\qualid}$_1$, \dots, {\qualid}$_n$ + with their definitions and replaces the current goal with its + $\beta\iota$ normal form. + +\item {\tt unfold {\qualid}$_1$ at \num$_1^1$, \dots, \num$_i^1$, +\dots,\ \qualid$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + + The lists \num$_1^1$, \dots, \num$_i^1$ and \num$_1^n$, \dots, + \num$_j^n$ specify the occurrences of {\qualid}$_1$, \dots, + \qualid$_n$ to be unfolded. Occurrences are located from left to + right. + + \ErrMsg {\tt bad occurrence number of {\qualid}$_i$} + + \ErrMsg {\qualid}$_i$ {\tt does not occur} + +\item {\tt unfold {\qstring}} + + If {\qstring} denotes the discriminating symbol of a notation (e.g. {\tt + "+"}) or an expression defining a notation (e.g. \verb!"_ + _"!), and + this notation refers to an unfoldable constant, then the tactic + unfolds it. + +\item {\tt unfold {\qstring}\%{\delimkey}} + + This is variant of {\tt unfold {\qstring}} where {\qstring} gets its + interpretation from the scope bound to the delimiting key + {\delimkey} instead of its default interpretation (see + Section~\ref{scopechange}). + +\item {\tt unfold \qualidorstring$_1$ at \num$_1^1$, \dots, \num$_i^1$, +\dots,\ \qualidorstring$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + + This is the most general form, where {\qualidorstring} is either a + {\qualid} or a {\qstring} referring to a notation. + +\end{Variants} + +\subsection{{\tt fold} \term +\tacindex{fold}} + +This tactic applies to any goal. The term \term\ is reduced using the {\tt red} +tactic. Every occurrence of the resulting term in the goal is then +replaced by \term. + +\begin{Variants} +\item {\tt fold} \term$_1$ \dots\ \term$_n$ + + Equivalent to {\tt fold} \term$_1${\tt;}\ldots{\tt; fold} \term$_n$. +\end{Variants} + +\subsection{{\tt pattern {\term}} +\tacindex{pattern} +\label{pattern}} + +This command applies to any goal. The argument {\term} must be a free +subterm of the current goal. The command {\tt pattern} performs +$\beta$-expansion (the inverse of $\bt$-reduction) of the current goal +(say \T) by +\begin{enumerate} +\item replacing all occurrences of {\term} in {\T} with a fresh variable +\item abstracting this variable +\item applying the abstracted goal to {\term} +\end{enumerate} + +For instance, if the current goal $T$ is expressible has $\phi(t)$ +where the notation captures all the instances of $t$ in $\phi(t)$, +then {\tt pattern $t$} transforms it into {\tt (fun x:$A$ => $\phi(${\tt +x}$)$) $t$}. This command can be used, for instance, when the tactic +{\tt apply} fails on matching. + +\begin{Variants} +\item {\tt pattern {\term} at {\num$_1$} \dots\ {\num$_n$}} + + Only the occurrences {\num$_1$} \dots\ {\num$_n$} of {\term} are + considered for $\beta$-expansion. Occurrences are located from left + to right. + +\item {\tt pattern {\term} at - {\num$_1$} \dots\ {\num$_n$}} + + All occurrences except the occurrences of indexes {\num$_1$} \dots\ + {\num$_n$} of {\term} are considered for + $\beta$-expansion. Occurrences are located from left to right. + +\item {\tt pattern {\term$_1$}, \dots, {\term$_m$}} + + Starting from a goal $\phi(t_1 \dots\ t_m)$, the tactic + {\tt pattern $t_1$, \dots,\ $t_m$} generates the equivalent goal {\tt + (fun (x$_1$:$A_1$) \dots\ (x$_m$:$A_m$) => $\phi(${\tt x$_1$\dots\ + x$_m$}$)$) $t_1$ \dots\ $t_m$}.\\ If $t_i$ occurs in one of the + generated types $A_j$ these occurrences will also be considered and + possibly abstracted. + +\item {\tt pattern {\term$_1$} at {\num$_1^1$} \dots\ {\num$_{n_1}^1$}, \dots, + {\term$_m$} at {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} + + This behaves as above but processing only the occurrences \num$_1^1$, + \dots, \num$_i^1$ of \term$_1$, \dots, \num$_1^m$, \dots, \num$_j^m$ + of \term$_m$ starting from \term$_m$. + +\item {\tt pattern} {\term$_1$} \zeroone{{\tt at \zeroone{-}} {\num$_1^1$} \dots\ {\num$_{n_1}^1$}} {\tt ,} \dots {\tt ,} + {\term$_m$} \zeroone{{\tt at \zeroone{-}} {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} + + This is the most general syntax that combines the different variants. + +\end{Variants} + +\subsection{Conversion tactics applied to hypotheses} + +{\convtactic} {\tt in} \ident$_1$ \dots\ \ident$_n$ + +Applies the conversion tactic {\convtactic} to the +hypotheses \ident$_1$, \ldots, \ident$_n$. The tactic {\convtactic} is +any of the conversion tactics listed in this section. + +If \ident$_i$ is a local definition, then \ident$_i$ can be replaced +by (Type of \ident$_i$) to address not the body but the type of the +local definition. Example: {\tt unfold not in (Type of H1) (Type of H3).} + +\begin{ErrMsgs} +\item \errindex{No such hypothesis} : {\ident}. +\end{ErrMsgs} + + +\section{Automation} +\subsection{\tt auto +\label{auto} +\tacindex{auto}} + +This tactic implements a Prolog-like resolution procedure to solve the +current goal. It first tries to solve the goal using the {\tt + assumption} tactic, then it reduces the goal to an atomic one using +{\tt intros} and introducing the newly generated hypotheses as hints. +Then it looks at the list of tactics associated to the head symbol of +the goal and tries to apply one of them (starting from the tactics +with lower cost). This process is recursively applied to the generated +subgoals. + +By default, \texttt{auto} only uses the hypotheses of the current goal and the +hints of the database named {\tt core}. + +\begin{Variants} + +\item {\tt auto \num} + + Forces the search depth to be \num. The maximal search depth is 5 by + default. + +\item {\tt auto with \ident$_1$ \dots\ \ident$_n$} + + Uses the hint databases $\ident_1$ \dots\ $\ident_n$ in addition to + the database {\tt core}. See Section~\ref{Hints-databases} for the + list of pre-defined databases and the way to create or extend a + database. This option can be combined with the previous one. + +\item {\tt auto with *} + + Uses all existing hint databases, minus the special database + {\tt v62}. See Section~\ref{Hints-databases} + +\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$} + + Uses \nterm{lemma}$_1$, \ldots, \nterm{lemma}$_n$ in addition to + hints (can be combined with the \texttt{with \ident} option). If + $lemma_i$ is an inductive type, it is the collection of its + constructors which is added as hints. + +\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$ with \ident$_1$ \dots\ \ident$_n$} + + This combines the effects of the {\tt using} and {\tt with} options. + +\item {\tt trivial}\tacindex{trivial} + + This tactic is a restriction of {\tt auto} that is not recursive and + tries only hints which cost 0. Typically it solves trivial + equalities like $X=X$. + +\item \texttt{trivial with \ident$_1$ \dots\ \ident$_n$} + +\item \texttt{trivial with *} + +\end{Variants} + +\Rem {\tt auto} either solves completely the goal or else leaves it +intact. \texttt{auto} and \texttt{trivial} never fail. + +\SeeAlso Section~\ref{Hints-databases} + +\subsection{\tt eauto +\tacindex{eauto} +\label{eauto}} + +This tactic generalizes {\tt auto}. In contrast with +the latter, {\tt eauto} uses unification of the goal +against the hints rather than pattern-matching +(in other words, it uses {\tt eapply} instead of +{\tt apply}). +As a consequence, {\tt eauto} can solve such a goal: -\begin{coq_example*} -Inductive list : Set := - | nil : list - | cons : nat -> list -> list. -Variable P : list -> Prop. -\end{coq_example*} -\begin{coq_eval} -Lemma ex : - forall (l:list) (n:nat), P nil -> cons n l = cons 0 nil -> P l. -intros l n H H0. -\end{coq_eval} \begin{coq_example} -Show. -injection H0. +Hint Resolve ex_intro. +Goal forall P:nat -> Prop, P 0 -> exists n, P n. +eauto. \end{coq_example} \begin{coq_eval} Abort. \end{coq_eval} -Beware that \texttt{injection} yields always an equality in a sigma type -whenever the injected object has a dependent type. +Note that {\tt ex\_intro} should be declared as an +hint. -\Rem There is a special case for dependent pairs. If we have a decidable -equality over the type of the first argument, then it is safe to do -the projection on the second one, and so {\tt injection} will work fine. -To define such an equality, you have to use the {\tt Scheme} command -(see \ref{Scheme}). +\SeeAlso Section~\ref{Hints-databases} -\Rem If some quantified hypothesis of the goal is named {\ident}, then -{\tt injection {\ident}} first introduces the hypothesis in the local -context using \texttt{intros until \ident}. +\subsection{\tt autounfold with \ident$_1$ \dots\ \ident$_n$ +\tacindex{autounfold} +\label{autounfold}} -\begin{ErrMsgs} -\item \errindex{Not a projectable equality but a discriminable one} -\item \errindex{Nothing to do, it is an equality between convertible terms} -\item \errindex{Not a primitive equality} -\end{ErrMsgs} +This tactic unfolds constants that were declared through a {\tt Hint + Unfold} in the given databases. + +\begin{Variants} +\item {\tt autounfold with \ident$_1$ \dots\ \ident$_n$ in \textit{clause}} + + Perform the unfolding in the given clause. + +\item {\tt autounfold with *} + + Uses the unfold hints declared in all the hint databases. +\end{Variants} + + +\subsection{\tt autorewrite with \ident$_1$ \dots \ident$_n$. +\label{tactic:autorewrite} +\tacindex{autorewrite}} + +This tactic \footnote{The behavior of this tactic has much changed compared to +the versions available in the previous distributions (V6). This may cause +significant changes in your theories to obtain the same result. As a drawback +of the re-engineering of the code, this tactic has also been completely revised +to get a very compact and readable version.} carries out rewritings according +the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}. + +Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until +it fails. Once all the rules have been processed, if the main subgoal has +progressed (e.g., if it is distinct from the initial main goal) then the rules +of this base are processed again. If the main subgoal has not progressed then +the next base is processed. For the bases, the behavior is exactly similar to +the processing of the rewriting rules. + +The rewriting rule bases are built with the {\tt Hint~Rewrite} vernacular +command. + +\Warning{} This tactic may loop if you build non terminating rewriting systems. + +\begin{Variant} +\item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\ +Performs, in the same way, all the rewritings of the bases {\tt \ident$_1$ $...$ +\ident$_n$} applying {\tt \tac} to the main subgoal after each rewriting step. + +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid}} + + Performs all the rewritings in hypothesis {\qualid}. +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid} using \tac} + + Performs all the rewritings in hypothesis {\qualid} applying {\tt + \tac} to the main subgoal after each rewriting step. + +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in \textit{clause}} + Performs all the rewritings in the clause \textit{clause}. \\ + The \textit{clause} argument must not contain any \texttt{type of} nor \texttt{value of}. + +\end{Variant} + +\SeeAlso Section~\ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}. + +\SeeAlso Section~\ref{autorewrite-example} for examples showing the use of +this tactic. + +% En attente d'un moyen de valoriser les fichiers de demos +%\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} + +\section{Controlling automation} + +\subsection{The hints databases for {\tt auto} and {\tt eauto} +\index{Hints databases} +\label{Hints-databases} +\comindex{Hint}} + +The hints for \texttt{auto} and \texttt{eauto} are stored in +databases. Each database maps head symbols to a list of hints. One can +use the command \texttt{Print Hint \ident} to display the hints +associated to the head symbol \ident{} (see \ref{PrintHint}). Each +hint has a cost that is an nonnegative integer, and an optional pattern. +The hints with lower cost are tried first. A hint is tried by +\texttt{auto} when the conclusion of the current goal +matches its pattern or when it has no pattern. + +\subsubsection*{Creating Hint databases + \label{CreateHintDb}\comindex{CreateHintDb}} + +One can optionally declare a hint database using the command +\texttt{Create HintDb}. If a hint is added to an unknown database, it +will be automatically created. + +\medskip +\texttt{Create HintDb} {\ident} [\texttt{discriminated}] +\medskip + +This command creates a new database named \ident. +The database is implemented by a Discrimination Tree (DT) that serves as +an index of all the lemmas. The DT can use transparency information to decide +if a constant should be indexed or not (c.f. \ref{HintTransparency}), +making the retrieval more efficient. +The legacy implementation (the default one for new databases) uses the +DT only on goals without existentials (i.e., auto goals), for non-Immediate +hints and do not make use of transparency hints, putting more work on the +unification that is run after retrieval (it keeps a list of the lemmas +in case the DT is not used). The new implementation enabled by +the {\tt discriminated} option makes use of DTs in all cases and takes +transparency information into account. However, the order in which hints +are retrieved from the DT may differ from the order in which they were +inserted, making this implementation observationally different from the +legacy one. + +\begin{Variants} +\item\texttt{Local Hint} \textsl{hint\_definition} \texttt{:} + \ident$_1$ \ldots\ \ident$_n$ + + This is used to declare a hint database that must not be exported to the other + modules that require and import the current module. Inside a + section, the option {\tt Local} is useless since hints do not + survive anyway to the closure of sections. + +\end{Variants} + +The general +command to add a hint to some database \ident$_1$, \dots, \ident$_n$ is: +\begin{tabbing} + \texttt{Hint} \textsl{hint\_definition} \texttt{:} \ident$_1$ \ldots\ \ident$_n$ +\end{tabbing} +where {\sl hint\_definition} is one of the following expressions: + +\begin{itemize} +\item \texttt{Resolve} {\term} + \comindex{Hint Resolve} + + This command adds {\tt apply {\term}} to the hint list + with the head symbol of the type of \term. The cost of that hint is + the number of subgoals generated by {\tt apply {\term}}. + + In case the inferred type of \term\ does not start with a product the + tactic added in the hint list is {\tt exact {\term}}. In case this + type can be reduced to a type starting with a product, the tactic {\tt + apply {\term}} is also stored in the hints list. -\begin{Variants} -\item \texttt{injection} \num{} + If the inferred type of \term\ contains a dependent + quantification on a predicate, it is added to the hint list of {\tt + eapply} instead of the hint list of {\tt apply}. In this case, a + warning is printed since the hint is only used by the tactic {\tt + eauto} (see \ref{eauto}). A typical example of a hint that is used + only by \texttt{eauto} is a transitivity lemma. - This does the same thing as \texttt{intros until \num} followed by -\texttt{injection \ident} where {\ident} is the identifier for the last -introduced hypothesis. + \begin{ErrMsgs} + \item \errindex{Bound head variable} -\item \texttt{injection} \term{} {\tt with} {\bindinglist} + The head symbol of the type of {\term} is a bound variable such + that this tactic cannot be associated to a constant. - This does the same as \texttt{injection {\term}} but using - the given bindings to instantiate parameters or hypotheses of {\term}. + \item \term\ \errindex{cannot be used as a hint} -\item \texttt{einjection} \num\\ - \texttt{einjection} \term{} \zeroone{{\tt with} {\bindinglist}} + The type of \term\ contains products over variables which do not + appear in the conclusion. A typical example is a transitivity axiom. + In that case the {\tt apply} tactic fails, and thus is useless. - This works the same as {\tt injection} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. + \end{ErrMsgs} -\item{\tt injection} - - If the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, - this behaves as {\tt intro {\ident}; injection {\ident}}. - - \ErrMsg \errindex{goal does not satisfy the expected preconditions} + \begin{Variants} -\item \texttt{injection} \term{} \zeroone{{\tt with} {\bindinglist}} \texttt{as} \nelist{\intropattern}{}\\ -\texttt{injection} \num{} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{injection} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{einjection} \term{} \zeroone{{\tt with} {\bindinglist}} \texttt{as} \nelist{\intropattern}{}\\ -\texttt{einjection} \num{} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{einjection} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\tacindex{injection \ldots{} as} - -These variants apply \texttt{intros} \nelist{\intropattern}{} after -the call to \texttt{injection} or \texttt{einjection}. + \item \texttt{Resolve} {\term$_1$} \dots {\term$_m$} -\end{Variants} + Adds each \texttt{Resolve} {\term$_i$}. -\subsection{\tt simplify\_eq {\term} -\tacindex{simplify\_eq} -\tacindex{esimplify\_eq} -\label{simplify-eq}} + \end{Variants} -Let {\term} be the proof of a statement of conclusion {\tt - {\term$_1$}={\term$_2$}}. If {\term$_1$} and -{\term$_2$} are structurally different (in the sense described for the -tactic {\tt discriminate}), then the tactic {\tt simplify\_eq} behaves as {\tt - discriminate {\term}}, otherwise it behaves as {\tt injection - {\term}}. +\item \texttt{Immediate {\term}} +\comindex{Hint Immediate} -\Rem If some quantified hypothesis of the goal is named {\ident}, then -{\tt simplify\_eq {\ident}} first introduces the hypothesis in the local -context using \texttt{intros until \ident}. + This command adds {\tt apply {\term}; trivial} to the hint list + associated with the head symbol of the type of {\ident} in the given + database. This tactic will fail if all the subgoals generated by + {\tt apply {\term}} are not solved immediately by the {\tt trivial} + tactic (which only tries tactics with cost $0$). -\begin{Variants} -\item \texttt{simplify\_eq} \num + This command is useful for theorems such as the symmetry of equality + or $n+1=m+1 \to n=m$ that we may like to introduce with a + limited use in order to avoid useless proof-search. - This does the same thing as \texttt{intros until \num} then -\texttt{simplify\_eq \ident} where {\ident} is the identifier for the last -introduced hypothesis. + The cost of this tactic (which never generates subgoals) is always 1, + so that it is not used by {\tt trivial} itself. -\item \texttt{simplify\_eq} \term{} {\tt with} {\bindinglist} + \begin{ErrMsgs} - This does the same as \texttt{simplify\_eq {\term}} but using - the given bindings to instantiate parameters or hypotheses of {\term}. + \item \errindex{Bound head variable} -\item \texttt{esimplify\_eq} \num\\ - \texttt{esimplify\_eq} \term{} \zeroone{{\tt with} {\bindinglist}} + \item \term\ \errindex{cannot be used as a hint} - This works the same as {\tt simplify\_eq} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. + \end{ErrMsgs} -\item{\tt simplify\_eq} + \begin{Variants} -If the current goal has form $t_1\verb=<>=t_2$, it behaves as -\texttt{intro {\ident}; simplify\_eq {\ident}}. -\end{Variants} + \item \texttt{Immediate} {\term$_1$} \dots {\term$_m$} -\subsection{\tt dependent rewrite -> {\ident} -\tacindex{dependent rewrite ->} -\label{dependent-rewrite}} + Adds each \texttt{Immediate} {\term$_i$}. -This tactic applies to any goal. If \ident\ has type -\verb+(existT B a b)=(existT B a' b')+ -in the local context (i.e. each term of the -equality has a sigma type $\{ a:A~ \&~(B~a)\}$) this tactic rewrites -\verb+a+ into \verb+a'+ and \verb+b+ into \verb+b'+ in the current -goal. This tactic works even if $B$ is also a sigma type. This kind -of equalities between dependent pairs may be derived by the injection -and inversion tactics. + \end{Variants} -\begin{Variants} -\item{\tt dependent rewrite <- {\ident}} -\tacindex{dependent rewrite <-} \\ -Analogous to {\tt dependent rewrite ->} but uses the equality from -right to left. -\end{Variants} +\item \texttt{Constructors} {\ident} +\comindex{Hint Constructors} -\section{Inversion -\label{inversion}} + If {\ident} is an inductive type, this command adds all its + constructors as hints of type \texttt{Resolve}. Then, when the + conclusion of current goal has the form \texttt{({\ident} \dots)}, + \texttt{auto} will try to apply each constructor. -\subsection{\tt inversion {\ident} -\tacindex{inversion}} + \begin{ErrMsgs} -Let the type of \ident~ in the local context be $(I~\vec{t})$, -where $I$ is a (co)inductive predicate. Then, -\texttt{inversion} applied to \ident~ derives for each possible -constructor $c_i$ of $(I~\vec{t})$, {\bf all} the necessary -conditions that should hold for the instance $(I~\vec{t})$ to be -proved by $c_i$. + \item {\ident} \errindex{is not an inductive type} -\Rem If {\ident} does not denote a hypothesis in the local context -but refers to a hypothesis quantified in the goal, then the -latter is first introduced in the local context using -\texttt{intros until \ident}. + \item {\ident} \errindex{not declared} -\begin{Variants} -\item \texttt{inversion} \num - - This does the same thing as \texttt{intros until \num} then - \texttt{inversion \ident} where {\ident} is the identifier for the - last introduced hypothesis. + \end{ErrMsgs} -\item \tacindex{inversion\_clear} \texttt{inversion\_clear} \ident + \begin{Variants} - This behaves as \texttt{inversion} and then erases \ident~ from the - context. + \item \texttt{Constructors} {\ident$_1$} \dots {\ident$_m$} -\item \tacindex{inversion \dots\ as} \texttt{inversion} {\ident} \texttt{as} {\intropattern} - - This behaves as \texttt{inversion} but using names in - {\intropattern} for naming hypotheses. The {\intropattern} must have - the form {\tt [} $p_{11}$ \ldots $p_{1n_1}$ {\tt |} {\ldots} {\tt |} - $p_{m1}$ \ldots $p_{mn_m}$ {\tt ]} with $m$ being the number of - constructors of the type of {\ident}. Be careful that the list must - be of length $m$ even if {\tt inversion} discards some cases (which - is precisely one of its roles): for the discarded cases, just use an - empty list (i.e. $n_i=0$). + Adds each \texttt{Constructors} {\ident$_i$}. - The arguments of the $i^{th}$ constructor and the - equalities that {\tt inversion} introduces in the context of the - goal corresponding to the $i^{th}$ constructor, if it exists, get - their names from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If - there are not enough names, {\tt induction} invents names for the - remaining variables to introduce. In case an equation splits into - several equations (because {\tt inversion} applies {\tt injection} - on the equalities it generates), the corresponding name $p_{ij}$ in - the list must be replaced by a sublist of the form {\tt [$p_{ij1}$ - \ldots $p_{ijq}$]} (or, equivalently, {\tt ($p_{ij1}$, - \ldots, $p_{ijq}$)}) where $q$ is the number of subequalities - obtained from splitting the original equation. Here is an example. + \end{Variants} -\begin{coq_eval} -Require Import List. -\end{coq_eval} +\item \texttt{Unfold} {\qualid} +\comindex{Hint Unfold} -\begin{coq_example} -Inductive contains0 : list nat -> Prop := - | in_hd : forall l, contains0 (0 :: l) - | in_tl : forall l b, contains0 l -> contains0 (b :: l). -Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. -intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. -\end{coq_example} + This adds the tactic {\tt unfold {\qualid}} to the hint list that + will only be used when the head constant of the goal is \ident. Its + cost is 4. -\begin{coq_eval} -Abort. -\end{coq_eval} + \begin{Variants} -\item \texttt{inversion} {\num} {\tt as} {\intropattern} + \item \texttt{Unfold} {\ident$_1$} \dots {\ident$_m$} - This allows to name the hypotheses introduced by - \texttt{inversion} {\num} in the context. + Adds each \texttt{Unfold} {\ident$_i$}. -\item \tacindex{inversion\_cleardots\ as} \texttt{inversion\_clear} - {\ident} {\tt as} {\intropattern} + \end{Variants} - This allows to name the hypotheses introduced by - \texttt{inversion\_clear} in the context. - -\item \tacindex{inversion \dots\ in} \texttt{inversion } {\ident} - \texttt{in} \ident$_1$ \dots\ \ident$_n$ +\item \texttt{Transparent}, \texttt{Opaque} {\qualid} +\label{HintTransparency} +\comindex{Hint Transparent} +\comindex{Hint Opaque} - Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and - then performing \texttt{inversion}. - -\item \tacindex{inversion \dots\ as \dots\ in} \texttt{inversion } - {\ident} {\tt as} {\intropattern} \texttt{in} \ident$_1$ \dots\ - \ident$_n$ - - This allows to name the hypotheses introduced in the context by - \texttt{inversion} {\ident} \texttt{in} \ident$_1$ \dots\ - \ident$_n$. - -\item \tacindex{inversion\_clear \dots\ in} \texttt{inversion\_clear} - {\ident} \texttt{in} \ident$_1$ \ldots \ident$_n$ - - Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and - then performing {\tt inversion\_clear}. - -\item \tacindex{inversion\_clear \dots\ as \dots\ in} - \texttt{inversion\_clear} {\ident} \texttt{as} {\intropattern} - \texttt{in} \ident$_1$ \ldots \ident$_n$ + This adds a transparency hint to the database, making {\tt {\qualid}} + a transparent or opaque constant during resolution. This information + is used during unification of the goal with any lemma in the database + and inside the discrimination network to relax or constrain it in the + case of \texttt{discriminated} databases. - This allows to name the hypotheses introduced in the context by - \texttt{inversion\_clear} {\ident} \texttt{in} \ident$_1$ \ldots - \ident$_n$. + \begin{Variants} -\item \tacindex{dependent inversion} \texttt{dependent inversion} - {\ident} - - That must be used when \ident\ appears in the current goal. It acts - like \texttt{inversion} and then substitutes \ident\ for the - corresponding term in the goal. - -\item \tacindex{dependent inversion \dots\ as } \texttt{dependent - inversion} {\ident} \texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion} {\ident}. + \item \texttt{Transparent}, \texttt{Opaque} {\ident$_1$} \dots {\ident$_m$} -\item \tacindex{dependent inversion\_clear} \texttt{dependent - inversion\_clear} {\ident} - - Like \texttt{dependent inversion}, except that {\ident} is cleared - from the local context. + Declares each {\ident$_i$} as a transparent or opaque constant. -\item \tacindex{dependent inversion\_clear \dots\ as} - \texttt{dependent inversion\_clear} {\ident}\texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion\_clear} {\ident}. + \end{Variants} -\item \tacindex{dependent inversion \dots\ with} \texttt{dependent - inversion } {\ident} \texttt{ with } \term - - This variant allows you to specify the generalization of the goal. It - is useful when the system fails to generalize the goal automatically. If - {\ident} has type $(I~\vec{t})$ and $I$ has type - $forall (\vec{x}:\vec{T}), s$, then \term~ must be of type - $I:forall (\vec{x}:\vec{T}), I~\vec{x}\to s'$ where $s'$ is the - type of the goal. +\item \texttt{Extern \num\ [\pattern]\ => }\textsl{tactic} +\comindex{Hint Extern} -\item \tacindex{dependent inversion \dots\ as \dots\ with} - \texttt{dependent inversion } {\ident} \texttt{as} {\intropattern} - \texttt{ with } \term - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion } {\ident} \texttt{ with } \term. + This hint type is to extend \texttt{auto} with tactics other than + \texttt{apply} and \texttt{unfold}. For that, we must specify a + cost, an optional pattern and a tactic to execute. Here is an example: -\item \tacindex{dependent inversion\_clear \dots\ with} - \texttt{dependent inversion\_clear } {\ident} \texttt{ with } \term - - Like \texttt{dependent inversion \dots\ with} but clears {\ident} from - the local context. +\begin{quotation} +\begin{verbatim} +Hint Extern 4 (~(_ = _)) => discriminate. +\end{verbatim} +\end{quotation} -\item \tacindex{dependent inversion\_clear \dots\ as \dots\ with} - \texttt{dependent inversion\_clear } {\ident} \texttt{as} - {\intropattern} \texttt{ with } \term - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion\_clear } {\ident} \texttt{ with } \term. + Now, when the head of the goal is a disequality, \texttt{auto} will + try \texttt{discriminate} if it does not manage to solve the goal + with hints with a cost less than 4. -\item \tacindex{simple inversion} \texttt{simple inversion} {\ident} - - It is a very primitive inversion tactic that derives all the necessary - equalities but it does not simplify the constraints as - \texttt{inversion} does. + One can even use some sub-patterns of the pattern in the tactic + script. A sub-pattern is a question mark followed by an ident, like + \texttt{?X1} or \texttt{?X2}. Here is an example: -\item \tacindex{simple inversion \dots\ as} \texttt{simple inversion} - {\ident} \texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{simple inversion}. +% Require EqDecide. +\begin{coq_example*} +Require Import List. +\end{coq_example*} +\begin{coq_example} +Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => + generalize X1, X2; decide equality : eqdec. +Goal +forall a b:list (nat * nat), {a = b} + {a <> b}. +info auto with eqdec. +\end{coq_example} +\begin{coq_eval} +Abort. +\end{coq_eval} -\item \tacindex{inversion \dots\ using} \texttt{inversion} \ident - \texttt{ using} \ident$'$ - - Let {\ident} have type $(I~\vec{t})$ ($I$ an inductive - predicate) in the local context, and \ident$'$ be a (dependent) inversion - lemma. Then, this tactic refines the current goal with the specified - lemma. +\end{itemize} -\item \tacindex{inversion \dots\ using \dots\ in} \texttt{inversion} - {\ident} \texttt{using} \ident$'$ \texttt{in} \ident$_1$\dots\ \ident$_n$ - - This tactic behaves as generalizing \ident$_1$\dots\ \ident$_n$, - then doing \texttt{inversion} {\ident} \texttt{using} \ident$'$. +\Rem One can use an \texttt{Extern} hint with no pattern to do +pattern-matching on hypotheses using \texttt{match goal with} inside +the tactic. -\end{Variants} +\begin{Variants} +\item \texttt{Hint} \textsl{hint\_definition} -\SeeAlso~\ref{inversion-examples} for detailed examples + No database name is given: the hint is registered in the {\tt core} + database. -\subsection{\tt Derive Inversion {\ident} with - ${\tt forall (}\vec{x}{\tt :}\vec{T}{\tt),} I~\vec{t}$ Sort \sort -\label{Derive-Inversion} -\comindex{Derive Inversion}} +\item\texttt{Hint Local} \textsl{hint\_definition} \texttt{:} + \ident$_1$ \ldots\ \ident$_n$ -This command generates an inversion principle for the -\texttt{inversion \dots\ using} tactic. -Let $I$ be an inductive predicate and $\vec{x}$ the variables -occurring in $\vec{t}$. This command generates and stocks the -inversion lemma for the sort \sort~ corresponding to the instance -$forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf -global} environment. When applied it is equivalent to have inverted -the instance with the tactic {\tt inversion}. + This is used to declare hints that must not be exported to the other + modules that require and import the current module. Inside a + section, the option {\tt Local} is useless since hints do not + survive anyway to the closure of sections. -\begin{Variants} -\item \texttt{Derive Inversion\_clear} {\ident} \texttt{with} - \comindex{Derive Inversion\_clear} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~ \\ - \index{Derive Inversion\_clear \dots\ with} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{inversion} - replaced by the tactic \texttt{inversion\_clear}. -\item \texttt{Derive Dependent Inversion} {\ident} \texttt{with} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~\\ - \comindex{Derive Dependent Inversion} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{dependent inversion}. -\item \texttt{Derive Dependent Inversion\_clear} {\ident} \texttt{with} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~\\ - \comindex{Derive Dependent Inversion\_clear} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{dependent inversion\_clear}. -\end{Variants} +\item\texttt{Hint Local} \textsl{hint\_definition} -\SeeAlso \ref{inversion-examples} for examples + Idem for the {\tt core} database. +\end{Variants} +% There are shortcuts that allow to define several goal at once: -\subsection[\tt functional inversion \ident]{\tt functional inversion \ident\label{sec:functional-inversion}} +% \begin{itemize} +% \item \comindex{Hints Resolve}\texttt{Hints Resolve \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ +% This command is a shortcut for the following ones: +% \begin{quotation} +% \noindent\texttt{Hint \ident$_1$ : \ident\ := Resolve \ident$_1$}\\ +% \dots\\ +% \texttt{Hint \ident$_1$ : \ident := Resolve \ident$_1$} +% \end{quotation} +% Notice that the hint name is the same that the theorem given as +% hint. +% \item \comindex{Hints Immediate}\texttt{Hints Immediate \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ +% \item \comindex{Hints Unfold}\texttt{Hints Unfold \qualid$_1$ \dots\ \qualid$_n$ : \ident.}\\ +% \end{itemize} -\texttt{functional inversion} is a \emph{highly} experimental tactic -which performs inversion on hypothesis \ident\ of the form -\texttt{\qualid\ \term$_1$\dots\term$_n$\ = \term} or \texttt{\term\ = - \qualid\ \term$_1$\dots\term$_n$} where \qualid\ must have been -defined using \texttt{Function} (see Section~\ref{Function}). +%\begin{Warnings} +% \item \texttt{Overriding hint named \dots\ in database \dots} +%\end{Warnings} -\begin{ErrMsgs} -\item \errindex{Hypothesis {\ident} must contain at least one Function} -\item \errindex{Cannot find inversion information for hypothesis \ident} - This error may be raised when some inversion lemma failed to be - generated by Function. -\end{ErrMsgs} -\begin{Variants} -\item {\tt functional inversion \num} - This does the same thing as \texttt{intros until \num} then - \texttt{functional inversion \ident} where {\ident} is the - identifier for the last introduced hypothesis. -\item {\tt functional inversion \ident\ \qualid}\\ - {\tt functional inversion \num\ \qualid} +\subsection{Hint databases defined in the \Coq\ standard library} - In case the hypothesis {\ident} (or {\num}) has a type of the form - \texttt{\qualid$_1$\ \term$_1$\dots\term$_n$\ =\ \qualid$_2$\ - \term$_{n+1}$\dots\term$_{n+m}$} where \qualid$_1$ and \qualid$_2$ - are valid candidates to functional inversion, this variant allows to - choose which must be inverted. -\end{Variants} +Several hint databases are defined in the \Coq\ standard library. The +actual content of a database is the collection of the hints declared +to belong to this database in each of the various modules currently +loaded. Especially, requiring new modules potentially extend a +database. At {\Coq} startup, only the {\tt core} and {\tt v62} +databases are non empty and can be used. +\begin{description} +\item[\tt core] This special database is automatically used by + \texttt{auto}, except when pseudo-database \texttt{nocore} is + given to \texttt{auto}. The \texttt{core} database contains + only basic lemmas about negation, + conjunction, and so on from. Most of the hints in this database come + from the \texttt{Init} and \texttt{Logic} directories. -\subsection{\tt quote \ident -\tacindex{quote} -\index{2-level approach}} +\item[\tt arith] This database contains all lemmas about Peano's + arithmetic proved in the directories \texttt{Init} and + \texttt{Arith} -This kind of inversion has nothing to do with the tactic -\texttt{inversion} above. This tactic does \texttt{change (\ident\ - t)}, where \texttt{t} is a term built in order to ensure the -convertibility. In other words, it does inversion of the function -\ident. This function must be a fixpoint on a simple recursive -datatype: see~\ref{quote-examples} for the full details. +\item[\tt zarith] contains lemmas about binary signed integers from + the directories \texttt{theories/ZArith}. When required, the module + {\tt Omega} also extends the database {\tt zarith} with a high-cost + hint that calls {\tt omega} on equations and inequalities in {\tt + nat} or {\tt Z}. -\begin{ErrMsgs} -\item \errindex{quote: not a simple fixpoint}\\ - Happens when \texttt{quote} is not able to perform inversion properly. -\end{ErrMsgs} +\item[\tt bool] contains lemmas about booleans, mostly from directory + \texttt{theories/Bool}. -\begin{Variants} -\item \texttt{quote {\ident} [ \ident$_1$ \dots \ident$_n$ ]}\\ - All terms that are built only with \ident$_1$ \dots \ident$_n$ will be - considered by \texttt{quote} as constants rather than variables. -\end{Variants} +\item[\tt datatypes] is for lemmas about lists, streams and so on that + are mainly proved in the \texttt{Lists} subdirectory. -% En attente d'un moyen de valoriser les fichiers de demos -% \SeeAlso file \texttt{theories/DEMOS/DemoQuote.v} in the distribution +\item[\tt sets] contains lemmas about sets and relations from the + directories \texttt{Sets} and \texttt{Relations}. -\section[Classical tactics]{Classical tactics\label{ClassicalTactics}} +\item[\tt typeclass\_instances] contains all the type class instances + declared in the environment, including those used for \texttt{setoid\_rewrite}, + from the \texttt{Classes} directory. +\end{description} -In order to ease the proving process, when the {\tt Classical} module is loaded. A few more tactics are available. Make sure to load the module using the \texttt{Require Import} command. +There is also a special database called {\tt v62}. It collects all +hints that were declared in the versions of {\Coq} prior to version +6.2.4 when the databases {\tt core}, {\tt arith}, and so on were +introduced. The purpose of the database {\tt v62} is to ensure +compatibility with further versions of {\Coq} for developments done in +versions prior to 6.2.4 ({\tt auto} being replaced by {\tt auto with v62}). +The database {\tt v62} is intended not to be extended (!). It is not +included in the hint databases list used in the {\tt auto with *} tactic. -\subsection{{\tt classical\_left, classical\_right} \tacindex{classical\_left} \tacindex{classical\_right}} +Furthermore, you are advised not to put your own hints in the +{\tt core} database, but use one or several databases specific to your +development. -The tactics \texttt{classical\_left} and \texttt{classical\_right} are the analog of the \texttt{left} and \texttt{right} but using classical logic. They can only be used for disjunctions. -Use \texttt{classical\_left} to prove the left part of the disjunction with the assumption that the negation of right part holds. -Use \texttt{classical\_right} to prove the right part of the disjunction with the assumption that the negation of left part holds. +\subsection{\tt Print Hint +\label{PrintHint} +\comindex{Print Hint}} -\section{Automatizing -\label{Automatizing}} +This command displays all hints that apply to the current goal. It +fails if no proof is being edited, while the two variants can be used at +every moment. -\subsection{\tt auto -\label{auto} -\tacindex{auto}} +\begin{Variants} -This tactic implements a Prolog-like resolution procedure to solve the -current goal. It first tries to solve the goal using the {\tt - assumption} tactic, then it reduces the goal to an atomic one using -{\tt intros} and introducing the newly generated hypotheses as hints. -Then it looks at the list of tactics associated to the head symbol of -the goal and tries to apply one of them (starting from the tactics -with lower cost). This process is recursively applied to the generated -subgoals. +\item {\tt Print Hint {\ident} } -By default, \texttt{auto} only uses the hypotheses of the current goal and the -hints of the database named {\tt core}. + This command displays only tactics associated with \ident\ in the + hints list. This is independent of the goal being edited, so this + command will not fail if no goal is being edited. -\begin{Variants} +\item {\tt Print Hint *} -\item {\tt auto \num} + This command displays all declared hints. - Forces the search depth to be \num. The maximal search depth is 5 by - default. +\item {\tt Print HintDb {\ident} } +\label{PrintHintDb} +\comindex{Print HintDb} -\item {\tt auto with \ident$_1$ \dots\ \ident$_n$} - - Uses the hint databases $\ident_1$ \dots\ $\ident_n$ in addition to - the database {\tt core}. See Section~\ref{Hints-databases} for the - list of pre-defined databases and the way to create or extend a - database. This option can be combined with the previous one. + This command displays all hints from database \ident. -\item {\tt auto with *} +\end{Variants} - Uses all existing hint databases, minus the special database - {\tt v62}. See Section~\ref{Hints-databases} +\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident +\label{HintRewrite} +\comindex{Hint Rewrite}} -\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$} +This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} +(their types must be equalities) in the rewriting base {\tt \ident} +with the default orientation (left to right). Notice that the +rewriting bases are distinct from the {\tt auto} hint bases and that +{\tt auto} does not take them into account. - Uses \nterm{lemma}$_1$, \ldots, \nterm{lemma}$_n$ in addition to - hints (can be combined with the \texttt{with \ident} option). If - $lemma_i$ is an inductive type, it is the collection of its - constructors which is added as hints. +This command is synchronous with the section mechanism (see \ref{Section}): +when closing a section, all aliases created by \texttt{Hint Rewrite} in that +section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} +declarations at the global level of that module are loaded. -\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$ with \ident$_1$ \dots\ \ident$_n$} +\begin{Variants} +\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ +This is strictly equivalent to the command above (we only make explicit the +orientation which otherwise defaults to {\tt ->}). - This combines the effects of the {\tt using} and {\tt with} options. +\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ +Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left +orientation in the base {\tt \ident}. -\item {\tt trivial}\tacindex{trivial} +\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ +When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will +be used, the tactic {\tt \tac} will be applied to the generated subgoals, the +main subgoal excluded. - This tactic is a restriction of {\tt auto} that is not recursive and - tries only hints which cost 0. Typically it solves trivial - equalities like $X=X$. +%% \item +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ +%% These are deprecated syntactic variants for +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. -\item \texttt{trivial with \ident$_1$ \dots\ \ident$_n$} +\item \texttt{Print Rewrite HintDb {\ident}} -\item \texttt{trivial with *} + This command displays all rewrite hints contained in {\ident}. \end{Variants} -\Rem {\tt auto} either solves completely the goal or else leaves it -intact. \texttt{auto} and \texttt{trivial} never fail. +\subsection{Hints and sections +\label{Hint-and-Section}} -\SeeAlso Section~\ref{Hints-databases} +Hints provided by the \texttt{Hint} commands are erased when closing a +section. Conversely, all hints of a module \texttt{A} that are not +defined inside a section (and not defined with option {\tt Local}) become +available when the module {\tt A} is imported (using +e.g. \texttt{Require Import A.}). -\subsection{\tt eauto -\tacindex{eauto} -\label{eauto}} +\subsection{Setting implicit automation tactics} -This tactic generalizes {\tt auto}. In contrast with -the latter, {\tt eauto} uses unification of the goal -against the hints rather than pattern-matching -(in other words, it uses {\tt eapply} instead of -{\tt apply}). -As a consequence, {\tt eauto} can solve such a goal: +\subsubsection[\tt Proof with {\tac}.]{\tt Proof with {\tac}.\label{ProofWith} +\comindex{Proof with}} -\begin{coq_example} -Hint Resolve ex_intro. -Goal forall P:nat -> Prop, P 0 -> exists n, P n. -eauto. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} + This command may be used to start a proof. It defines a default + tactic to be used each time a tactic command {\tac$_1$} is ended by + ``\verb#...#''. In this case the tactic command typed by the user is + equivalent to \tac$_1$;{\tac}. -Note that {\tt ex\_intro} should be declared as an -hint. +\SeeAlso {\tt Proof.} in Section~\ref{BeginProof}. -\SeeAlso Section~\ref{Hints-databases} +\begin{Variants} +\item {\tt Proof with {\tac} using {\ident$_1$ \dots {\ident$_n$}}} + Combines in a single line {\tt Proof with} and {\tt Proof using}, + see~\ref{ProofUsing} +\item {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}} + Combines in a single line {\tt Proof with} and {\tt Proof using}, + see~\ref{ProofUsing} -\subsection{\tt autounfold with \ident$_1$ \dots\ \ident$_n$ -\tacindex{autounfold} -\label{autounfold}} +\end{Variants} -This tactic unfolds constants that were declared through a {\tt Hint - Unfold} in the given databases. +\subsubsection[\tt Declare Implicit Tactic {\tac}.]{\tt Declare Implicit Tactic {\tac}.\comindex{Declare Implicit Tactic}} + +This command declares a tactic to be used to solve implicit arguments +that {\Coq} does not know how to solve by unification. It is used +every time the term argument of a tactic has one of its holes not +fully resolved. -\begin{Variants} -\item {\tt autounfold with \ident$_1$ \dots\ \ident$_n$ in \textit{clause}} - - Perform the unfolding in the given clause. +Here is an example: -\item {\tt autounfold with *} - - Uses the unfold hints declared in all the hint databases. -\end{Variants} +\begin{coq_example} +Parameter quo : nat -> forall n:nat, n<>0 -> nat. +Notation "x // y" := (quo x y _) (at level 40). +Declare Implicit Tactic assumption. +Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. +intros. +exists (n // m). +\end{coq_example} -% EXISTE ENCORE ? -% -% \subsection{\tt Prolog [ \term$_1$ \dots\ \term$_n$ ] \num} -% \tacindex{Prolog}\label{Prolog} -% This tactic, implemented by Chet Murthy, is based upon the concept of -% existential variables of Gilles Dowek, stating that resolution is a -% kind of unification. It tries to solve the current goal using the {\tt -% Assumption} tactic, the {\tt intro} tactic, and applying hypotheses -% of the local context and terms of the given list {\tt [ \term$_1$ -% \dots\ \term$_n$\ ]}. It is more powerful than {\tt auto} since it -% may apply to any theorem, even those of the form {\tt (x:A)(P x) -> Q} -% where {\tt x} does not appear free in {\tt Q}. The maximal search -% depth is {\tt \num}. +The tactic {\tt exists (n // m)} did not fail. The hole was solved by +{\tt assumption} so that it behaved as {\tt exists (quo n m H)}. -% \begin{ErrMsgs} -% \item \errindex{Prolog failed}\\ -% The Prolog tactic was not able to prove the subgoal. -% \end{ErrMsgs} +\section{Decision procedures} \subsection{\tt tauto \tacindex{tauto} @@ -3402,7 +3837,7 @@ instantiation of \verb=x= is necessary. The tactic \texttt{intuition} takes advantage of the search-tree built by the decision procedure involved in the tactic {\tt tauto}. It uses this information to generate a set of subgoals equivalent to the -original one (but simpler than it) and applies the tactic +original one (but simpler than it) and applies the tactic {\tac} to them \cite{Mun94}. If this tactic fails on some goals then {\tt intuition} fails. In fact, {\tt tauto} is simply {\tt intuition fail}. @@ -3438,17 +3873,17 @@ incompatibilities. \tacindex{rtauto} \label{rtauto}} -The {\tt rtauto} tactic solves propositional tautologies similarly to what {\tt tauto} does. The main difference is that the proof term is built using a reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. +The {\tt rtauto} tactic solves propositional tautologies similarly to what {\tt tauto} does. The main difference is that the proof term is built using a reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. -Users should be aware that this difference may result in faster proof-search but slower proof-checking, and {\tt rtauto} might not solve goals that {\tt tauto} would be able to solve (e.g. goals involving universal quantifiers). +Users should be aware that this difference may result in faster proof-search but slower proof-checking, and {\tt rtauto} might not solve goals that {\tt tauto} would be able to solve (e.g. goals involving universal quantifiers). \subsection{{\tt firstorder} \tacindex{firstorder} \label{firstorder}} The tactic \texttt{firstorder} is an {\it experimental} extension of -\texttt{tauto} to -first-order reasoning, written by Pierre Corbineau. +\texttt{tauto} to +first-order reasoning, written by Pierre Corbineau. It is not restricted to usual logical connectives but instead may reason about any first-order class inductive definition. @@ -3478,910 +3913,587 @@ instead may reason about any first-order class inductive definition. \end{Variants} Proof-search is bounded by a depth parameter which can be set by typing the -{\nobreak \tt Set Firstorder Depth $n$} \comindex{Set Firstorder Depth} +{\nobreak \tt Set Firstorder Depth $n$} \comindex{Set Firstorder Depth} vernacular command. -%% \subsection{{\tt jp} {\em (Jprover)} -%% \tacindex{jp} -%% \label{jprover}} - -%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an experimental -%% port of the {\em Jprover}\cite{SLKN01} semi-decision procedure for -%% first-order intuitionistic logic implemented in {\em -%% NuPRL}\cite{Kre02}. - -%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an {\it -%% experimental} port of the {\em Jprover}\cite{SLKN01} semi-decision -%% procedure for first-order intuitionistic logic implemented in {\em -%% NuPRL}\cite{Kre02}. - -%% Search may optionnaly be bounded by a multiplicity parameter -%% indicating how many (at most) copies of a formula may be used in -%% the proof process, its absence may lead to non-termination of the tactic. - -%% %\begin{coq_eval} -%% %Variable S:Set. -%% %Variables P Q:S->Prop. -%% %Variable f:S->S. -%% %\end{coq_eval} - -%% %\begin{coq_example*} -%% %Lemma example: (exists x |P x\/Q x)->(exists x |P x)\/(exists x |Q x). -%% %jp. -%% %Qed. - -%% %Lemma example2: (forall x ,P x->P (f x))->forall x,P x->P (f(f x)). -%% %jp. -%% %Qed. -%% %\end{coq_example*} - -%% \begin{Variants} -%% \item {\tt jp $n$}\\ -%% \tacindex{jp $n$} -%% Tries the {\em Jprover} procedure with multiplicities up to $n$, -%% starting from 1. -%% \item {\tt jp}\\ -%% Tries the {\em Jprover} procedure without multiplicity bound, -%% possibly running forever. -%% \end{Variants} - -%% \begin{ErrMsgs} -%% \item \errindex{multiplicity limit reached}\\ -%% The procedure tried all multiplicities below the limit and -%% failed. Goal might be solved by increasing the multiplicity limit. -%% \item \errindex{formula is not provable}\\ -%% The procedure determined that goal was not provable in -%% intuitionistic first-order logic, no matter how big the -%% multiplicity is. -%% \end{ErrMsgs} - - -% \subsection[\tt Linear]{\tt Linear\tacindex{Linear}\label{Linear}} -% The tactic \texttt{Linear}, due to Jean-Christophe Filli{\^a}atre -% \cite{Fil94}, implements a decision procedure for {\em Direct -% Predicate Calculus}, that is first-order Gentzen's Sequent Calculus -% without contraction rules \cite{KeWe84,BeKe92}. Intuitively, a -% first-order goal is provable in Direct Predicate Calculus if it can be -% proved using each hypothesis at most once. - -% Unlike the previous tactics, the \texttt{Linear} tactic does not belong -% to the initial state of the system, and it must be loaded explicitly -% with the command - -% \begin{coq_example*} -% Require Linear. -% \end{coq_example*} - -% For instance, assuming that \texttt{even} and \texttt{odd} are two -% predicates on natural numbers, and \texttt{a} of type \texttt{nat}, the -% tactic \texttt{Linear} solves the following goal - -% \begin{coq_eval} -% Variables even,odd : nat -> Prop. -% Variable a:nat. -% \end{coq_eval} - -% \begin{coq_example*} -% Lemma example : (even a) -% -> ((x:nat)((even x)->(odd (S x)))) -% -> (EX y | (odd y)). -% \end{coq_example*} - -% You can find examples of the use of \texttt{Linear} in -% \texttt{theories/DEMOS/DemoLinear.v}. -% \begin{coq_eval} -% Abort. -% \end{coq_eval} - -% \begin{Variants} -% \item {\tt Linear with \ident$_1$ \dots\ \ident$_n$}\\ -% \tacindex{Linear with} -% Is equivalent to apply first {\tt generalize \ident$_1$ \dots -% \ident$_n$} (see Section~\ref{generalize}) then the \texttt{Linear} -% tactic. So one can use axioms, lemmas or hypotheses of the local -% context with \texttt{Linear} in this way. -% \end{Variants} - -% \begin{ErrMsgs} -% \item \errindex{Not provable in Direct Predicate Calculus} -% \item \errindex{Found $n$ classical proof(s) but no intuitionistic one}\\ -% The decision procedure looks actually for classical proofs of the -% goals, and then checks that they are intuitionistic. In that case, -% classical proofs have been found, which do not correspond to -% intuitionistic ones. -% \end{ErrMsgs} \subsection{\tt congruence -\tacindex{congruence} -\label{congruence}} - -The tactic {\tt congruence}, by Pierre Corbineau, implements the standard Nelson and Oppen -congruence closure algorithm, which is a decision procedure for ground -equalities with uninterpreted symbols. It also include the constructor theory -(see \ref{injection} and \ref{discriminate}). -If the goal is a non-quantified equality, {\tt congruence} tries to -prove it with non-quantified equalities in the context. Otherwise it -tries to infer a discriminable equality from those in the context. Alternatively, congruence tries to prove that a hypothesis is equal to the goal or to the negation of another hypothesis. - -{\tt congruence} is also able to take advantage of hypotheses stating quantified equalities, you have to provide a bound for the number of extra equalities generated that way. Please note that one of the members of the equality must contain all the quantified variables in order for {\tt congruence} to match against it. - -\begin{coq_eval} -Reset Initial. -Variable A:Set. -Variables a b:A. -Variable f:A->A. -Variable g:A->A->A. -\end{coq_eval} - -\begin{coq_example} -Theorem T: - a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. -intros. -congruence. -\end{coq_example} - -\begin{coq_eval} -Reset Initial. -Variable A:Set. -Variables a c d:A. -Variable f:A->A*A. -\end{coq_eval} - -\begin{coq_example} -Theorem inj : f = pair a -> Some (f c) = Some (f d) -> c=d. -intros. -congruence. -\end{coq_example} - -\begin{Variants} - \item {\tt congruence {\sl n}}\\ - Tries to add at most {\tt \sl n} instances of hypotheses stating quantified equalities to the problem in order to solve it. A bigger value of {\tt \sl n} does not make success slower, only failure. You might consider adding some lemmas as hypotheses using {\tt assert} in order for congruence to use them. - -\end{Variants} - -\begin{Variants} -\item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\ - Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by - {\tt congruence}. This helps in case you have partially applied - constructors in your goal. -\end{Variants} - -\begin{ErrMsgs} - \item \errindex{I don't know how to handle dependent equality} \\ - The decision procedure managed to find a proof of the goal or of - a discriminable equality but this proof couldn't be built in {\Coq} - because of dependently-typed functions. - \item \errindex{I couldn't solve goal} \\ - The decision procedure didn't find any way to solve the goal. - \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\ - The decision procedure could solve the goal with the provision - that additional arguments are supplied for some partially applied - constructors. Any term of an appropriate type will allow the - tactic to successfully solve the goal. Those additional arguments - can be given to {\tt congruence} by filling in the holes in the - terms given in the error message, using the {\tt with} variant - described above. -\end{ErrMsgs} - -\subsection{\tt omega -\tacindex{omega} -\label{omega}} - -The tactic \texttt{omega}, due to Pierre Cr{\'e}gut, -is an automatic decision procedure for Presburger -arithmetic. It solves quantifier-free -formulas built with \verb|~|, \verb|\/|, \verb|/\|, -\verb|->| on top of equalities, inequalities and disequalities on -both the type \texttt{nat} of natural numbers and \texttt{Z} of binary -integers. This tactic must be loaded by the command \texttt{Require Import - Omega}. See the additional documentation about \texttt{omega} -(see Chapter~\ref{OmegaChapter}). - -\subsection{{\tt ring} and {\tt ring\_simplify \term$_1$ \dots\ \term$_n$} -\tacindex{ring} -\tacindex{ring\_simplify} -\comindex{Add Ring}} - -The {\tt ring} tactic solves equations upon polynomial expressions of -a ring (or semi-ring) structure. It proceeds by normalizing both hand -sides of the equation (w.r.t. associativity, commutativity and -distributivity, constant propagation) and comparing syntactically the -results. - -{\tt ring\_simplify} applies the normalization procedure described -above to the terms given. The tactic then replaces all occurrences of -the terms given in the conclusion of the goal by their normal -forms. If no term is given, then the conclusion should be an equation -and both hand sides are normalized. - -See Chapter~\ref{ring} for more information on the tactic and how to -declare new ring structures. - -\subsection{{\tt field}, {\tt field\_simplify \term$_1$\dots\ \term$_n$} - and {\tt field\_simplify\_eq} -\tacindex{field} -\tacindex{field\_simplify} -\tacindex{field\_simplify\_eq} -\comindex{Add Field}} - -The {\tt field} tactic is built on the same ideas as {\tt ring}: this -is a reflexive tactic that solves or simplifies equations in a field -structure. The main idea is to reduce a field expression (which is an -extension of ring expressions with the inverse and division -operations) to a fraction made of two polynomial expressions. - -Tactic {\tt field} is used to solve subgoals, whereas {\tt - field\_simplify \term$_1$\dots\term$_n$} replaces the provided terms -by their reduced fraction. {\tt field\_simplify\_eq} applies when the -conclusion is an equation: it simplifies both hand sides and multiplies -so as to cancel denominators. So it produces an equation without -division nor inverse. +\tacindex{congruence} +\label{congruence}} -All of these 3 tactics may generate a subgoal in order to prove that -denominators are different from zero. +The tactic {\tt congruence}, by Pierre Corbineau, implements the standard Nelson and Oppen +congruence closure algorithm, which is a decision procedure for ground +equalities with uninterpreted symbols. It also include the constructor theory +(see \ref{injection} and \ref{discriminate}). +If the goal is a non-quantified equality, {\tt congruence} tries to +prove it with non-quantified equalities in the context. Otherwise it +tries to infer a discriminable equality from those in the context. Alternatively, congruence tries to prove that a hypothesis is equal to the goal or to the negation of another hypothesis. -See Chapter~\ref{ring} for more information on the tactic and how to -declare new field structures. +{\tt congruence} is also able to take advantage of hypotheses stating quantified equalities, you have to provide a bound for the number of extra equalities generated that way. Please note that one of the members of the equality must contain all the quantified variables in order for {\tt congruence} to match against it. -\Example -\begin{coq_example*} -Require Import Reals. -Goal forall x y:R, - (x * y > 0)%R -> - (x * (1 / x + x / (x + y)))%R = - ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. -\end{coq_example*} +\begin{coq_eval} +Reset Initial. +Variable A:Set. +Variables a b:A. +Variable f:A->A. +Variable g:A->A->A. +\end{coq_eval} \begin{coq_example} -intros; field. +Theorem T: + a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. +intros. +congruence. \end{coq_example} \begin{coq_eval} Reset Initial. +Variable A:Set. +Variables a c d:A. +Variable f:A->A*A. \end{coq_eval} -\SeeAlso file {\tt plugins/setoid\_ring/RealField.v} for an example of instantiation,\\ -\phantom{\SeeAlso}theory {\tt theories/Reals} for many examples of use of {\tt -field}. +\begin{coq_example} +Theorem inj : f = pair a -> Some (f c) = Some (f d) -> c=d. +intros. +congruence. +\end{coq_example} -\subsection{\tt fourier -\tacindex{fourier}} +\begin{Variants} + \item {\tt congruence {\sl n}}\\ + Tries to add at most {\tt \sl n} instances of hypotheses stating quantified equalities to the problem in order to solve it. A bigger value of {\tt \sl n} does not make success slower, only failure. You might consider adding some lemmas as hypotheses using {\tt assert} in order for congruence to use them. -This tactic written by Lo{\"\i}c Pottier solves linear inequalities on -real numbers using Fourier's method~\cite{Fourier}. This tactic must -be loaded by {\tt Require Import Fourier}. +\end{Variants} -\Example -\begin{coq_example*} -Require Import Reals. -Require Import Fourier. -Goal forall x y:R, (x < y)%R -> (y + 1 >= x - 1)%R. -\end{coq_example*} +\begin{Variants} +\item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\ + Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by + {\tt congruence}. This helps in case you have partially applied + constructors in your goal. +\end{Variants} -\begin{coq_example} -intros; fourier. -\end{coq_example} +\begin{ErrMsgs} + \item \errindex{I don't know how to handle dependent equality} \\ + The decision procedure managed to find a proof of the goal or of + a discriminable equality but this proof couldn't be built in {\Coq} + because of dependently-typed functions. + \item \errindex{I couldn't solve goal} \\ + The decision procedure didn't find any way to solve the goal. + \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\ + The decision procedure could solve the goal with the provision + that additional arguments are supplied for some partially applied + constructors. Any term of an appropriate type will allow the + tactic to successfully solve the goal. Those additional arguments + can be given to {\tt congruence} by filling in the holes in the + terms given in the error message, using the {\tt with} variant + described above. +\end{ErrMsgs} -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\subsection{\tt autorewrite with \ident$_1$ \dots \ident$_n$. -\label{tactic:autorewrite} -\tacindex{autorewrite}} +\section{Things that do not fit other sections} -This tactic \footnote{The behavior of this tactic has much changed compared to -the versions available in the previous distributions (V6). This may cause -significant changes in your theories to obtain the same result. As a drawback -of the re-engineering of the code, this tactic has also been completely revised -to get a very compact and readable version.} carries out rewritings according -the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}. -Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until -it fails. Once all the rules have been processed, if the main subgoal has -progressed (e.g., if it is distinct from the initial main goal) then the rules -of this base are processed again. If the main subgoal has not progressed then -the next base is processed. For the bases, the behavior is exactly similar to -the processing of the rewriting rules. -The rewriting rule bases are built with the {\tt Hint~Rewrite} vernacular -command. -\Warning{} This tactic may loop if you build non terminating rewriting systems. -\begin{Variant} -\item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\ -Performs, in the same way, all the rewritings of the bases {\tt \ident$_1$ $...$ -\ident$_n$} applying {\tt \tac} to the main subgoal after each rewriting step. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid}} - Performs all the rewritings in hypothesis {\qualid}. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid} using \tac} - Performs all the rewritings in hypothesis {\qualid} applying {\tt - \tac} to the main subgoal after each rewriting step. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in \textit{clause}} - Performs all the rewritings in the clause \textit{clause}. \\ - The \textit{clause} argument must not contain any \texttt{type of} nor \texttt{value of}. -\end{Variant} -\SeeAlso Section~\ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}. -\SeeAlso Section~\ref{autorewrite-example} for examples showing the use of -this tactic. -% En attente d'un moyen de valoriser les fichiers de demos -%\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} -\section{Controlling automation} -\subsection{The hints databases for {\tt auto} and {\tt eauto} -\index{Hints databases} -\label{Hints-databases} -\comindex{Hint}} -The hints for \texttt{auto} and \texttt{eauto} are stored in -databases. Each database maps head symbols to a list of hints. One can -use the command \texttt{Print Hint \ident} to display the hints -associated to the head symbol \ident{} (see \ref{PrintHint}). Each -hint has a cost that is an nonnegative integer, and an optional pattern. -The hints with lower cost are tried first. A hint is tried by -\texttt{auto} when the conclusion of the current goal -matches its pattern or when it has no pattern. -\subsubsection*{Creating Hint databases - \label{CreateHintDb}\comindex{CreateHintDb}} -One can optionally declare a hint database using the command -\texttt{Create HintDb}. If a hint is added to an unknown database, it -will be automatically created. -\medskip -\texttt{Create HintDb} {\ident} [\texttt{discriminated}] -\medskip -This command creates a new database named \ident. -The database is implemented by a Discrimination Tree (DT) that serves as -an index of all the lemmas. The DT can use transparency information to decide -if a constant should be indexed or not (c.f. \ref{HintTransparency}), -making the retrieval more efficient. -The legacy implementation (the default one for new databases) uses the -DT only on goals without existentials (i.e., auto goals), for non-Immediate -hints and do not make use of transparency hints, putting more work on the -unification that is run after retrieval (it keeps a list of the lemmas -in case the DT is not used). The new implementation enabled by -the {\tt discriminated} option makes use of DTs in all cases and takes -transparency information into account. However, the order in which hints -are retrieved from the DT may differ from the order in which they were -inserted, making this implementation observationaly different from the -legacy one. -\begin{Variants} -\item\texttt{Local Hint} \textsl{hint\_definition} \texttt{:} - \ident$_1$ \ldots\ \ident$_n$ - - This is used to declare a hint database that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. -\end{Variants} -The general -command to add a hint to some database \ident$_1$, \dots, \ident$_n$ is: -\begin{tabbing} - \texttt{Hint} \textsl{hint\_definition} \texttt{:} \ident$_1$ \ldots\ \ident$_n$ -\end{tabbing} -where {\sl hint\_definition} is one of the following expressions: -\begin{itemize} -\item \texttt{Resolve} {\term} - \comindex{Hint Resolve} - - This command adds {\tt apply {\term}} to the hint list - with the head symbol of the type of \term. The cost of that hint is - the number of subgoals generated by {\tt apply {\term}}. - - In case the inferred type of \term\ does not start with a product the - tactic added in the hint list is {\tt exact {\term}}. In case this - type can be reduced to a type starting with a product, the tactic {\tt - apply {\term}} is also stored in the hints list. - - If the inferred type of \term\ contains a dependent - quantification on a predicate, it is added to the hint list of {\tt - eapply} instead of the hint list of {\tt apply}. In this case, a - warning is printed since the hint is only used by the tactic {\tt - eauto} (see \ref{eauto}). A typical example of a hint that is used - only by \texttt{eauto} is a transitivity lemma. - \begin{ErrMsgs} - \item \errindex{Bound head variable} - The head symbol of the type of {\term} is a bound variable such - that this tactic cannot be associated to a constant. - \item \term\ \errindex{cannot be used as a hint} - The type of \term\ contains products over variables which do not - appear in the conclusion. A typical example is a transitivity axiom. - In that case the {\tt apply} tactic fails, and thus is useless. - \end{ErrMsgs} - \begin{Variants} - \item \texttt{Resolve} {\term$_1$} \dots {\term$_m$} - Adds each \texttt{Resolve} {\term$_i$}. - \end{Variants} -\item \texttt{Immediate {\term}} -\comindex{Hint Immediate} - - This command adds {\tt apply {\term}; trivial} to the hint list - associated with the head symbol of the type of {\ident} in the given - database. This tactic will fail if all the subgoals generated by - {\tt apply {\term}} are not solved immediately by the {\tt trivial} - tactic (which only tries tactics with cost $0$). - - This command is useful for theorems such as the symmetry of equality - or $n+1=m+1 \to n=m$ that we may like to introduce with a - limited use in order to avoid useless proof-search. - - The cost of this tactic (which never generates subgoals) is always 1, - so that it is not used by {\tt trivial} itself. - \begin{ErrMsgs} - \item \errindex{Bound head variable} - \item \term\ \errindex{cannot be used as a hint} +\section{Everything after this point has yet to be sorted} - \end{ErrMsgs} - \begin{Variants} +\subsection{\tt constr\_eq \term$_1$ \term$_2$ +\tacindex{constr\_eq} +\label{constreq}} - \item \texttt{Immediate} {\term$_1$} \dots {\term$_m$} +This tactic applies to any goal. It checks whether its arguments are +equal modulo alpha conversion and casts. - Adds each \texttt{Immediate} {\term$_i$}. +\ErrMsg \errindex{Not equal} - \end{Variants} +\subsection{\tt unify \term$_1$ \term$_2$ +\tacindex{unify} +\label{unify}} -\item \texttt{Constructors} {\ident} -\comindex{Hint Constructors} - - If {\ident} is an inductive type, this command adds all its - constructors as hints of type \texttt{Resolve}. Then, when the - conclusion of current goal has the form \texttt{({\ident} \dots)}, - \texttt{auto} will try to apply each constructor. +This tactic applies to any goal. It checks whether its arguments are +unifiable, potentially instantiating existential variables. - \begin{ErrMsgs} +\ErrMsg \errindex{Not unifiable} - \item {\ident} \errindex{is not an inductive type} +\begin{Variants} +\item {\tt unify \term$_1$ \term$_2$ with \ident} - \item {\ident} \errindex{not declared} + Unification takes the transparency information defined in the + hint database {\tt \ident} into account (see Section~\ref{HintTransparency}). +\end{Variants} - \end{ErrMsgs} +\subsection{\tt is\_evar \term +\tacindex{is\_evar} +\label{isevar}} - \begin{Variants} +This tactic applies to any goal. It checks whether its argument is an +existential variable. Existential variables are uninstantiated +variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). - \item \texttt{Constructors} {\ident$_1$} \dots {\ident$_m$} +\ErrMsg \errindex{Not an evar} - Adds each \texttt{Constructors} {\ident$_i$}. +\subsection{\tt has\_evar \term +\tacindex{has\_evar} +\label{hasevar}} - \end{Variants} +This tactic applies to any goal. It checks whether its argument has an +existential variable as a subterm. Unlike {\tt context} patterns +combined with {\tt is\_evar}, this tactic scans all subterms, +including those under binders. -\item \texttt{Unfold} {\qualid} -\comindex{Hint Unfold} - - This adds the tactic {\tt unfold {\qualid}} to the hint list that - will only be used when the head constant of the goal is \ident. Its - cost is 4. +\ErrMsg \errindex{No evars} + +\subsection{\tt is\_var \term +\tacindex{is\_var} +\label{isvar}} - \begin{Variants} +This tactic applies to any goal. It checks whether its argument is a +variable or hypothesis in the current goal context or in the opened sections. - \item \texttt{Unfold} {\ident$_1$} \dots {\ident$_m$} +\ErrMsg \errindex{Not a variable or hypothesis} - Adds each \texttt{Unfold} {\ident$_i$}. +\section{Equality} - \end{Variants} +\subsection{\tt f\_equal +\label{f-equal} +\tacindex{f\_equal}} -\item \texttt{Transparent}, \texttt{Opaque} {\qualid} -\label{HintTransparency} -\comindex{Hint Transparent} -\comindex{Hint Opaque} - - This adds a transparency hint to the database, making {\tt {\qualid}} - a transparent or opaque constant during resolution. This information - is used during unification of the goal with any lemma in the database - and inside the discrimination network to relax or constrain it in the - case of \texttt{discriminated} databases. - - \begin{Variants} +This tactic applies to a goal of the form $f\ a_1\ \ldots\ a_n = f'\ +a'_1\ \ldots\ a'_n$. Using {\tt f\_equal} on such a goal leads to +subgoals $f=f'$ and $a_1=a'_1$ and so on up to $a_n=a'_n$. Amongst +these subgoals, the simple ones (e.g. provable by +reflexivity or congruence) are automatically solved by {\tt f\_equal}. - \item \texttt{Transparent}, \texttt{Opaque} {\ident$_1$} \dots {\ident$_m$} - Declares each {\ident$_i$} as a transparent or opaque constant. - - \end{Variants} +\section{Equality and inductive sets} -\item \texttt{Extern \num\ [\pattern]\ => }\textsl{tactic} -\comindex{Hint Extern} +We describe in this section some special purpose tactics dealing with +equality and inductive sets or types. These tactics use the equality +{\tt eq:forall (A:Type), A->A->Prop}, simply written with the +infix symbol {\tt =}. - This hint type is to extend \texttt{auto} with tactics other than - \texttt{apply} and \texttt{unfold}. For that, we must specify a - cost, an optional pattern and a tactic to execute. Here is an example: +\subsection{\tt decide equality +\label{decideequality} +\tacindex{decide equality}} -\begin{quotation} -\begin{verbatim} -Hint Extern 4 (~(_ = _)) => discriminate. -\end{verbatim} -\end{quotation} +This tactic solves a goal of the form +{\tt forall $x$ $y$:$R$, \{$x$=$y$\}+\{\verb|~|$x$=$y$\}}, where $R$ +is an inductive type such that its constructors do not take proofs or +functions as arguments, nor objects in dependent types. +It solves goals of the form {\tt \{$x$=$y$\}+\{\verb|~|$x$=$y$\}} as well. - Now, when the head of the goal is a disequality, \texttt{auto} will - try \texttt{discriminate} if it does not manage to solve the goal - with hints with a cost less than 4. - - One can even use some sub-patterns of the pattern in the tactic - script. A sub-pattern is a question mark followed by an ident, like - \texttt{?X1} or \texttt{?X2}. Here is an example: +\subsection{\tt compare \term$_1$ \term$_2$ +\tacindex{compare}} -% Require EqDecide. -\begin{coq_example*} -Require Import List. -\end{coq_example*} -\begin{coq_example} -Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => - generalize X1, X2; decide equality : eqdec. -Goal -forall a b:list (nat * nat), {a = b} + {a <> b}. -info auto with eqdec. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} +This tactic compares two given objects \term$_1$ and \term$_2$ +of an inductive datatype. If $G$ is the current goal, it leaves the sub-goals +\term$_1${\tt =}\term$_2$ {\tt ->} $G$ and \verb|~|\term$_1${\tt =}\term$_2$ +{\tt ->} $G$. The type +of \term$_1$ and \term$_2$ must satisfy the same restrictions as in the tactic +\texttt{decide equality}. -\end{itemize} +\subsection{\tt simplify\_eq {\term} +\tacindex{simplify\_eq} +\tacindex{esimplify\_eq} +\label{simplify-eq}} -\Rem One can use an \texttt{Extern} hint with no pattern to do -pattern-matching on hypotheses using \texttt{match goal with} inside -the tactic. +Let {\term} be the proof of a statement of conclusion {\tt + {\term$_1$}={\term$_2$}}. If {\term$_1$} and +{\term$_2$} are structurally different (in the sense described for the +tactic {\tt discriminate}), then the tactic {\tt simplify\_eq} behaves as {\tt + discriminate {\term}}, otherwise it behaves as {\tt injection + {\term}}. + +\Rem If some quantified hypothesis of the goal is named {\ident}, then +{\tt simplify\_eq {\ident}} first introduces the hypothesis in the local +context using \texttt{intros until \ident}. \begin{Variants} -\item \texttt{Hint} \textsl{hint\_definition} - - No database name is given: the hint is registered in the {\tt core} - database. +\item \texttt{simplify\_eq} \num -\item\texttt{Hint Local} \textsl{hint\_definition} \texttt{:} - \ident$_1$ \ldots\ \ident$_n$ + This does the same thing as \texttt{intros until \num} then +\texttt{simplify\_eq \ident} where {\ident} is the identifier for the last +introduced hypothesis. - This is used to declare hints that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. +\item \texttt{simplify\_eq} \term{} {\tt with} {\bindinglist} + + This does the same as \texttt{simplify\_eq {\term}} but using + the given bindings to instantiate parameters or hypotheses of {\term}. -\item\texttt{Hint Local} \textsl{hint\_definition} +\item \texttt{esimplify\_eq} \num\\ + \texttt{esimplify\_eq} \term{} \zeroone{{\tt with} {\bindinglist}} - Idem for the {\tt core} database. - + This works the same as {\tt simplify\_eq} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. + +\item{\tt simplify\_eq} + +If the current goal has form $t_1\verb=<>=t_2$, it behaves as +\texttt{intro {\ident}; simplify\_eq {\ident}}. \end{Variants} -% There are shortcuts that allow to define several goal at once: +\subsection{\tt dependent rewrite -> {\ident} +\tacindex{dependent rewrite ->} +\label{dependent-rewrite}} -% \begin{itemize} -% \item \comindex{Hints Resolve}\texttt{Hints Resolve \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ -% This command is a shortcut for the following ones: -% \begin{quotation} -% \noindent\texttt{Hint \ident$_1$ : \ident\ := Resolve \ident$_1$}\\ -% \dots\\ -% \texttt{Hint \ident$_1$ : \ident := Resolve \ident$_1$} -% \end{quotation} -% Notice that the hint name is the same that the theorem given as -% hint. -% \item \comindex{Hints Immediate}\texttt{Hints Immediate \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ -% \item \comindex{Hints Unfold}\texttt{Hints Unfold \qualid$_1$ \dots\ \qualid$_n$ : \ident.}\\ -% \end{itemize} +This tactic applies to any goal. If \ident\ has type +\verb+(existT B a b)=(existT B a' b')+ +in the local context (i.e. each term of the +equality has a sigma type $\{ a:A~ \&~(B~a)\}$) this tactic rewrites +\verb+a+ into \verb+a'+ and \verb+b+ into \verb+b'+ in the current +goal. This tactic works even if $B$ is also a sigma type. This kind +of equalities between dependent pairs may be derived by the injection +and inversion tactics. -%\begin{Warnings} -% \item \texttt{Overriding hint named \dots\ in database \dots} -%\end{Warnings} +\begin{Variants} +\item{\tt dependent rewrite <- {\ident}} +\tacindex{dependent rewrite <-} \\ +Analogous to {\tt dependent rewrite ->} but uses the equality from +right to left. +\end{Variants} +\section{Inversion +\label{inversion}} +\subsection[\tt functional inversion \ident]{\tt functional inversion \ident\label{sec:functional-inversion}} -\subsection{Hint databases defined in the \Coq\ standard library} +\texttt{functional inversion} is a \emph{highly} experimental tactic +which performs inversion on hypothesis \ident\ of the form +\texttt{\qualid\ \term$_1$\dots\term$_n$\ = \term} or \texttt{\term\ = + \qualid\ \term$_1$\dots\term$_n$} where \qualid\ must have been +defined using \texttt{Function} (see Section~\ref{Function}). -Several hint databases are defined in the \Coq\ standard library. The -actual content of a database is the collection of the hints declared -to belong to this database in each of the various modules currently -loaded. Especially, requiring new modules potentially extend a -database. At {\Coq} startup, only the {\tt core} and {\tt v62} -databases are non empty and can be used. +\begin{ErrMsgs} +\item \errindex{Hypothesis {\ident} must contain at least one Function} +\item \errindex{Cannot find inversion information for hypothesis \ident} + This error may be raised when some inversion lemma failed to be + generated by Function. +\end{ErrMsgs} -\begin{description} +\begin{Variants} +\item {\tt functional inversion \num} -\item[\tt core] This special database is automatically used by - \texttt{auto}, except when pseudo-database \texttt{nocore} is - given to \texttt{auto}. The \texttt{core} database contains - only basic lemmas about negation, - conjunction, and so on from. Most of the hints in this database come - from the \texttt{Init} and \texttt{Logic} directories. + This does the same thing as \texttt{intros until \num} then + \texttt{functional inversion \ident} where {\ident} is the + identifier for the last introduced hypothesis. +\item {\tt functional inversion \ident\ \qualid}\\ + {\tt functional inversion \num\ \qualid} -\item[\tt arith] This database contains all lemmas about Peano's - arithmetic proved in the directories \texttt{Init} and - \texttt{Arith} + In case the hypothesis {\ident} (or {\num}) has a type of the form + \texttt{\qualid$_1$\ \term$_1$\dots\term$_n$\ =\ \qualid$_2$\ + \term$_{n+1}$\dots\term$_{n+m}$} where \qualid$_1$ and \qualid$_2$ + are valid candidates to functional inversion, this variant allows to + choose which must be inverted. +\end{Variants} -\item[\tt zarith] contains lemmas about binary signed integers from - the directories \texttt{theories/ZArith}. When required, the module - {\tt Omega} also extends the database {\tt zarith} with a high-cost - hint that calls {\tt omega} on equations and inequalities in {\tt - nat} or {\tt Z}. -\item[\tt bool] contains lemmas about booleans, mostly from directory - \texttt{theories/Bool}. -\item[\tt datatypes] is for lemmas about lists, streams and so on that - are mainly proved in the \texttt{Lists} subdirectory. +\subsection{\tt quote \ident +\tacindex{quote} +\index{2-level approach}} -\item[\tt sets] contains lemmas about sets and relations from the - directories \texttt{Sets} and \texttt{Relations}. +This kind of inversion has nothing to do with the tactic +\texttt{inversion} above. This tactic does \texttt{change (\ident\ + t)}, where \texttt{t} is a term built in order to ensure the +convertibility. In other words, it does inversion of the function +\ident. This function must be a fixpoint on a simple recursive +datatype: see~\ref{quote-examples} for the full details. -\item[\tt typeclass\_instances] contains all the type class instances - declared in the environment, including those used for \texttt{setoid\_rewrite}, - from the \texttt{Classes} directory. -\end{description} +\begin{ErrMsgs} +\item \errindex{quote: not a simple fixpoint}\\ + Happens when \texttt{quote} is not able to perform inversion properly. +\end{ErrMsgs} -There is also a special database called {\tt v62}. It collects all -hints that were declared in the versions of {\Coq} prior to version -6.2.4 when the databases {\tt core}, {\tt arith}, and so on were -introduced. The purpose of the database {\tt v62} is to ensure -compatibility with further versions of {\Coq} for developments done in -versions prior to 6.2.4 ({\tt auto} being replaced by {\tt auto with v62}). -The database {\tt v62} is intended not to be extended (!). It is not -included in the hint databases list used in the {\tt auto with *} tactic. +\begin{Variants} +\item \texttt{quote {\ident} [ \ident$_1$ \dots \ident$_n$ ]}\\ + All terms that are built only with \ident$_1$ \dots \ident$_n$ will be + considered by \texttt{quote} as constants rather than variables. +\end{Variants} -Furthermore, you are advised not to put your own hints in the -{\tt core} database, but use one or several databases specific to your -development. +% En attente d'un moyen de valoriser les fichiers de demos +% \SeeAlso file \texttt{theories/DEMOS/DemoQuote.v} in the distribution -\subsection{\tt Print Hint -\label{PrintHint} -\comindex{Print Hint}} +\section[Classical tactics]{Classical tactics\label{ClassicalTactics}} -This command displays all hints that apply to the current goal. It -fails if no proof is being edited, while the two variants can be used at -every moment. +In order to ease the proving process, when the {\tt Classical} module is loaded. A few more tactics are available. Make sure to load the module using the \texttt{Require Import} command. -\begin{Variants} +\subsection{{\tt classical\_left, classical\_right} \tacindex{classical\_left} \tacindex{classical\_right}} -\item {\tt Print Hint {\ident} } +The tactics \texttt{classical\_left} and \texttt{classical\_right} are the analog of the \texttt{left} and \texttt{right} but using classical logic. They can only be used for disjunctions. +Use \texttt{classical\_left} to prove the left part of the disjunction with the assumption that the negation of right part holds. +Use \texttt{classical\_right} to prove the right part of the disjunction with the assumption that the negation of left part holds. - This command displays only tactics associated with \ident\ in the - hints list. This is independent of the goal being edited, so this - command will not fail if no goal is being edited. +\section{Automatizing +\label{Automatizing}} -\item {\tt Print Hint *} +% EXISTE ENCORE ? +% +% \subsection{\tt Prolog [ \term$_1$ \dots\ \term$_n$ ] \num} +% \tacindex{Prolog}\label{Prolog} +% This tactic, implemented by Chet Murthy, is based upon the concept of +% existential variables of Gilles Dowek, stating that resolution is a +% kind of unification. It tries to solve the current goal using the {\tt +% Assumption} tactic, the {\tt intro} tactic, and applying hypotheses +% of the local context and terms of the given list {\tt [ \term$_1$ +% \dots\ \term$_n$\ ]}. It is more powerful than {\tt auto} since it +% may apply to any theorem, even those of the form {\tt (x:A)(P x) -> Q} +% where {\tt x} does not appear free in {\tt Q}. The maximal search +% depth is {\tt \num}. - This command displays all declared hints. +% \begin{ErrMsgs} +% \item \errindex{Prolog failed}\\ +% The Prolog tactic was not able to prove the subgoal. +% \end{ErrMsgs} -\item {\tt Print HintDb {\ident} } -\label{PrintHintDb} -\comindex{Print HintDb} - This command displays all hints from database \ident. +%% \subsection{{\tt jp} {\em (Jprover)} +%% \tacindex{jp} +%% \label{jprover}} -\end{Variants} +%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an experimental +%% port of the {\em Jprover}\cite{SLKN01} semi-decision procedure for +%% first-order intuitionistic logic implemented in {\em +%% NuPRL}\cite{Kre02}. -\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident -\label{HintRewrite} -\comindex{Hint Rewrite}} +%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an {\it +%% experimental} port of the {\em Jprover}\cite{SLKN01} semi-decision +%% procedure for first-order intuitionistic logic implemented in {\em +%% NuPRL}\cite{Kre02}. -This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} -(their types must be equalities) in the rewriting base {\tt \ident} -with the default orientation (left to right). Notice that the -rewriting bases are distinct from the {\tt auto} hint bases and that -{\tt auto} does not take them into account. +%% Search may optionnaly be bounded by a multiplicity parameter +%% indicating how many (at most) copies of a formula may be used in +%% the proof process, its absence may lead to non-termination of the tactic. -This command is synchronous with the section mechanism (see \ref{Section}): -when closing a section, all aliases created by \texttt{Hint Rewrite} in that -section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} -declarations at the global level of that module are loaded. +%% %\begin{coq_eval} +%% %Variable S:Set. +%% %Variables P Q:S->Prop. +%% %Variable f:S->S. +%% %\end{coq_eval} -\begin{Variants} -\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ -This is strictly equivalent to the command above (we only make explicit the -orientation which otherwise defaults to {\tt ->}). +%% %\begin{coq_example*} +%% %Lemma example: (exists x |P x\/Q x)->(exists x |P x)\/(exists x |Q x). +%% %jp. +%% %Qed. -\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ -Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left -orientation in the base {\tt \ident}. +%% %Lemma example2: (forall x ,P x->P (f x))->forall x,P x->P (f(f x)). +%% %jp. +%% %Qed. +%% %\end{coq_example*} -\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ -When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will -be used, the tactic {\tt \tac} will be applied to the generated subgoals, the -main subgoal excluded. +%% \begin{Variants} +%% \item {\tt jp $n$}\\ +%% \tacindex{jp $n$} +%% Tries the {\em Jprover} procedure with multiplicities up to $n$, +%% starting from 1. +%% \item {\tt jp}\\ +%% Tries the {\em Jprover} procedure without multiplicity bound, +%% possibly running forever. +%% \end{Variants} -%% \item -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ -%% These are deprecated syntactic variants for -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. +%% \begin{ErrMsgs} +%% \item \errindex{multiplicity limit reached}\\ +%% The procedure tried all multiplicities below the limit and +%% failed. Goal might be solved by increasing the multiplicity limit. +%% \item \errindex{formula is not provable}\\ +%% The procedure determined that goal was not provable in +%% intuitionistic first-order logic, no matter how big the +%% multiplicity is. +%% \end{ErrMsgs} -\item \texttt{Print Rewrite HintDb {\ident}} - This command displays all rewrite hints contained in {\ident}. +% \subsection[\tt Linear]{\tt Linear\tacindex{Linear}\label{Linear}} +% The tactic \texttt{Linear}, due to Jean-Christophe Filli{\^a}atre +% \cite{Fil94}, implements a decision procedure for {\em Direct +% Predicate Calculus}, that is first-order Gentzen's Sequent Calculus +% without contraction rules \cite{KeWe84,BeKe92}. Intuitively, a +% first-order goal is provable in Direct Predicate Calculus if it can be +% proved using each hypothesis at most once. -\end{Variants} +% Unlike the previous tactics, the \texttt{Linear} tactic does not belong +% to the initial state of the system, and it must be loaded explicitly +% with the command -\subsection{Hints and sections -\label{Hint-and-Section}} +% \begin{coq_example*} +% Require Linear. +% \end{coq_example*} -Hints provided by the \texttt{Hint} commands are erased when closing a -section. Conversely, all hints of a module \texttt{A} that are not -defined inside a section (and not defined with option {\tt Local}) become -available when the module {\tt A} is imported (using -e.g. \texttt{Require Import A.}). +% For instance, assuming that \texttt{even} and \texttt{odd} are two +% predicates on natural numbers, and \texttt{a} of type \texttt{nat}, the +% tactic \texttt{Linear} solves the following goal -\subsection{Setting implicit automation tactics} +% \begin{coq_eval} +% Variables even,odd : nat -> Prop. +% Variable a:nat. +% \end{coq_eval} -\subsubsection[\tt Proof with {\tac}.]{\tt Proof with {\tac}.\label{ProofWith} -\comindex{Proof with}} +% \begin{coq_example*} +% Lemma example : (even a) +% -> ((x:nat)((even x)->(odd (S x)))) +% -> (EX y | (odd y)). +% \end{coq_example*} - This command may be used to start a proof. It defines a default - tactic to be used each time a tactic command {\tac$_1$} is ended by - ``\verb#...#''. In this case the tactic command typed by the user is - equivalent to \tac$_1$;{\tac}. +% You can find examples of the use of \texttt{Linear} in +% \texttt{theories/DEMOS/DemoLinear.v}. +% \begin{coq_eval} +% Abort. +% \end{coq_eval} -\SeeAlso {\tt Proof.} in Section~\ref{BeginProof}. +% \begin{Variants} +% \item {\tt Linear with \ident$_1$ \dots\ \ident$_n$}\\ +% \tacindex{Linear with} +% Is equivalent to apply first {\tt generalize \ident$_1$ \dots +% \ident$_n$} (see Section~\ref{generalize}) then the \texttt{Linear} +% tactic. So one can use axioms, lemmas or hypotheses of the local +% context with \texttt{Linear} in this way. +% \end{Variants} -\begin{Variants} -\item {\tt Proof with {\tac} using {\ident$_1$ \dots {\ident$_n$}}} - Combines in a single line {\tt Proof with} and {\tt Proof using}, - see~\ref{ProofUsing} -\item {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}} - Combines in a single line {\tt Proof with} and {\tt Proof using}, - see~\ref{ProofUsing} +% \begin{ErrMsgs} +% \item \errindex{Not provable in Direct Predicate Calculus} +% \item \errindex{Found $n$ classical proof(s) but no intuitionistic one}\\ +% The decision procedure looks actually for classical proofs of the +% goals, and then checks that they are intuitionistic. In that case, +% classical proofs have been found, which do not correspond to +% intuitionistic ones. +% \end{ErrMsgs} -\end{Variants} -\subsubsection[\tt Declare Implicit Tactic {\tac}.]{\tt Declare Implicit Tactic {\tac}.\comindex{Declare Implicit Tactic}} +\subsection{\tt omega +\tacindex{omega} +\label{omega}} -This command declares a tactic to be used to solve implicit arguments -that {\Coq} does not know how to solve by unification. It is used -every time the term argument of a tactic has one of its holes not -fully resolved. +The tactic \texttt{omega}, due to Pierre Cr{\'e}gut, +is an automatic decision procedure for Presburger +arithmetic. It solves quantifier-free +formulas built with \verb|~|, \verb|\/|, \verb|/\|, +\verb|->| on top of equalities, inequalities and disequalities on +both the type \texttt{nat} of natural numbers and \texttt{Z} of binary +integers. This tactic must be loaded by the command \texttt{Require Import + Omega}. See the additional documentation about \texttt{omega} +(see Chapter~\ref{OmegaChapter}). -Here is an example: +\subsection{{\tt ring} and {\tt ring\_simplify \term$_1$ \dots\ \term$_n$} +\tacindex{ring} +\tacindex{ring\_simplify} +\comindex{Add Ring}} -\begin{coq_example} -Parameter quo : nat -> forall n:nat, n<>0 -> nat. -Notation "x // y" := (quo x y _) (at level 40). +The {\tt ring} tactic solves equations upon polynomial expressions of +a ring (or semi-ring) structure. It proceeds by normalizing both hand +sides of the equation (w.r.t. associativity, commutativity and +distributivity, constant propagation) and comparing syntactically the +results. -Declare Implicit Tactic assumption. -Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. -intros. -exists (n // m). -\end{coq_example} +{\tt ring\_simplify} applies the normalization procedure described +above to the terms given. The tactic then replaces all occurrences of +the terms given in the conclusion of the goal by their normal +forms. If no term is given, then the conclusion should be an equation +and both hand sides are normalized. -The tactic {\tt exists (n // m)} did not fail. The hole was solved by -{\tt assumption} so that it behaved as {\tt exists (quo n m H)}. +See Chapter~\ref{ring} for more information on the tactic and how to +declare new ring structures. -\section{Generation of induction principles with {\tt Scheme} -\label{Scheme} -\index{Schemes} -\comindex{Scheme}} +\subsection{{\tt field}, {\tt field\_simplify \term$_1$\dots\ \term$_n$} + and {\tt field\_simplify\_eq} +\tacindex{field} +\tacindex{field\_simplify} +\tacindex{field\_simplify\_eq} +\comindex{Add Field}} -The {\tt Scheme} command is a high-level tool for generating -automatically (possibly mutual) induction principles for given types -and sorts. Its syntax follows the schema: -\begin{quote} -{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\\ - with {\ident$_m$} := Induction for {\ident'$_m$} Sort - {\sort$_m$}} -\end{quote} -where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type -identifiers belonging to the same package of mutual inductive -definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$} -to be mutually recursive definitions. Each term {\ident$_i$} proves a -general principle of mutual induction for objects in type {\term$_i$}. +The {\tt field} tactic is built on the same ideas as {\tt ring}: this +is a reflexive tactic that solves or simplifies equations in a field +structure. The main idea is to reduce a field expression (which is an +extension of ring expressions with the inverse and division +operations) to a fraction made of two polynomial expressions. -\begin{Variants} -\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\ \\ - with {\ident$_m$} := Minimality for {\ident'$_m$} Sort - {\sort$_m$}} +Tactic {\tt field} is used to solve subgoals, whereas {\tt + field\_simplify \term$_1$\dots\term$_n$} replaces the provided terms +by their reduced fraction. {\tt field\_simplify\_eq} applies when the +conclusion is an equation: it simplifies both hand sides and multiplies +so as to cancel denominators. So it produces an equation without +division nor inverse. - Same as before but defines a non-dependent elimination principle more - natural in case of inductively defined relations. +All of these 3 tactics may generate a subgoal in order to prove that +denominators are different from zero. -\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}} +See Chapter~\ref{ring} for more information on the tactic and how to +declare new field structures. - Tries to generate a boolean equality and a proof of the - decidability of the usual equality. If \ident$_i$ involves - some other inductive types, their equality has to be defined first. +\Example +\begin{coq_example*} +Require Import Reals. +Goal forall x y:R, + (x * y > 0)%R -> + (x * (1 / x + x / (x + y)))%R = + ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. +\end{coq_example*} -\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\\ - with Induction for {\ident$_m$} Sort - {\sort$_m$}} +\begin{coq_example} +intros; field. +\end{coq_example} - If you do not provide the name of the schemes, they will be automatically - computed from the sorts involved (works also with Minimality). +\begin{coq_eval} +Reset Initial. +\end{coq_eval} -\end{Variants} +\SeeAlso file {\tt plugins/setoid\_ring/RealField.v} for an example of instantiation,\\ +\phantom{\SeeAlso}theory {\tt theories/Reals} for many examples of use of {\tt +field}. -\SeeAlso Section~\ref{Scheme-examples} - -\subsection{Automatic declaration of schemes} -\comindex{Set Equality Schemes} -\comindex{Set Elimination Schemes} -It is possible to deactivate the automatic declaration of the induction - principles when defining a new inductive type with the - {\tt Unset Elimination Schemes} command. It may be -reactivated at any time with {\tt Set Elimination Schemes}. -\\ - -You can also activate the automatic declaration of those boolean equalities -(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes} - command. However you have to be careful with this option since -\Coq~ may now reject well-defined inductive types because it cannot compute -a boolean equality for them. - -\subsection{\tt Combined Scheme\label{CombinedScheme} -\comindex{Combined Scheme}} -The {\tt Combined Scheme} command is a tool for combining -induction principles generated by the {\tt Scheme} command. -Its syntax follows the schema : - -\noindent -{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}}\\ -\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to -the same package of mutual inductive principle definitions. This command -generates {\ident$_0$} to be the conjunction of the principles: it is -built from the common premises of the principles and concluded by the -conjunction of their conclusions. - -\SeeAlso Section~\ref{CombinedScheme-examples} - -\section{Generation of induction principles with {\tt Functional Scheme} -\label{FunScheme} -\comindex{Functional Scheme}} - -The {\tt Functional Scheme} command is a high-level experimental -tool for generating automatically induction principles -corresponding to (possibly mutually recursive) functions. Its -syntax follows the schema: -\begin{quote} -{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\ \\ - with {\ident$_m$} := Induction for {\ident'$_m$} Sort - {\sort$_m$}} -\end{quote} -where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function -names (they must be in the same order as when they were defined). -This command generates the induction principles -\ident$_1$\dots\ident$_m$, following the recursive structure and case -analyses of the functions \ident'$_1$ \dots\ \ident'$_m$. +\subsection{\tt fourier +\tacindex{fourier}} +This tactic written by Lo{\"\i}c Pottier solves linear inequalities on +real numbers using Fourier's method~\cite{Fourier}. This tactic must +be loaded by {\tt Require Import Fourier}. -\paragraph{\texttt{Functional Scheme}} -There is a difference between obtaining an induction scheme by using -\texttt{Functional Scheme} on a function defined by \texttt{Function} -or not. Indeed \texttt{Function} generally produces smaller -principles, closer to the definition written by the user. +\Example +\begin{coq_example*} +Require Import Reals. +Require Import Fourier. +Goal forall x y:R, (x < y)%R -> (y + 1 >= x - 1)%R. +\end{coq_example*} +\begin{coq_example} +intros; fourier. +\end{coq_example} -\SeeAlso Section~\ref{FunScheme-examples} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} \section{Simple tactic macros @@ -4389,7 +4501,7 @@ principles, closer to the definition written by the user. \comindex{Tactic Definition} \label{TacticDefinition}} -A simple example has more value than a long explanation: +A simple example has more value than a long explanation: \begin{coq_example} Ltac Solve := simpl; intros; auto. @@ -4399,7 +4511,7 @@ Ltac ElimBoolRewrite b H1 H2 := The tactics macros are synchronous with the \Coq\ section mechanism: a tactic definition is deleted from the current environment -when you close the section (see also \ref{Section}) +when you close the section (see also \ref{Section}) where it was defined. If you want that a tactic macro defined in a module is usable in the modules that require it, you should put it outside of any section. @@ -4408,8 +4520,8 @@ Chapter~\ref{TacticLanguage} gives examples of more complex user-defined tactics. -%%% Local Variables: +%%% Local Variables: %%% mode: latex %%% TeX-master: "Reference-Manual" %%% TeX-master: "Reference-Manual" -%%% End: +%%% End: diff --git a/doc/refman/RefMan-tacex.tex b/doc/refman/RefMan-tacex.tex index 8330a434..83a8cd11 100644 --- a/doc/refman/RefMan-tacex.tex +++ b/doc/refman/RefMan-tacex.tex @@ -3,590 +3,6 @@ This chapter presents detailed examples of certain tactics, to illustrate their behavior. -\section[\tt refine]{\tt refine\tacindex{refine} -\label{refine-example}} - -This tactic applies to any goal. It behaves like {\tt exact} with a -big difference : the user can leave some holes (denoted by \texttt{\_} or -{\tt (\_:}{\it type}{\tt )}) in the term. -{\tt refine} will generate as many -subgoals as they are holes in the term. The type of holes must be -either synthesized by the system or declared by an -explicit cast like \verb|(\_:nat->Prop)|. This low-level -tactic can be useful to advanced users. - -%\firstexample -\Example - -\begin{coq_example*} -Inductive Option : Set := - | Fail : Option - | Ok : bool -> Option. -\end{coq_example} -\begin{coq_example} -Definition get : forall x:Option, x <> Fail -> bool. -refine - (fun x:Option => - match x return x <> Fail -> bool with - | Fail => _ - | Ok b => fun _ => b - end). -intros; absurd (Fail = Fail); trivial. -\end{coq_example} -\begin{coq_example*} -Defined. -\end{coq_example*} - -% \example{Using Refine to build a poor-man's ``Cases'' tactic} - -% \texttt{Refine} is actually the only way for the user to do -% a proof with the same structure as a {\tt Cases} definition. Actually, -% the tactics \texttt{case} (see \ref{case}) and \texttt{Elim} (see -% \ref{elim}) only allow one step of elementary induction. - -% \begin{coq_example*} -% Require Bool. -% Require Arith. -% \end{coq_example*} -% %\begin{coq_eval} -% %Abort. -% %\end{coq_eval} -% \begin{coq_example} -% Definition one_two_or_five := [x:nat] -% Cases x of -% (1) => true -% | (2) => true -% | (5) => true -% | _ => false -% end. -% Goal (x:nat)(Is_true (one_two_or_five x)) -> x=(1)\/x=(2)\/x=(5). -% \end{coq_example} - -% A traditional script would be the following: - -% \begin{coq_example*} -% Destruct x. -% Tauto. -% Destruct n. -% Auto. -% Destruct n0. -% Auto. -% Destruct n1. -% Tauto. -% Destruct n2. -% Tauto. -% Destruct n3. -% Auto. -% Intros; Inversion H. -% \end{coq_example*} - -% With the tactic \texttt{Refine}, it becomes quite shorter: - -% \begin{coq_example*} -% Restart. -% \end{coq_example*} -% \begin{coq_example} -% Refine [x:nat] -% <[y:nat](Is_true (one_two_or_five y))->(y=(1)\/y=(2)\/y=(5))> -% Cases x of -% (1) => [H]? -% | (2) => [H]? -% | (5) => [H]? -% | n => [H](False_ind ? H) -% end; Auto. -% \end{coq_example} -% \begin{coq_eval} -% Abort. -% \end{coq_eval} - -\section[\tt eapply]{\tt eapply\tacindex{eapply} -\label{eapply-example}} -\Example -Assume we have a relation on {\tt nat} which is transitive: - -\begin{coq_example*} -Variable R : nat -> nat -> Prop. -Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. -Variables n m p : nat. -Hypothesis Rnm : R n m. -Hypothesis Rmp : R m p. -\end{coq_example*} - -Consider the goal {\tt (R n p)} provable using the transitivity of -{\tt R}: - -\begin{coq_example*} -Goal R n p. -\end{coq_example*} - -The direct application of {\tt Rtrans} with {\tt apply} fails because -no value for {\tt y} in {\tt Rtrans} is found by {\tt apply}: - -\begin{coq_eval} -Set Printing Depth 50. -(********** The following is not correct and should produce **********) -(**** Error: generated subgoal (R n ?17) has metavariables in it *****) -\end{coq_eval} -\begin{coq_example} -apply Rtrans. -\end{coq_example} - -A solution is to rather apply {\tt (Rtrans n m p)}. - -\begin{coq_example} -apply (Rtrans n m p). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -More elegantly, {\tt apply Rtrans with (y:=m)} allows to only mention -the unknown {\tt m}: - -\begin{coq_example} - - apply Rtrans with (y := m). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -Another solution is to mention the proof of {\tt (R x y)} in {\tt -Rtrans}... - -\begin{coq_example} - - apply Rtrans with (1 := Rnm). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -... or the proof of {\tt (R y z)}: - -\begin{coq_example} - - apply Rtrans with (2 := Rmp). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -On the opposite, one can use {\tt eapply} which postpone the problem -of finding {\tt m}. Then one can apply the hypotheses {\tt Rnm} and {\tt -Rmp}. This instantiates the existential variable and completes the proof. - -\begin{coq_example} -eapply Rtrans. -apply Rnm. -apply Rmp. -\end{coq_example} - -\begin{coq_eval} -Reset R. -\end{coq_eval} - -\section[{\tt Scheme}]{{\tt Scheme}\comindex{Scheme} -\label{Scheme-examples}} - -\firstexample -\example{Induction scheme for \texttt{tree} and \texttt{forest}} - -The definition of principle of mutual induction for {\tt tree} and -{\tt forest} over the sort {\tt Set} is defined by the command: - -\begin{coq_eval} -Reset Initial. -Variables A B : - Set. -\end{coq_eval} - -\begin{coq_example*} -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. - -Scheme tree_forest_rec := Induction for tree Sort Set - with forest_tree_rec := Induction for forest Sort Set. -\end{coq_example*} - -You may now look at the type of {\tt tree\_forest\_rec}: - -\begin{coq_example} -Check tree_forest_rec. -\end{coq_example} - -This principle involves two different predicates for {\tt trees} and -{\tt forests}; it also has three premises each one corresponding to a -constructor of one of the inductive definitions. - -The principle {\tt forest\_tree\_rec} shares exactly the same -premises, only the conclusion now refers to the property of forests. - -\begin{coq_example} -Check forest_tree_rec. -\end{coq_example} - -\example{Predicates {\tt odd} and {\tt even} on naturals} - -Let {\tt odd} and {\tt even} be inductively defined as: - -% Reset Initial. -\begin{coq_eval} -Open Scope nat_scope. -\end{coq_eval} - -\begin{coq_example*} -Inductive odd : nat -> Prop := - oddS : forall n:nat, even n -> odd (S n) -with even : nat -> Prop := - | evenO : even 0 - | evenS : forall n:nat, odd n -> even (S n). -\end{coq_example*} - -The following command generates a powerful elimination -principle: - -\begin{coq_example} -Scheme odd_even := Minimality for odd Sort Prop - with even_odd := Minimality for even Sort Prop. -\end{coq_example} - -The type of {\tt odd\_even} for instance will be: - -\begin{coq_example} -Check odd_even. -\end{coq_example} - -The type of {\tt even\_odd} shares the same premises but the -conclusion is {\tt (n:nat)(even n)->(Q n)}. - -\subsection[{\tt Combined Scheme}]{{\tt Combined Scheme}\comindex{Combined Scheme} -\label{CombinedScheme-examples}} - -We can define the induction principles for trees and forests using: -\begin{coq_example} -Scheme tree_forest_ind := Induction for tree Sort Prop - with forest_tree_ind := Induction for forest Sort Prop. -\end{coq_example} - -Then we can build the combined induction principle which gives the -conjunction of the conclusions of each individual principle: -\begin{coq_example} -Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind. -\end{coq_example} - -The type of {\tt tree\_forest\_mutrec} will be: -\begin{coq_example} -Check tree_forest_mutind. -\end{coq_example} - -\section[{\tt Functional Scheme} and {\tt functional induction}]{{\tt Functional Scheme} and {\tt functional induction}\comindex{Functional Scheme}\tacindex{functional induction} -\label{FunScheme-examples}} - -\firstexample -\example{Induction scheme for \texttt{div2}} - -We define the function \texttt{div2} as follows: - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Require Import Arith. -Fixpoint div2 (n:nat) : nat := - match n with - | O => 0 - | S O => 0 - | S (S n') => S (div2 n') - end. -\end{coq_example*} - -The definition of a principle of induction corresponding to the -recursive structure of \texttt{div2} is defined by the command: - -\begin{coq_example} -Functional Scheme div2_ind := Induction for div2 Sort Prop. -\end{coq_example} - -You may now look at the type of {\tt div2\_ind}: - -\begin{coq_example} -Check div2_ind. -\end{coq_example} - -We can now prove the following lemma using this principle: - - -\begin{coq_example*} -Lemma div2_le' : forall n:nat, div2 n <= n. -intro n. - pattern n , (div2 n). -\end{coq_example*} - - -\begin{coq_example} -apply div2_ind; intros. -\end{coq_example} - -\begin{coq_example*} -auto with arith. -auto with arith. -simpl; auto with arith. -Qed. -\end{coq_example*} - -We can use directly the \texttt{functional induction} -(\ref{FunInduction}) tactic instead of the pattern/apply trick: - -\begin{coq_example*} -Reset div2_le'. -Lemma div2_le : forall n:nat, div2 n <= n. -intro n. -\end{coq_example*} - -\begin{coq_example} -functional induction (div2 n). -\end{coq_example} - -\begin{coq_example*} -auto with arith. -auto with arith. -auto with arith. -Qed. -\end{coq_example*} - -\Rem There is a difference between obtaining an induction scheme for a -function by using \texttt{Function} (see Section~\ref{Function}) and by -using \texttt{Functional Scheme} after a normal definition using -\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for -details. - - -\example{Induction scheme for \texttt{tree\_size}} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -We define trees by the following mutual inductive type: - -\begin{coq_example*} -Variable A : Set. -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | empty : forest - | cons : tree -> forest -> forest. -\end{coq_example*} - -We define the function \texttt{tree\_size} that computes the size -of a tree or a forest. Note that we use \texttt{Function} which -generally produces better principles. - -\begin{coq_example*} -Function tree_size (t:tree) : nat := - match t with - | node A f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | empty => 0 - | cons t f' => (tree_size t + forest_size f') - end. -\end{coq_example*} - -Remark: \texttt{Function} generates itself non mutual induction -principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}: - -\begin{coq_example} -Check tree_size_ind. -\end{coq_example} - -The definition of mutual induction principles following the recursive -structure of \texttt{tree\_size} and \texttt{forest\_size} is defined -by the command: - -\begin{coq_example*} -Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop -with forest_size_ind2 := Induction for forest_size Sort Prop. -\end{coq_example*} - -You may now look at the type of {\tt tree\_size\_ind2}: - -\begin{coq_example} -Check tree_size_ind2. -\end{coq_example} - - - - -\section[{\tt inversion}]{{\tt inversion}\tacindex{inversion} -\label{inversion-examples}} - -\subsection*{Generalities about inversion} - -When working with (co)inductive predicates, we are very often faced to -some of these situations: -\begin{itemize} -\item we have an inconsistent instance of an inductive predicate in the - local context of hypotheses. Thus, the current goal can be trivially - proved by absurdity. -\item we have a hypothesis that is an instance of an inductive - predicate, and the instance has some variables whose constraints we - would like to derive. -\end{itemize} - -The inversion tactics are very useful to simplify the work in these -cases. Inversion tools can be classified in three groups: - -\begin{enumerate} -\item tactics for inverting an instance without stocking the inversion - lemma in the context; this includes the tactics - (\texttt{dependent}) \texttt{inversion} and - (\texttt{dependent}) \texttt{inversion\_clear}. -\item commands for generating and stocking in the context the inversion - lemma corresponding to an instance; this includes \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion} and \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion\_clear}. -\item tactics for inverting an instance using an already defined - inversion lemma; this includes the tactic \texttt{inversion \ldots using}. -\end{enumerate} - -As inversion proofs may be large in size, we recommend the user to -stock the lemmas whenever the same instance needs to be inverted -several times. - -\firstexample -\example{Non-dependent inversion} - -Let's consider the relation \texttt{Le} over natural numbers and the -following variables: - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Inductive Le : nat -> nat -> Set := - | LeO : forall n:nat, Le 0 n - | LeS : forall n m:nat, Le n m -> Le (S n) (S m). -Variable P : nat -> nat -> Prop. -Variable Q : forall n m:nat, Le n m -> Prop. -\end{coq_example*} - -For example, consider the goal: - -\begin{coq_eval} -Lemma ex : forall n m:nat, Le (S n) m -> P n m. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -To prove the goal we may need to reason by cases on \texttt{H} and to - derive that \texttt{m} is necessarily of -the form $(S~m_0)$ for certain $m_0$ and that $(Le~n~m_0)$. -Deriving these conditions corresponds to prove that the -only possible constructor of \texttt{(Le (S n) m)} is -\texttt{LeS} and that we can invert the -\texttt{->} in the type of \texttt{LeS}. -This inversion is possible because \texttt{Le} is the smallest set closed by -the constructors \texttt{LeO} and \texttt{LeS}. - -\begin{coq_example} -inversion_clear H. -\end{coq_example} - -Note that \texttt{m} has been substituted in the goal for \texttt{(S m0)} -and that the hypothesis \texttt{(Le n m0)} has been added to the -context. - -Sometimes it is -interesting to have the equality \texttt{m=(S m0)} in the -context to use it after. In that case we can use \texttt{inversion} that -does not clear the equalities: - -\begin{coq_example*} -Undo. -\end{coq_example*} - -\begin{coq_example} -inversion H. -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -\example{Dependent Inversion} - -Let us consider the following goal: - -\begin{coq_eval} -Lemma ex_dep : forall (n m:nat) (H:Le (S n) m), Q (S n) m H. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -As \texttt{H} occurs in the goal, we may want to reason by cases on its -structure and so, we would like inversion tactics to -substitute \texttt{H} by the corresponding term in constructor form. -Neither \texttt{Inversion} nor {\tt Inversion\_clear} make such a -substitution. -To have such a behavior we use the dependent inversion tactics: - -\begin{coq_example} -dependent inversion_clear H. -\end{coq_example} - -Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and -\texttt{m} by \texttt{(S m0)}. - -\example{using already defined inversion lemmas} - -\begin{coq_eval} -Abort. -\end{coq_eval} - -For example, to generate the inversion lemma for the instance -\texttt{(Le (S n) m)} and the sort \texttt{Prop} we do: - -\begin{coq_example*} -Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort - Prop. -\end{coq_example*} - -\begin{coq_example} -Check leminv. -\end{coq_example} - -Then we can use the proven inversion lemma: - -\begin{coq_example} -Show. -\end{coq_example} - -\begin{coq_example} -inversion H using leminv. -\end{coq_example} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - \section[\tt dependent induction]{\tt dependent induction\label{dependent-induction-example}} \def\depind{{\tt dependent induction}~} \def\depdestr{{\tt dependent destruction}~} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index bda4cff9..f5178445 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -78,47 +78,47 @@ See the man page of {\tt coqdep} for more details and options. \index{Makefile@{\tt Makefile}} \index{CoqMakefile@{\tt coq\_Makefile}}} -When a proof development becomes large and is split into several files, -it becomes crucial to use a tool like {\tt make} to compile \Coq\ -modules. +When a proof development becomes large, is split into several files or contains +Ocaml plugins, it becomes crucial to use a tool like {\tt make} to compile +\Coq\ modules. The writing of a generic and complete {\tt Makefile} may be a tedious work and that's why \Coq\ provides a tool to automate its creation, {\tt coq\_makefile}. -Arguments are explain by \texttt{\% coq\_makefile --help}. They can be directly -written in the command line but it is recommended to write them in a file (called -for example {\tt Make}) and then call {\tt coq\_makefile -f Make -o - Makefile}. That means options are in {\tt Make} file and output is {\tt - Makefile} This way, {\tt Makefile} will be automatically regenerated if -something changes in {\tt Make}. +You can get a description of the arguments by the command \texttt{\% coq\_makefile + --help}. Arguments can be directly written on the command line interface but it is recommended +to write them in a file ({\tt \_CoqProject} by default) and then call {\tt + coq\_makefile -f \_CoqProject -o Makefile}. That means options are read from {\tt + \_CoqProject} and written in {\tt Makefile}. This way, {\tt Makefile} will be +automagically regenerated when something changes in {\tt \_CoqProject}. The first time you use this tool, you may be happy with: \begin{quotation} \texttt{\% \{ echo '-R .} {\em MyFancyLib} \texttt{' ; find -name '*.v' -print \} > - Make \&\& coq\_makefile -f Make -o Makefile} + \_CoqProject \&\& coq\_makefile -f \_CoqProject -o Makefile} \end{quotation} -To customize things afterwards, remember: +To customize things further, remember the following: \begin{itemize} -\item Coq files must end in {\tt .v}, caml modules in {\tt .ml4} if they - require camlp preproccessing (and in {\tt .ml} otherwise), and caml module signatures in {\tt - .mli}. -\item If you give a directory directly as argument, it is because you provide a - Makefile for it in it. -\item {\tt -R} option is for Coq, {\tt -I} for caml. The same directory can +\item \Coq files must end in {\tt .v}, \ocaml modules in {\tt .ml4} if they + require camlp preproccessing (and in {\tt .ml} otherwise), and \ocaml module + signatures in {\tt .mli}. +\item Whenever a directory is passed as argument, any inner {\tt Makefile} will be + recursively called. +\item {\tt -R} option is for \Coq, {\tt -I} for \ocaml. The same directory can be ``included'' by both. - Using {\tt -R} option gives a right logical path and a correct installation + + Using {\tt -R} option gives a correct logical path and a correct installation emplacement to your coq files. -\item If your files depend on an external library that isn't install somewhere - looked by coqc, use {\tt OTHERFLAGS = '-R path/to/lib lib\_name'} option in your {\tt - Make} but don't do {\tt -R \dots} directly, the {\em make clean} command would - erase it! +\item If your files depend on an external library, never use {\tt -R \dots} to + include it in the path, the {\em make clean} command would erase it! Take + advantage of the \verb:COQPATH: variable (see \ref{envars}) instead if + necessary. \end{itemize} -\Warning To compile a project containing \ocaml{} files you must keep -the sources of \Coq{} somewhere and have an environment variable named -\texttt{COQTOP} that points to that directory. +Under normal circumstances, the only other variable that you may use is +\verb:$COQBIN: to specify the directory where the binaries are. \section[Documenting \Coq\ files with coqdoc]{Documenting \Coq\ files with coqdoc\label{coqdoc} \index{Coqdoc@{\sf coqdoc}}} @@ -142,7 +142,7 @@ after each phrase. Starting with a file {\em file}{\tt.tex} containing \Coq\ phrases, the {\tt coq-tex} filter produces a file named {\em file}{\tt.v.tex} with -the \Coq\ outcome. +the \Coq\ outcome. There are options to produce the \Coq\ parts in smaller font, italic, between horizontal rules, etc. diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index cc42c2ef..4380f544 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -35,7 +35,7 @@ \input{../common/title.tex}% extension .tex pour htmlgen %\input{headers} -\usepackage[linktocpage,colorlinks,bookmarks=false]{hyperref} +\usepackage[linktocpage,colorlinks]{hyperref} % The manual advises to load hyperref package last to be able to redefine % necessary commands. % The above should work for both latex and pdflatex. Even if PDF is produced @@ -88,15 +88,16 @@ Options A and B of the licence are {\em not} elected.} \part{The proof engine} \include{RefMan-oth.v}% Vernacular commands -\include{RefMan-pro}% Proof handling +\include{RefMan-pro.v}% Proof handling \include{RefMan-tac.v}% Tactics and tacticals \include{RefMan-ltac.v}% Writing tactics \include{RefMan-tacex.v}% Detailed Examples of tactics \include{RefMan-decl.v}% The mathematical proof language \part{User extensions} -\include{RefMan-syn.v}% The Syntax and the Grammad commands +\include{RefMan-syn.v}% The Syntax and the Grammar commands %%SUPPRIME \include{RefMan-tus.v}% Writing tactics +\include{RefMan-sch.v}% The Scheme commands \part{Practical tools} \include{RefMan-com}% The coq commands (coqc coqtop) diff --git a/doc/refman/coqdoc.tex b/doc/refman/coqdoc.tex index 271a13f7..c2591a7b 100644 --- a/doc/refman/coqdoc.tex +++ b/doc/refman/coqdoc.tex @@ -43,8 +43,8 @@ remember: ``garbage in, garbage out''. \Coq\ material is quoted between the delimiters \texttt{[} and \texttt{]}. Square brackets may be nested, the inner ones being understood as being part of the quoted code (thus -you can quote a term like $[x:T]u$ by writing -\texttt{[[x:T]u]}). Inside quotations, the code is pretty-printed in +you can quote a term like \texttt{fun x => u} by writing +\texttt{[fun x => u]}). Inside quotations, the code is pretty-printed in the same way as it is in code parts. Pre-formatted vernacular is enclosed by \texttt{[[} and @@ -63,7 +63,7 @@ or (** printing \emph{token} $...\LaTeX\ math...$ #...HTML...# *) \end{alltt} It gives the \LaTeX\ and HTML texts to be produced for the given \Coq\ -token. One of the \LaTeX\ or HTML text may be ommitted, causing the +token. One of the \LaTeX\ or HTML text may be omitted, causing the default pretty-printing to be used for this token. The printing for one token can be removed with @@ -94,7 +94,7 @@ Any of these can be overwritten or suppressed using the Important note: the recognition of tokens is done by a (ocaml)lex automaton and thus applies the longest-match rule. For instance, \verb!->~! is recognized as a single token, where \Coq\ sees two -tokens. It is the responsability of the user to insert space between +tokens. It is the responsibility of the user to insert space between tokens \emph{or} to give pretty-printing rules for the possible combinations, e.g. \begin{verbatim} @@ -153,7 +153,7 @@ emphasis. Usually, these are spaces or punctuation. This sentence contains some _emphasized text_. \end{verbatim} -\paragraph{Escapings to \LaTeX\ and HTML.} +\paragraph{Escaping to \LaTeX\ and HTML.} Pure \LaTeX\ or HTML material can be inserted using the following escape sequences: \begin{itemize} @@ -318,7 +318,7 @@ suffix \verb!.tex!. \item[\texttt{\mm{}files-from }\textit{file}] ~\par Read file names to process in file `\textit{file}' as if they were - given on the command line. Useful for program sources splitted in + given on the command line. Useful for program sources split up into several directories. \item[\texttt{-q}, \texttt{\mm{}quiet}] ~\par diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files new file mode 100644 index 00000000..e69de29b diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 35c13f3b..0ee101c8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -1,17 +1,5 @@ - - - - - -The Coq Standard Library - - - - -

    The Coq Standard Library

    +

    The Coq Standard Library

    Here is a short description of the Coq standard library, which is distributed with the system. @@ -68,6 +56,7 @@ through the Require Import command.

    theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v theories/Logic/FunctionalExtensionality.v + theories/Logic/ExtensionalityFacts.v
    Structures: @@ -184,6 +173,8 @@ through the Require Import command.

    theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v + theories/ZArith/ZOdiv_def.v + theories/ZArith/ZOdiv.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v @@ -414,6 +405,16 @@ through the Require Import command.

    theories/Lists/ListTactics.v +
    Vectors: + Dependent datastructures storing their length +
    +
    + theories/Vectors/Fin.v + theories/Vectors/VectorDef.v + theories/Vectors/VectorSpec.v + (theories/Vectors/Vector.v) +
    +
    Sorting: Axiomatizations of sorts
    @@ -454,7 +455,9 @@ through the Require Import command.

    theories/MSets/MSetEqProperties.v theories/MSets/MSetWeakList.v theories/MSets/MSetList.v + theories/MSets/MSetGenTree.v theories/MSets/MSetAVL.v + theories/MSets/MSetRBT.v theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) @@ -576,4 +579,11 @@ through the Require Import command.

    theories/Program/Combinators.v +
    Unicode: + Unicode-based notations +
    +
    + theories/Unicode/Utf8_core.v + theories/Unicode/Utf8.v +
    diff --git a/doc/stdlib/index-trailer.html b/doc/stdlib/index-trailer.html deleted file mode 100644 index 308b1d01..00000000 --- a/doc/stdlib/index-trailer.html +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index 8e496fdd..1a70567f 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -3,37 +3,55 @@ # Instantiate links to library files in index template FILE=$1 +HIDDEN=$2 cp -f $FILE.template tmp echo -n Building file index-list.prehtml ... -LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +#LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"` for k in $LIBDIRS; do i=theories/$k echo $i d=`basename $i` - if [ "$d" != "Num" -a "$d" != "CVS" ]; then + if [ "$d" != "CVS" ]; then + ls $i | grep -q \.v'$' + if [ $? = 0 ]; then for j in $i/*.v; do b=`basename $j .v` rm -f tmp2 grep -q theories/$k/$b.v tmp a=$? + grep -q theories/$k/$b.v $HIDDEN + h=$? if [ $a = 0 ]; then - p=`echo $k | sed 's:/:.:g'` - sed -e "s:theories/$k/$b.v:$b:g" tmp > tmp2 - mv -f tmp2 tmp + if [ $h = 0 ]; then + echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1 + else + p=`echo $k | sed 's:/:.:g'` + sed -e "s:theories/$k/$b.v:$b:g" tmp > tmp2 + mv -f tmp2 tmp + fi else - echo Warning: theories/$k/$b.v is missing in the template file - fi + if [ $h = 0 ]; then + echo Error: theories/$k/$b.v is missing in the template file + exit 1 + else + echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v + exit 1 + fi + + fi done + fi fi rm -f tmp2 sed -e "s/#$d#//" tmp > tmp2 mv -f tmp2 tmp done a=`grep theories tmp` -if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi +if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi mv tmp $FILE echo Done diff --git a/ide/command_windows.ml b/ide/command_windows.ml index 939238d3..a34e5ebe 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -13,6 +13,7 @@ class command_window coqtop current = ~position:`CENTER ~title:"CoqIde queries" ~show:false () in *) + let views = ref [] in let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in let _ = frame#misc#hide () in let _ = GtkData.AccelGroup.create () in @@ -49,12 +50,17 @@ class command_window coqtop current = () in + let remove_cb () = + let index = notebook#current_page in + let () = notebook#remove_page index in + views := Minilib.list_filter_i (fun i x -> i <> index) !views + in let _ = toolbar#insert_button ~tooltip:"Delete Page" ~text:"Delete Page" ~icon:(Ideutils.stock_to_widget `DELETE) - ~callback:(fun () -> notebook#remove_page notebook#current_page) + ~callback:remove_cb () in object(self) @@ -63,14 +69,14 @@ object(self) val new_page_menu = new_page_menu val notebook = notebook + method frame = frame method new_command ?command ?term () = - let appendp x = ignore (notebook#append_page x) in let frame = GBin.frame ~shadow_type:`ETCHED_OUT - ~packing:appendp () in + let _ = notebook#append_page frame#coerce in notebook#goto_page (notebook#page_num frame#coerce); let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in @@ -91,7 +97,10 @@ object(self) ~packing:(vbox#pack ~fill:true ~expand:true) () in let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in let result = GText.view ~packing:r_bin#add () in + let () = views := !views @ [result] in result#misc#modify_font !current.Preferences.text_font; + let clr = Tags.color_of_string !current.Preferences.background_color in + result#misc#modify_base [`NORMAL, `COLOR clr]; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let callback () = @@ -134,6 +143,15 @@ object(self) ignore (combo#entry#connect#activate ~callback); self#frame#misc#show () + method refresh_font () = + let iter view = view#misc#modify_font !current.Preferences.text_font in + List.iter iter !views + + method refresh_color () = + let clr = Tags.color_of_string !current.Preferences.background_color in + let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in + List.iter iter !views + initializer ignore (new_page_menu#connect#clicked ~callback:self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) diff --git a/ide/command_windows.mli b/ide/command_windows.mli index 8c7319aa..c34b6cf6 100644 --- a/ide/command_windows.mli +++ b/ide/command_windows.mli @@ -11,4 +11,6 @@ class command_window : object method new_command : ?command:string -> ?term:string -> unit -> unit method frame : GBin.frame + method refresh_font : unit -> unit + method refresh_color : unit -> unit end diff --git a/ide/coq.ml b/ide/coq.ml index 16a07b01..76dc5650 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -54,36 +54,106 @@ let rec read_all_lines in_chan = arg::(read_all_lines in_chan) with End_of_file -> [] -let filter_coq_opts args = +let fatal_error_popup msg = + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`ERROR ~message:msg () + in ignore (popup#run ()); exit 1 + +let final_info_popup small msg = + if small then + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`INFO ~message:msg () + in + let _ = popup#run () in + exit 0 + else + let popup = GWindow.dialog () in + let button = GButton.button ~label:"ok" ~packing:popup#action_area#add () + in + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC + ~packing:popup#vbox#add ~height:500 () + in + let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in + let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in + let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in + let _ = popup#run () in + exit 0 + +let connection_error cmd lines exn = + fatal_error_popup + ("Connection with coqtop failed!\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)^"\n"^ + "Exception was: "^Printexc.to_string exn) + +let display_coqtop_answer cmd lines = + final_info_popup (List.length lines < 30) + ("Coqtop exited\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)) + +let check_remaining_opt arg = + if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) + +let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in - let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in - let filtered_args = read_all_lines oc in - let message = read_all_lines ec in - match Unix.close_process_full (oc,ic,ec) with - | Unix.WEXITED 0 -> true,filtered_args - | Unix.WEXITED 2 -> false,filtered_args - | _ -> false,message - -exception Coqtop_output of string list + let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in + let cmd = requote cmd in + let filtered_args = ref [] in + let errlines = ref [] in + try + let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in + filtered_args := read_all_lines oc; + errlines := read_all_lines ec; + match Unix.close_process_full (oc,ic,ec) with + | Unix.WEXITED 0 -> + List.iter check_remaining_opt !filtered_args; !filtered_args + | Unix.WEXITED 127 -> asks_for_coqtop args + | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines) + with Sys_error _ -> asks_for_coqtop args + | e -> connection_error cmd (!filtered_args @ !errlines) e + +and asks_for_coqtop args = + let pb_mes = GWindow.message_dialog + ~message:"Failed to load coqtop. Reset the preference to default ?" + ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in + match pb_mes#run () with + | `YES -> + let () = !Preferences.current.Preferences.cmd_coqtop <- None in + let () = custom_coqtop := None in + let () = pb_mes#destroy () in + filter_coq_opts args + | `DELETE_EVENT | `NO -> + let () = pb_mes#destroy () in + let cmd_sel = GWindow.file_selection + ~title:"Coqtop to execute (edit your preference then)" + ~filename:(coqtop_path ()) ~urgency_hint:true () in + match cmd_sel#run () with + | `OK -> + let () = custom_coqtop := (Some cmd_sel#filename) in + let () = cmd_sel#destroy () in + filter_coq_opts args + | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + +exception WrongExitStatus of string + +let print_status = function + | Unix.WEXITED n -> "WEXITED "^string_of_int n + | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n + | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n let check_connection args = + let lines = ref [] in + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in + let cmd = requote cmd in try - let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in let ic = Unix.open_process_in cmd in - let lines = read_all_lines ic in + lines := read_all_lines ic; match Unix.close_process_in ic with - | Unix.WEXITED 0 -> prerr_endline "coqtop seems ok" - | _ -> raise (Coqtop_output lines) - with - | End_of_file -> - Minilib.safe_prerr_endline "Cannot start connection with coqtop"; - exit 1 - | Coqtop_output lines -> - Minilib.safe_prerr_endline "Connection with coqtop failed:"; - List.iter Minilib.safe_prerr_endline lines; - exit 1 + | Unix.WEXITED 0 -> () (* coqtop seems ok *) + | st -> raise (WrongExitStatus (print_status st)) + with e -> connection_error cmd !lines e (** * The structure describing a coqtop sub-process *) @@ -139,7 +209,7 @@ let open_process_pid prog args = let spawn_coqtop sup_args = Mutex.lock toplvl_ctr_mtx; try - let prog = !Minilib.coqtop_path in + let prog = coqtop_path () in let args = Array.of_list (prog :: "-ideslave" :: sup_args) in let (pid,ic,oc) = open_process_pid prog args in incr toplvl_ctr; diff --git a/ide/coq.mli b/ide/coq.mli index 9d64da6c..7f61521e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -13,11 +13,15 @@ val short_version : unit -> string val version : unit -> string -(** * Initial checks by launching test coqtop processes *) - -val filter_coq_opts : string list -> bool * string list - -(** A mock coqtop launch, checking in particular that initial.coq is found *) +(** * Launch a test coqtop processes, ask for a correct coqtop if it fails. + @return the list of arguments that coqtop did not understand + (the files probably ..). This command may terminate coqide in + case of trouble. *) +val filter_coq_opts : string list -> string list + +(** Launch a coqtop with the user args in order to be sure that it works, + checking in particular that initial.coq is found. This command + may terminate coqide in case of trouble *) val check_connection : string list -> unit (** * The structure describing a coqtop sub-process *) diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index b9e14145..256426d2 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -127,7 +127,6 @@ let commands = [ "Show Script"; "Show Tree";*) "Structure"; - (* "Suspend"; *) "Syntactic Definition"; "Syntax";]; [ diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index f0f1afb7..c9a9a826 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -24,7 +24,7 @@ let one_word_commands = [ "Add" ; "Check"; "Eval"; "Extraction" ; "Load" ; "Undo"; "Goal"; - "Proof" ; "Print";"Save" ; + "Proof" ; "Print";"Save" ; "Restart"; "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ] in let one_word_declarations = @@ -37,7 +37,8 @@ (* Inductive *) "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; (* Other *) - "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ] + "Ltac" ; "Instance"; "Include"; "Context"; "Class" ; + "Arguments" ] in let proof_declarations = [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ; @@ -85,33 +86,28 @@ let multiword_declaration = | "Existing" space+ "Instance" "s"? | "Canonical" space+ "Structure" -let locality = ("Local" space+)? +let locality = (space+ "Local")? let multiword_command = - "Set" (space+ ident)* -| "Unset" (space+ ident)* -| "Open" space+ locality "Scope" -| "Close" space+ locality "Scope" -| "Bind" space+ "Scope" -| "Arguments" space+ "Scope" -| "Reserved" space+ "Notation" space+ locality -| "Delimit" space+ "Scope" + ("Uns" | "S")" et" (space+ ident)* +| (("Open" | "Close") locality | "Bind" | " Delimit" ) + space+ "Scope" +| (("Reserved" space+)? "Notation" | "Infix") locality space+ | "Next" space+ "Obligation" | "Solve" space+ "Obligations" | "Require" space+ ("Import"|"Export")? -| "Infix" space+ locality -| "Notation" space+ locality -| "Hint" space+ locality ident +| "Hint" locality space+ ident | "Reset" (space+ "Initial")? | "Tactic" space+ "Notation" -| "Implicit" space+ "Arguments" -| "Implicit" space+ ("Type"|"Types") +| "Implicit" space+ "Type" "s"? | "Combined" space+ "Scheme" | "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))| ("Library"|"Inline"|"NoInline"|"Blacklist")) | "Recursive" space+ "Extraction" (space+ "Library")? | ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist") | "Extract" space+ (("Inlined" space+) "Constant"| "Inductive") +| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque") +| ("Generalizable" space+) ("All" | "No")? "Variable" "s"? (* At least still missing: "Inline" + decl, variants of "Identity Coercion", variants of Print, Add, ... *) diff --git a/ide/coqide-gtk2rc b/ide/coqide-gtk2rc index 621d4e84..9da99551 100644 --- a/ide/coqide-gtk2rc +++ b/ide/coqide-gtk2rc @@ -23,16 +23,6 @@ binding "text" { class "GtkTextView" binding "text" -style "views" { -base[NORMAL] = "CornSilk" -# bg_pixmap[NORMAL] = "background.jpg" -} -class "GtkTextView" style "views" - -widget "*.*.*.*.*.ScriptWindow" style "views" -widget "*.*.*.*.GoalWindow" style "views" -widget "*.*.*.*.MessageWindow" style "views" - gtk-font-name = "Sans 12" style "location" { diff --git a/ide/coqide.ml b/ide/coqide.ml index 009a1989..61280fd9 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -27,7 +27,6 @@ let safety_tag = function class type analyzed_views= object val mutable act_id : GtkSignal.id option - val mutable deact_id : GtkSignal.id option val input_buffer : GText.buffer val input_view : Undo.undoable_view val last_array : string array @@ -65,7 +64,6 @@ object method backtrack_to : GText.iter -> unit method backtrack_to_no_lock : GText.iter -> unit method clear_message : unit - method disconnected_keypress_handler : GdkEvent.Key.t -> bool method find_phrase_starting_at : GText.iter -> (GText.iter * GText.iter) option method get_insert : GText.iter @@ -84,6 +82,7 @@ object method reset_initial : unit method force_reset_initial : unit method set_message : string -> unit + method raw_coq_query : string -> unit method show_goals : unit method show_goals_full : unit method undo_last_step : unit @@ -889,11 +888,32 @@ object(self) raise RestartCoqtop | e -> sync display_error (None, Printexc.to_string e); None + (* This method is intended to perform stateless commands *) + method raw_coq_query phrase = + let () = prerr_endline "raw_coq_query starting now" in + let display_error s = + if not (Glib.Utf8.validate s) then + flash_info "This error is so nasty that I can't even display it." + else begin + self#insert_message s; + message_view#misc#draw None + end + in + try + match Coq.interp !mycoqtop ~raw:true ~verbose:false phrase with + | Interface.Fail (_, err) -> sync display_error err + | Interface.Good msg -> sync self#insert_message msg + with + | End_of_file -> raise RestartCoqtop + | e -> sync display_error (Printexc.to_string e) + method find_phrase_starting_at (start:GText.iter) = try let start = grab_sentence_start start self#get_start_of_input in let stop = grab_sentence_stop start in - if is_sentence_end stop#backward_char then Some (start,stop) + (* Is this phrase non-empty and complete ? *) + if stop#compare start > 0 && is_sentence_end stop#backward_char + then Some (start,stop) else None with Not_found -> None @@ -1217,22 +1237,6 @@ object(self) let state = GdkEvent.Key.state k in begin match state with - | l when List.mem `MOD1 l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Return=k - then ignore( - if (input_buffer#insert_interactive "\n") then - begin - let i= self#get_insert#backward_word_start in - prerr_endline "active_kp_hf: Placing cursor"; - self#process_until_iter_or_error i - end); - true - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Break=k - then break (); - false | l -> if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin prerr_endline "active_kp_handler for Tab"; @@ -1241,18 +1245,6 @@ object(self) end else false end - - method disconnected_keypress_handler k = - match GdkEvent.Key.state k with - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._c=k - then break (); - false - | l -> false - - - val mutable deact_id = None val mutable act_id = None method activate () = if not is_active then begin @@ -1523,9 +1515,15 @@ let create_session file = script#buffer#place_cursor ~where:(script#buffer#start_iter); proof#misc#set_can_focus true; message#misc#set_can_focus true; + (* setting fonts *) script#misc#modify_font !current.text_font; proof#misc#modify_font !current.text_font; message#misc#modify_font !current.text_font; + (* setting colors *) + script#misc#modify_base [`NORMAL, `NAME !current.background_color]; + proof#misc#modify_base [`NORMAL, `NAME !current.background_color]; + message#misc#modify_base [`NORMAL, `NAME !current.background_color]; + { tab_label=basename; filename=begin match file with None -> "" |Some f -> f end; script=script; @@ -1798,12 +1796,6 @@ let forbid_quit_to_save () = else false) let main files = - (* Statup preferences *) - begin - try load_pref () - with e -> - flash_info ("Could not load preferences ("^Printexc.to_string e^")."); - end; (* Main window *) let w = GWindow.window @@ -1823,9 +1815,9 @@ let main files = let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in let new_f _ = - match select_file_for_save ~title:"Create file" () with - | None -> () - | Some f -> do_load f + let session = create_session None in + let index = session_notebook#append_term session in + session_notebook#goto_page index in let load_f _ = match select_file_for_open ~title:"Load file" () with @@ -2181,6 +2173,7 @@ let main files = true)) in reset_auto_save_timer (); (* to enable statup preferences timer *) (* end Preferences *) + let do_or_activate f () = do_if_not_computing "do_or_activate" (fun current -> @@ -2327,13 +2320,13 @@ let main files = in let file_actions = GAction.action_group ~name:"File" () in - let export_actions = GAction.action_group ~name:"Export" () in let edit_actions = GAction.action_group ~name:"Edit" () in + let view_actions = GAction.action_group ~name:"View" () in + let export_actions = GAction.action_group ~name:"Export" () in let navigation_actions = GAction.action_group ~name:"Navigation" () in let tactics_actions = GAction.action_group ~name:"Tactics" () in let templates_actions = GAction.action_group ~name:"Templates" () in let queries_actions = GAction.action_group ~name:"Queries" () in - let display_actions = GAction.action_group ~name:"Display" () in let compile_actions = GAction.action_group ~name:"Compile" () in let windows_actions = GAction.action_group ~name:"Windows" () in let help_actions = GAction.action_group ~name:"Help" () in @@ -2362,10 +2355,18 @@ let main files = ~accel:(!current.modifier_for_tactics^sc) ~callback:(do_if_active (fun a -> a#insert_command ("progress "^s^".\n") (s^".\n"))) in - let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel - ~callback:(fun _ -> let term = get_current_word () in - session_notebook#current_term.command#new_command ~command:s ~term ()) - in let add_complex_template (name, label, text, offset, len, key) = + let query_callback command _ = + let word = get_current_word () in + if not (word = "") then + let term = session_notebook#current_term in + let query = command ^ " " ^ word ^ "." in + term.message_view#buffer#set_text ""; + term.analyzed_view#raw_coq_query query + in + let query_shortcut s accel = + GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s) + in + let add_complex_template (name, label, text, offset, len, key) = (* Templates/Lemma *) let callback _ = let {script = view } = session_notebook#current_term in @@ -2450,6 +2451,31 @@ let main files = end; reset_revert_timer ()) ~stock:`PREFERENCES; (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; + GAction.add_actions view_actions [ + GAction.add_action "View" ~label:"_View"; + GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("Left") ~stock:`GO_BACK + ~callback:(fun _ -> session_notebook#previous_page ()); + GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("Right") ~stock:`GO_FORWARD + ~callback:(fun _ -> session_notebook#next_page ()); + GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar" + ~active:(!current.show_toolbar) ~callback: + (fun _ -> !current.show_toolbar <- not !current.show_toolbar; + !refresh_toolbar_hook ()); + GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane" + ~callback:(fun _ -> let ccw = session_notebook#current_term.command in + if ccw#frame#misc#visible + then ccw#frame#misc#hide () + else ccw#frame#misc#show ()) + ~accel:"Escape"; + ]; + List.iter + (fun (opts,name,label,key,dflt) -> + GAction.add_toggle_action name ~active:dflt ~label + ~accel:(!current.modifier_for_display^key) + ~callback:(fun v -> do_or_activate (fun a -> + let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in + a#show_goals) ()) view_actions) + print_items; GAction.add_actions navigation_actions [ GAction.add_action "Navigation" ~label:"_Navigation"; GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN @@ -2532,15 +2558,6 @@ let main files = query_shortcut "Locate" None; query_shortcut "Whelp Locate" None; ]; - GAction.add_action "Display" ~label:"_Display" display_actions; - List.iter - (fun (opts,name,label,key,dflt) -> - GAction.add_toggle_action name ~active:dflt ~label - ~accel:(!current.modifier_for_display^key) - ~callback:(fun v -> do_or_activate (fun a -> - let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in - a#show_goals) ()) display_actions) - print_items; GAction.add_actions compile_actions [ GAction.add_action "Compile" ~label:"_Compile"; GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f; @@ -2551,16 +2568,6 @@ let main files = ]; GAction.add_actions windows_actions [ GAction.add_action "Windows" ~label:"_Windows"; - GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane" - ~callback:(fun _ -> let ccw = session_notebook#current_term.command in - if ccw#frame#misc#visible - then ccw#frame#misc#hide () - else ccw#frame#misc#show ()) - ~accel:"Escape"; - GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar" - ~active:(!current.show_toolbar) ~callback: - (fun _ -> !current.show_toolbar <- not !current.show_toolbar; - !show_toolbar !current.show_toolbar); GAction.add_action "Detach View" ~label:"Detach _View" ~callback:(fun _ -> do_if_not_computing "detach view" (function {script=v;analyzed_view=av} -> @@ -2608,11 +2615,11 @@ let main files = Coqide_ui.ui_m#insert_action_group file_actions 0; Coqide_ui.ui_m#insert_action_group export_actions 0; Coqide_ui.ui_m#insert_action_group edit_actions 0; + Coqide_ui.ui_m#insert_action_group view_actions 0; Coqide_ui.ui_m#insert_action_group navigation_actions 0; Coqide_ui.ui_m#insert_action_group tactics_actions 0; Coqide_ui.ui_m#insert_action_group templates_actions 0; Coqide_ui.ui_m#insert_action_group queries_actions 0; - Coqide_ui.ui_m#insert_action_group display_actions 0; Coqide_ui.ui_m#insert_action_group compile_actions 0; Coqide_ui.ui_m#insert_action_group windows_actions 0; Coqide_ui.ui_m#insert_action_group help_actions 0; @@ -2625,9 +2632,6 @@ let main files = let toolbar = new GObj.widget tbar in vbox#pack toolbar; - show_toolbar := - (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); - ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true)); (* The vertical Separator between Scripts and Goals *) @@ -2790,17 +2794,39 @@ let main files = (* Progress Bar *) lower_hbox#pack pbar#coerce; pbar#set_text "CoqIde started"; - (* XXX *) - change_font := - (fun fd -> - List.iter - (fun {script=view; proof_view=prf_v; message_view=msg_v} -> - view#misc#modify_font fd; - prf_v#misc#modify_font fd; - msg_v#misc#modify_font fd - ) - session_notebook#pages; + + (* Initializing hooks *) + + refresh_toolbar_hook := + (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ()); + refresh_font_hook := + (fun () -> + let fd = !current.text_font in + let iter_page p = + p.script#misc#modify_font fd; + p.proof_view#misc#modify_font fd; + p.message_view#misc#modify_font fd; + p.command#refresh_font () + in + List.iter iter_page session_notebook#pages; ); + refresh_background_color_hook := + (fun () -> + let clr = Tags.color_of_string !current.background_color in + let iter_page p = + p.script#misc#modify_base [`NORMAL, `COLOR clr]; + p.proof_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.message_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.command#refresh_color () + in + List.iter iter_page session_notebook#pages; + ); + resize_window_hook := (fun () -> + w#resize + ~width:!current.window_width + ~height:!current.window_height); + refresh_tabs_hook := update_notebook_pos; + let about_full_string = "\nCoq is developed by the Coq Development Team\ \n(INRIA - CNRS - LIX - LRI - PPS)\ @@ -2865,10 +2891,12 @@ let main files = (* *) - resize_window := (fun () -> - w#resize - ~width:!current.window_width - ~height:!current.window_height); +(* Begin Color configuration *) + + Tags.set_processing_color (Tags.color_of_string !current.processing_color); + Tags.set_processed_color (Tags.color_of_string !current.processed_color); + +(* End of color configuration *) ignore(nb#connect#switch_page ~callback: (fun i -> @@ -2892,7 +2920,7 @@ let main files = session_notebook#goto_page index; end; initial_about session_notebook#current_term.proof_view#buffer; - !show_toolbar !current.show_toolbar; + !refresh_toolbar_hook (); session_notebook#current_term.script#misc#grab_focus ();; (* This function check every half of second if GeoProof has send @@ -2921,43 +2949,24 @@ let rec check_for_geoproof_input () = in the path. Note that the -coqtop option to coqide allows to override this default coqtop path *) -let default_coqtop_path () = - let prog = Sys.executable_name in - try - let pos = String.length prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") prog pos in - String.blit "coqtop" 0 prog i 6; - prog - with _ -> "coqtop" - let read_coqide_args argv = let rec filter_coqtop coqtop project_files out = function | "-coqtop" :: prog :: args -> - if coqtop = "" then filter_coqtop prog project_files out args + if coqtop = None then filter_coqtop (Some prog) project_files out args else - (output_string stderr "Error: multiple -coqtop options"; exit 1) + (output_string stderr "Error: multiple -coqtop options"; exit 1) | "-f" :: file :: args -> filter_coqtop coqtop ((Minilib.canonical_path_name (Filename.dirname file), Project_file.read_project_file file) :: project_files) out args | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 + | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1 + | "-debug"::args -> Ideutils.debug := true; + filter_coqtop coqtop project_files ("-debug"::out) args | arg::args -> filter_coqtop coqtop project_files (arg::out) args - | [] -> ((if coqtop = "" then default_coqtop_path () else coqtop), - List.rev project_files,List.rev out) + | [] -> (coqtop,List.rev project_files,List.rev out) in - let coqtop,project_files,argv = filter_coqtop "" [] [] argv in - Minilib.coqtop_path := coqtop; + let coqtop,project_files,argv = filter_coqtop None [] [] argv in + Ideutils.custom_coqtop := coqtop; custom_project_files := project_files; argv - -let process_argv argv = - try - let continue,filtered = Coq.filter_coq_opts (List.tl argv) in - if not continue then - (List.iter Minilib.safe_prerr_endline filtered; exit 0); - let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in - if opts <> [] then - (Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1); - filtered - with _ -> - (Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1) diff --git a/ide/coqide.mli b/ide/coqide.mli index 38b0fab0..57158a6a 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -16,9 +16,6 @@ val sup_args : string list ref Minilib.coqtop_path accordingly *) val read_coqide_args : string list -> string list -(** Ask coqtop the remaining options it doesn't recognize *) -val process_argv : string list -> string list - (** Prepare the widgets, load the given files in tabs *) val main : string list -> unit diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index 3fec0631..6f4b8b13 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -65,21 +65,21 @@ let () = END let () = - let argl = Array.to_list Sys.argv in - let argl = Coqide.read_coqide_args argl in - let files = Coqide.process_argv argl in - let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in - Coq.check_connection args; - Coqide.sup_args := args; Coqide.ignore_break (); + ignore (GtkMain.Main.init ()); + initmac () ; (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) Minilib.xdg_config_dirs in GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc"); with Not_found -> ()); - ignore (GtkMain.Main.init ()); - initmac () ; + (* Statup preferences *) + begin + try Preferences.load_pref () + with e -> + Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^")."); + end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) ignore ( @@ -89,7 +89,13 @@ let () = if level land Glib.Message.log_level `WARNING <> 0 then Printf.eprintf "Warning: %s\n" msg else failwith ("Coqide internal error: " ^ msg))); - Coqide.main files; + let argl = Array.to_list Sys.argv in + let argl = Coqide.read_coqide_args argl in + let files = Coq.filter_coq_opts (List.tl argl) in + let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in + Coq.check_connection args; + Coqide.sup_args := args; + Coqide.main files; if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 0d7c67ac..eaf1e934 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -56,6 +56,22 @@ let init () = + + + + + + + + + + + + + + + + @@ -100,16 +116,6 @@ let init () = - - - - - - - - - - @@ -117,8 +123,6 @@ let init () = - - diff --git a/ide/ideproof.ml b/ide/ideproof.ml index 3c3324cb..b79d6469 100644 --- a/ide/ideproof.ml +++ b/ide/ideproof.ml @@ -53,7 +53,7 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s") in let goal_str index total = Printf.sprintf - "\n______________________________________(%d/%d)\n" index total + "______________________________________(%d/%d)\n" index total in (* Insert current goal and its hypotheses *) let hyps_hints, goal_hints = match hints with @@ -76,14 +76,15 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with let () = proof#buffer#insert head_str in let () = insert_hyp hyps_hints hyps in let () = - let tags = if goal_hints <> [] then + let tags = Tags.Proof.goal :: if goal_hints <> [] then let tag = proof#buffer#create_tag [] in let () = hook_tag_cb tag goal_hints sel_cb on_hover in [tag] else [] in proof#buffer#insert (goal_str 1 goals_cnt); - proof#buffer#insert ~tags (cur_goal ^ "\n") + proof#buffer#insert ~tags cur_goal; + proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = @@ -91,10 +92,11 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with proof#buffer#insert (g ^ "\n") in let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in - ignore(proof#buffer#place_cursor - ~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2))); - ignore(proof#scroll_to_mark `INSERT) + ignore(proof#buffer#place_cursor + ~where:(proof#buffer#end_iter#backward_to_tag_toggle + (Some Tags.Proof.goal))); + ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) let mode_cesar (proof:GText.view) = function | [] -> assert false @@ -123,7 +125,7 @@ let display mode (view:GText.view) goals hints evars = in List.iter iter evs | _ -> - view#buffer#insert "Proof Completed." + view#buffer#insert "No more subgoals." end | Some { Interface.fg_goals = []; Interface.bg_goals = bg } -> (* No foreground proofs, but still unfocused ones *) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index fd460c4e..a208ad0e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -63,28 +63,25 @@ let print_id id = let do_convert s = Utf8_convert.f (if Glib.Utf8.validate s then begin - prerr_endline "Input is UTF-8";s - end else - let from_loc () = - let _,char_set = Glib.Convert.get_charset () in - flash_info - ("Converting from locale ("^char_set^")"); - Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s - in - let from_manual () = - flash_info - ("Converting from "^ !current.encoding_manual); - Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual - in - if !current.encoding_use_utf8 || !current.encoding_use_locale then begin - try - from_loc () - with _ -> from_manual () - end else begin - try - from_manual () - with _ -> from_loc () - end) + prerr_endline "Input is UTF-8";s + end else + let from_loc () = + let _,char_set = Glib.Convert.get_charset () in + flash_info + ("Converting from locale ("^char_set^")"); + Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s + in + let from_manual enc = + flash_info + ("Converting from "^ enc); + Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc + in + match !current.encoding with + |Preferences.Eutf8 | Preferences.Elocale -> from_loc () + |Emanual enc -> + try + from_manual enc + with _ -> from_loc ()) let try_convert s = try @@ -96,18 +93,21 @@ Please choose a correct encoding in the preference panel.*)";; let try_export file_name s = try let s = - try if !current.encoding_use_utf8 then begin - (prerr_endline "UTF-8 is enforced" ;s) - end else if !current.encoding_use_locale then begin - let is_unicode,char_set = Glib.Convert.get_charset () in - if is_unicode then - (prerr_endline "Locale is UTF-8" ;s) - else - (prerr_endline ("Locale is "^char_set); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) - end else - (prerr_endline ("Manual charset is "^ !current.encoding_manual); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s) + try match !current.encoding with + |Eutf8 -> begin + (prerr_endline "UTF-8 is enforced" ;s) + end + |Elocale -> begin + let is_unicode,char_set = Glib.Convert.get_charset () in + if is_unicode then + (prerr_endline "Locale is UTF-8" ;s) + else + (prerr_endline ("Locale is "^char_set); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) + end + |Emanual enc -> + (prerr_endline ("Manual charset is "^ enc); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s) with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s) in let oc = open_out file_name in @@ -252,14 +252,40 @@ let stock_to_widget ?(size=`DIALOG) s = in img#set_stock s; img#coerce +let custom_coqtop = ref None + +let coqtop_path () = + let file = match !custom_coqtop with + | Some s -> s + | None -> + match !current.cmd_coqtop with + | Some s -> s + | None -> + let prog = String.copy Sys.executable_name in + try + let pos = String.length prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") prog pos in + String.blit "coqtop" 0 prog i 6; + prog + with Not_found -> "coqtop" + in file + let rec print_list print fmt = function | [] -> () | [x] -> print fmt x | x :: r -> print fmt x; print_list print fmt r +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd + (* TODO: allow to report output as soon as it comes (user-fiendlier for long commands like make...) *) let run_command f c = + let c = requote c in let result = Buffer.create 127 in let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in let buff = String.make 127 ' ' in @@ -279,11 +305,12 @@ let run_command f c = let browse f url = let com = Minilib.subst_command_placeholder !current.cmd_browse url in - let s = Sys.command com in + let _ = Unix.open_process_out com in () +(* This beautiful message will wait for twt ... if s = 127 then f ("Could not execute\n\""^com^ "\"\ncheck your preferences for setting a valid browser command\n") - +*) let doc_url () = if !current.doc_url = use_default_doc_url || !current.doc_url = "" then let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 1e29d323..c433d92a 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,6 +52,12 @@ val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val run_command : (string -> unit) -> string -> Unix.process_status*string +val custom_coqtop : string option ref +(* @return command to call coqtop + - custom_coqtop if set + - from the prefs is set + - try to infer it else *) +val coqtop_path : unit -> string val status : GMisc.statusbar @@ -67,3 +73,10 @@ val pbar : GRange.progress_bar returns an absolute filename equivalent to given filename *) val absolute_filename : string -> string + +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +val requote : string -> string diff --git a/ide/minilib.ml b/ide/minilib.ml index cec77f3b..4ccb1ccb 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -64,9 +64,10 @@ let string_map f s = let subst_command_placeholder s t = Str.global_replace (Str.regexp_string "%s") t s -let path_to_list p = - let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in - Str.split sep p +(* Split the content of a variable such as $PATH in a list of directories. + The separators are either ":" in unix or ";" in win32 *) + +let path_to_list = Str.split (Str.regexp "[:;]") (* On win32, the home directory is probably not in $HOME, but in some other environment variable *) @@ -76,28 +77,50 @@ let home = try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name +let opt2list = function None -> [] | Some x -> [x] + +let rec lconcat = function + | [] -> assert false + | [x] -> x + | x::l -> Filename.concat x (lconcat l) + let xdg_config_home = try Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq" with Not_found -> - Filename.concat home "/.config/coq" + lconcat [home;".config";"coq"] + +let static_xdg_config_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "config"] + else ["/etc/xdg/coq"] let xdg_config_dirs = - xdg_config_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) - with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with |None -> [] |Some d -> [d])) + xdg_config_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) + with Not_found -> static_xdg_config_dirs @ opt2list Coq_config.configdir let xdg_data_home = try Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq" with Not_found -> - Filename.concat home "/.local/share/coq" + lconcat [home;".local";"share";"coq"] + +let static_xdg_data_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "share"] + else ["/usr/local/share/coq";"/usr/share/coq"] let xdg_data_dirs = - xdg_data_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) - with Not_found -> - "/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with |None -> [] |Some d -> [d])) + xdg_data_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_DATA_DIRS")) + with Not_found -> static_xdg_data_dirs @ opt2list Coq_config.datadir let coqtop_path = ref "" diff --git a/ide/preferences.ml b/ide/preferences.ml index 02673098..d320ddda 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -10,9 +10,22 @@ open Configwin open Printf let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc" - let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys" +let get_config_file name = + let find_config dir = Sys.file_exists (Filename.concat dir name) in + let config_dir = List.find find_config Minilib.xdg_config_dirs in + Filename.concat config_dir name + +(* Small hack to handle v8.3 to v8.4 change in configuration file *) +let loaded_pref_file = + try get_config_file "coqiderc" + with Not_found -> Filename.concat Minilib.home ".coqiderc" + +let loaded_accel_file = + try get_config_file "coqide.keys" + with Not_found -> Filename.concat Minilib.home ".coqide.keys" + let mod_to_str (m:Gdk.Tags.modifier) = match m with | `MOD1 -> "" @@ -40,8 +53,32 @@ let project_behavior_of_string s = else if s = "appended to arguments" then Append_args else Ignore_args +type inputenc = Elocale | Eutf8 | Emanual of string + +let string_of_inputenc = function + |Elocale -> "LOCALE" + |Eutf8 -> "UTF-8" + |Emanual s -> s + +let inputenc_of_string s = + (if s = "UTF-8" then Eutf8 + else if s = "LOCALE" then Elocale + else Emanual s) + + +(** Hooks *) + +let refresh_font_hook = ref (fun () -> ()) +let refresh_background_color_hook = ref (fun () -> ()) +let refresh_toolbar_hook = ref (fun () -> ()) +let auto_complete_hook = ref (fun x -> ()) +let contextual_menus_on_goal_hook = ref (fun x -> ()) +let resize_window_hook = ref (fun () -> ()) +let refresh_tabs_hook = ref (fun () -> ()) + type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -57,9 +94,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -89,15 +124,20 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; + } let use_default_doc_url = "(automatic)" let (current:pref ref) = ref { + cmd_coqtop = None; cmd_coqc = "coqc"; cmd_make = "make"; cmd_coqmakefile = "coq_makefile -o makefile *.v"; @@ -114,9 +154,7 @@ let (current:pref ref) = read_project = Ignore_args; project_file_name = "_CoqProject"; - encoding_use_locale = true; - encoding_use_utf8 = false; - encoding_manual = "ISO_8859-1"; + encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; @@ -150,32 +188,25 @@ let (current:pref ref) = *) auto_complete = false; stop_before = true; - lax_syntax = true; vertical_tabs = false; opposite_tabs = false; - } - - -let change_font = ref (fun f -> ()) -let show_toolbar = ref (fun x -> ()) + background_color = "cornsilk"; + processed_color = "light green"; + processing_color = "light blue"; -let auto_complete = ref (fun x -> ()) - -let contextual_menus_on_goal = ref (fun x -> ()) - -let resize_window = ref (fun () -> ()) + } let save_pref () = if not (Sys.file_exists Minilib.xdg_config_home) then Unix.mkdir Minilib.xdg_config_home 0o700; - (try GtkData.AccelMap.save accel_file - with _ -> ()); + let () = try GtkData.AccelMap.save accel_file with _ -> () in let p = !current in let add = Minilib.Stringmap.add in let (++) x f = f x in Minilib.Stringmap.empty ++ + add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++ add "cmd_coqc" [p.cmd_coqc] ++ add "cmd_make" [p.cmd_make] ++ add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ @@ -190,9 +221,7 @@ let save_pref () = add "project_options" [string_of_project_behavior p.read_project] ++ add "project_file_name" [p.project_file_name] ++ - add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++ - add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++ - add "encoding_manual" [p.encoding_manual] ++ + add "encoding" [string_of_inputenc p.encoding] ++ add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ @@ -217,19 +246,18 @@ let save_pref () = add "query_window_width" [string_of_int p.query_window_width] ++ add "auto_complete" [string_of_bool p.auto_complete] ++ add "stop_before" [string_of_bool p.stop_before] ++ - add "lax_syntax" [string_of_bool p.lax_syntax] ++ add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ + add "background_color" [p.background_color] ++ + add "processing_color" [p.processing_color] ++ + add "processed_color" [p.processed_color] ++ Config_lexer.print_file pref_file let load_pref () = - let accel_dir = List.find - (fun x -> Sys.file_exists (Filename.concat x "coqide.keys")) - Minilib.xdg_config_dirs in - GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys"); + let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in let p = !current in - let m = Config_lexer.load_file pref_file in + let m = Config_lexer.load_file loaded_pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in let set_hd k f = set k (fun v -> f (List.hd v)) in @@ -239,6 +267,8 @@ let load_pref () = let set_command_with_pair_compat k f = set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) in + let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in + set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v); set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); set_hd "cmd_make" (fun v -> np.cmd_make <- v); set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); @@ -249,9 +279,7 @@ let load_pref () = set_bool "auto_save" (fun v -> np.auto_save <- v); set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2)); - set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v); - set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v); - set_hd "encoding_manual" (fun v -> np.encoding_manual <- v); + set_hd "encoding_manual" (fun v -> np.encoding <- (inputenc_of_string v)); set_hd "project_options" (fun v -> np.read_project <- (project_behavior_of_string v)); set_hd "project_file_name" (fun v -> np.project_file_name <- v); @@ -290,15 +318,21 @@ let load_pref () = set_int "query_window_height" (fun v -> np.query_window_height <- v); set_bool "auto_complete" (fun v -> np.auto_complete <- v); set_bool "stop_before" (fun v -> np.stop_before <- v); - set_bool "lax_syntax" (fun v -> np.lax_syntax <- v); set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); + set_hd "background_color" (fun v -> np.background_color <- v); + set_hd "processing_color" (fun v -> np.processing_color <- v); + set_hd "processed_color" (fun v -> np.processed_color <- v); current := np (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) let configure ?(apply=(fun () -> ())) () = + let cmd_coqtop = + string + ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s) + " coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in let cmd_coqc = string ~f:(fun s -> !current.cmd_coqc <- s) @@ -325,7 +359,7 @@ let configure ?(apply=(fun () -> ())) () = let w = GMisc.font_selection () in w#set_preview_text "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; - box#pack w#coerce; + box#pack ~expand:true w#coerce; ignore (w#misc#connect#realize ~callback:(fun () -> w#set_font_name (Pango.Font.to_string !current.text_font))); @@ -338,9 +372,67 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - !change_font !current.text_font) + !refresh_font_hook ()) true in + + let config_color = + let box = GPack.vbox () in + let table = GPack.table + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:(box#pack ~expand:true) () + in + let background_label = GMisc.label + ~text:"Background color" + ~packing:(table#attach ~expand:`X ~left:0 ~top:0) () + in + let processed_label = GMisc.label + ~text:"Background color of processed text" + ~packing:(table#attach ~expand:`X ~left:0 ~top:1) () + in + let processing_label = GMisc.label + ~text:"Background color of text being processed" + ~packing:(table#attach ~expand:`X ~left:0 ~top:2) () + in + let () = background_label#set_xalign 0. in + let () = processed_label#set_xalign 0. in + let () = processing_label#set_xalign 0. in + let background_button = GButton.color_button + ~color:(Tags.color_of_string (!current.background_color)) + ~packing:(table#attach ~left:1 ~top:0) () + in + let processed_button = GButton.color_button + ~color:(Tags.get_processed_color ()) + ~packing:(table#attach ~left:1 ~top:1) () + in + let processing_button = GButton.color_button + ~color:(Tags.get_processing_color ()) + ~packing:(table#attach ~left:1 ~top:2) () + in + let reset_button = GButton.button + ~label:"Reset" + ~packing:box#pack () + in + let reset_cb () = + background_button#set_color (Tags.color_of_string "cornsilk"); + processing_button#set_color (Tags.color_of_string "light blue"); + processed_button#set_color (Tags.color_of_string "light green"); + in + let _ = reset_button#connect#clicked ~callback:reset_cb in + let label = "Color configuration" in + let callback () = + !current.background_color <- Tags.string_of_color background_button#color; + !current.processing_color <- Tags.string_of_color processing_button#color; + !current.processed_color <- Tags.string_of_color processed_button#color; + !refresh_background_color_hook (); + Tags.set_processing_color processing_button#color; + Tags.set_processed_color processed_button#color + in + custom ~label box callback true + in + (* let show_toolbar = bool @@ -369,7 +461,7 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.auto_complete <- s; - !auto_complete s) + !auto_complete_hook s) "Auto Complete" !current.auto_complete in @@ -416,44 +508,28 @@ let configure ?(apply=(fun () -> ())) () = "Stop interpreting before the current point" !current.stop_before in - let lax_syntax = - bool - ~f:(fun s -> !current.lax_syntax <- s) - "Relax read-only constraint at end of command" !current.lax_syntax - in - let vertical_tabs = bool - ~f:(fun s -> !current.vertical_tabs <- s) + ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ()) "Vertical tabs" !current.vertical_tabs in let opposite_tabs = bool - ~f:(fun s -> !current.opposite_tabs <- s) + ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ()) "Tabs on opposite side" !current.opposite_tabs in let encodings = combo "File charset encoding " - ~f:(fun s -> - match s with - | "UTF-8" -> - !current.encoding_use_utf8 <- true; - !current.encoding_use_locale <- false - | "LOCALE" -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- true - | _ -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- false; - !current.encoding_manual <- s; - ) + ~f:(fun s -> !current.encoding <- (inputenc_of_string s)) ~new_allowed: true - ["UTF-8";"LOCALE";!current.encoding_manual] - (if !current.encoding_use_utf8 then "UTF-8" - else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual) + ("UTF-8"::"LOCALE":: match !current.encoding with + |Emanual s -> [s] + |_ -> [] + ) + (string_of_inputenc !current.encoding) in let read_project = combo @@ -579,11 +655,11 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.contextual_menus_on_goal <- s; - !contextual_menus_on_goal s) + !contextual_menus_on_goal_hook s) "Contextual menus on goal" !current.contextual_menus_on_goal in - let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax; + let misc = [contextual_menus_on_goal;auto_complete;stop_before; vertical_tabs;opposite_tabs] in (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! @@ -591,6 +667,7 @@ let configure ?(apply=(fun () -> ())) () = let cmds = [Section("Fonts", Some `SELECT_FONT, [config_font]); + Section("Colors", Some `SELECT_COLOR, [config_color]); Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) @@ -604,9 +681,8 @@ let configure ?(apply=(fun () -> ())) () = config_appearance); *) Section("Externals", None, - [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print; - cmd_editor; - cmd_browse;doc_url;library_url]); + [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; + cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); Section("Tactics Wizard", None, [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, @@ -618,7 +694,7 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - let x = edit ~apply ~width:500 "Customizations" cmds in + let x = edit ~apply "Customizations" cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) diff --git a/ide/preferences.mli b/ide/preferences.mli index f55088f1..b680c6f0 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -7,9 +7,11 @@ (************************************************************************) type project_behavior = Ignore_args | Append_args | Subst_args +type inputenc = Elocale | Eutf8 | Emanual of string type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -25,9 +27,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -57,9 +57,12 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; } val save_pref : unit -> unit @@ -69,9 +72,11 @@ val current : pref ref val configure : ?apply:(unit -> unit) -> unit -> unit -val change_font : ( Pango.font_description -> unit) ref -val show_toolbar : (bool -> unit) ref -val auto_complete : (bool -> unit) ref -val resize_window : (unit -> unit) ref +(* Hooks *) +val refresh_font_hook : (unit -> unit) ref +val refresh_background_color_hook : (unit -> unit) ref +val refresh_toolbar_hook : (unit -> unit) ref +val resize_window_hook : (unit -> unit) ref +val refresh_tabs_hook : (unit -> unit) ref val use_default_doc_url : string diff --git a/ide/tags.ml b/ide/tags.ml index 52ba54dc..eeace465 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -13,6 +13,9 @@ let make_tag (tt:GText.tag_table) ~name prop = tt#add new_tag#as_tag; new_tag +let processed_color = ref "light green" +let processing_color = ref "light blue" + module Script = struct let table = GText.tag_table () @@ -23,8 +26,8 @@ struct let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"] let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"] let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"] - let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false] - let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false] + let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false] + let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false] let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false] let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"] let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false] @@ -35,7 +38,7 @@ end module Proof = struct let table = GText.tag_table () - let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"] + let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color] let hypothesis = make_tag table ~name:"hypothesis" [] let goal = make_tag table ~name:"goal" [] end @@ -45,3 +48,27 @@ struct let error = make_tag table ~name:"error" [`FOREGROUND "red"] end +let string_of_color clr = + let r = Gdk.Color.red clr in + let g = Gdk.Color.green clr in + let b = Gdk.Color.blue clr in + Printf.sprintf "#%04X%04X%04X" r g b + +let color_of_string s = + let colormap = Gdk.Color.get_system_colormap () in + Gdk.Color.alloc ~colormap (`NAME s) + +let get_processed_color () = color_of_string !processed_color + +let set_processed_color clr = + let s = string_of_color clr in + processed_color := s; + Script.processed#set_property (`BACKGROUND s); + Proof.highlight#set_property (`BACKGROUND s) + +let get_processing_color () = color_of_string !processing_color + +let set_processing_color clr = + let s = string_of_color clr in + processing_color := s; + Script.to_process#set_property (`BACKGROUND s) diff --git a/ide/tags.mli b/ide/tags.mli new file mode 100644 index 00000000..53a8c493 --- /dev/null +++ b/ide/tags.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(*
    - -
    - - +
    + +
    + +
    + + - diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html index afcdbe73..891fb328 100644 --- a/doc/common/styles/html/coqremote/header.html +++ b/doc/common/styles/html/coqremote/header.html @@ -6,44 +6,40 @@ Standard Library | The Coq Proof Assistant - + - - - + + + - - + +
    - - - - -
    + + + + +
    diff --git a/ide/coq.ml b/ide/coq.ml index 8b1fa0a3..07f0ece8 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -191,11 +191,29 @@ let coqtop_zombies () = Note: we use Unix.stderr in Unix.create_process to get debug messages from the coqtop's Ide_slave loop. + + NB: it's important to close coqide's descriptors (ide2top_w and top2ide_r) + in coqtop. We do this indirectly via [Unix.set_close_on_exec]. + This way, coqide has the only remaining copies of these descriptors, + and closing them later will have visible effects in coqtop. Cf man 7 pipe : + + - If all file descriptors referring to the write end of a pipe have been + closed, then an attempt to read(2) from the pipe will see end-of-file + (read(2) will return 0). + - If all file descriptors referring to the read end of a pipe have been + closed, then a write(2) will cause a SIGPIPE signal to be generated for + the calling process. If the calling process is ignoring this signal, + then write(2) fails with the error EPIPE. + + Symmetrically, coqtop's descriptors (ide2top_r and top2ide_w) should be + closed in coqide. *) let open_process_pid prog args = let (ide2top_r,ide2top_w) = Unix.pipe () in let (top2ide_r,top2ide_w) = Unix.pipe () in + Unix.set_close_on_exec ide2top_w; + Unix.set_close_on_exec top2ide_r; let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in assert (pid <> 0); Unix.close ide2top_r; @@ -250,7 +268,7 @@ let eval_call coqtop (c:'a Ide_intf.call) = Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c); flush coqtop.cin; let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in - (Ide_intf.to_answer xml : 'a Interface.value) + (Ide_intf.to_answer xml c : 'a Interface.value) let interp coqtop ?(raw=false) ?(verbose=true) s = eval_call coqtop (Ide_intf.interp (raw,verbose,s)) diff --git a/ide/coqide.ml b/ide/coqide.ml index 1bd490ab..07de4daf 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -41,14 +41,9 @@ object val mutable read_only : bool val mutable filename : string option val mutable stats : Unix.stats option - val mutable detached_views : GWindow.window list method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b method set_auto_complete : bool -> unit - method kill_detached_views : unit -> unit - method add_detached_view : GWindow.window -> unit - method remove_detached_view : GWindow.window -> unit - method filename : string option method stats : Unix.stats option method update_stats : unit @@ -104,7 +99,10 @@ type viewable_script = } let kill_session s = - s.analyzed_view#kill_detached_views (); + (* To close the detached views of this script, we call manually + [destroy] on it, triggering some callbacks in [detach_view]. + In a more modern lablgtk, rather use the page-removed signal ? *) + s.script#destroy (); Coq.kill_coqtop !(s.toplvl) let build_session s = @@ -442,6 +440,7 @@ let remove_tags (buffer:GText.buffer) from upto = Tags.Script.proof_decl; Tags.Script.qed ] (** Cut a part of the buffer in sentences and tag them. + Invariant: either this slice ends the buffer, or it ends with ".". May raise [Coq_lex.Unterminated] when the zone ends with an unterminated sentence. *) @@ -480,14 +479,18 @@ let is_char s c = s#char = Char.code c (** Search backward the first character of a sentence, starting at [iter] and going at most up to [soi] (meant to be the end of the locked zone). - Raise [Not_found] when no proper sentence start has been found, - in particular when the final "." of the locked zone is followed - by a non-blank character outside the locked zone. This non-blank - character will be signaled as erroneous in [tag_on_insert] below. *) + Raise [StartError] when no proper sentence start has been found. + A character following a ending "." is considered as a sentence start + only if this character is a blank. In particular, when a final "." + at the end of the locked zone isn't followed by a blank, then this + non-blank character will be signaled as erroneous in [tag_on_insert] below. +*) + +exception StartError let grab_sentence_start (iter:GText.iter) soi = let cond iter = - if iter#compare soi < 0 then raise Not_found; + if iter#compare soi < 0 then raise StartError; let prev = iter#backward_char in is_sentence_end prev && (not (is_char prev '.') || @@ -509,42 +512,35 @@ let rec grab_ending_dot (start:GText.iter) = (** Retag a zone that has been edited *) -let tag_on_insert = - (* possible race condition here : editing two buffers with a timedelta smaller - * than 1.5s might break the error recovery mechanism. *) - let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *) - fun buffer -> - try - (* the start of the non-locked zone *) - let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in - (* the inserted zone is between [prev_insert] and [insert] *) - let insert = buffer#get_iter_at_mark `INSERT in - let prev_insert = buffer#get_iter_at_mark (`NAME "prev_insert") in - (* [prev_insert] is normally always before [insert] even when deleting. - Let's check this nonetheless *) - let prev_insert = - if insert#compare prev_insert < 0 then insert else prev_insert - in - let start = grab_sentence_start prev_insert soi in - (** The status of "{" "}" as sentence delimiters is too fragile. - We retag up to the next "." instead. *) - let stop = grab_ending_dot insert in - let skip_curr = ref true in (* shall the callback be skipped ? by default yes*) - (!skip_last) := true; (* skip the previously created callback *) - skip_last := skip_curr; - try split_slice_lax buffer start stop - with Coq_lex.Unterminated -> - skip_curr := false; - let callback () = - if not !skip_curr then begin - try split_slice_lax buffer start buffer#end_iter - with Coq_lex.Unterminated -> () - end; false - in - ignore (Glib.Timeout.add ~ms:1500 ~callback) - with Not_found -> - let err_pos = buffer#get_iter_at_mark (`NAME "start_of_input") in - buffer#apply_tag Tags.Script.error ~start:err_pos ~stop:err_pos#forward_char +let tag_on_insert buffer = + (* the start of the non-locked zone *) + let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in + (* the inserted zone is between [prev_insert] and [insert] *) + let insert = buffer#get_iter_at_mark `INSERT in + let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in + (* [prev] is normally always before [insert] even when deleting. + Let's check this nonetheless *) + let prev, insert = + if insert#compare prev < 0 then insert, prev else prev, insert + in + try + let start = grab_sentence_start prev soi in + (** The status of "{" "}" as sentence delimiters is too fragile. + We retag up to the next "." instead. *) + let stop = grab_ending_dot insert in + try split_slice_lax buffer start stop + with Coq_lex.Unterminated -> + (* This shouldn't happen frequently. Either: + - we are at eof, with indeed an unfinished sentence. + - we have just inserted an opening of comment or string. + - the inserted text ends with a "." that interacts with the "." + found by [grab_ending_dot] to form a non-ending "..". + In any case, we retag up to eof, since this isn't that costly. *) + if not stop#is_end then + try split_slice_lax buffer start buffer#end_iter + with Coq_lex.Unterminated -> () + with StartError -> + buffer#apply_tag Tags.Script.error ~start:soi ~stop:soi#forward_char let force_retag buffer = try split_slice_lax buffer buffer#start_iter buffer#end_iter @@ -591,7 +587,6 @@ object(self) val mutable stats = None val mutable last_modification_time = 0. val mutable last_auto_save_time = 0. - val mutable detached_views = [] val mutable find_forward_instead_of_backward = false val mutable auto_complete_on = !current.auto_complete @@ -606,14 +601,6 @@ object(self) let y = f x in self#set_auto_complete old; y - method add_detached_view (w:GWindow.window) = - detached_views <- w::detached_views - method remove_detached_view (w:GWindow.window) = - detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views - - method kill_detached_views () = - List.iter (fun w -> w#destroy ()) detached_views; - detached_views <- [] method filename = filename method stats = stats @@ -820,7 +807,7 @@ object(self) begin let menu_callback = if !current.contextual_menus_on_goal then (fun s () -> ignore (self#insert_this_phrase_on_success - true true false ("progress "^s) s)) + true true false ("progress "^s) s)) else (fun _ _ -> ()) in try @@ -1007,6 +994,7 @@ object(self) if stop#starts_line then input_buffer#insert ~iter:stop insertphrase else input_buffer#insert ~iter:stop ("\n"^insertphrase); + tag_on_insert input_buffer; let start = self#get_start_of_input in input_buffer#move_mark ~where:stop (`NAME "start_of_input"); input_buffer#apply_tag (safety_tag safe) ~start ~stop; @@ -1231,7 +1219,7 @@ object(self) (List.exists (fun p -> self#insert_this_phrase_on_success true false false - ("progress "^p^".\n") (p^".\n")) l) + ("progress "^p^".") (p^".")) l) method active_keypress_handler k = let state = GdkEvent.Key.state k in @@ -1382,23 +1370,15 @@ object(self) ); ignore (input_buffer#connect#begin_user_action ~callback:(fun () -> - let here = input_buffer#get_iter_at_mark `INSERT in - input_buffer#move_mark (`NAME "prev_insert") here - ) + let where = self#get_insert in + input_buffer#move_mark (`NAME "prev_insert") ~where; + let start = self#get_start_of_input in + let stop = input_buffer#end_iter in + input_buffer#remove_tag Tags.Script.error ~start ~stop) ); ignore (input_buffer#connect#end_user_action ~callback:(fun () -> last_modification_time <- Unix.time (); - let r = input_view#visible_rect in - let stop = - input_view#get_iter_at_location - ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r) - ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r) - in - input_buffer#remove_tag - Tags.Script.error - ~start:self#get_start_of_input - ~stop; tag_on_insert input_buffer ) ); @@ -1795,6 +1775,8 @@ let forbid_quit_to_save () = end else false) +let logfile = ref None + let main files = (* Main window *) @@ -2354,7 +2336,7 @@ let main files = let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s) ~accel:(!current.modifier_for_tactics^sc) ~callback:(do_if_active (fun a -> a#insert_command - ("progress "^s^".\n") (s^".\n"))) in + ("progress "^s^".") (s^"."))) in let query_callback command _ = let word = get_current_word () in if not (word = "") then @@ -2380,6 +2362,24 @@ let main files = match key with |Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac) |None -> GAction.add_action name ~label ~callback ?accel:None + in + let detach_view _ = + (* Open a separate window containing the current buffer *) + let trm = session_notebook#current_term in + let w = GWindow.window ~show:true + ~width:(!current.window_width*2/3) + ~height:(!current.window_height*2/3) + ~position:`CENTER + ~title:(if trm.filename = "" then "*scratch*" else trm.filename) + () + in + let sb = GBin.scrolled_window ~packing:w#add () + in + let nv = GText.view ~buffer:trm.script#buffer ~packing:sb#add () + in + nv#misc#modify_font !current.text_font; + (* If the buffer in the main window is closed, destroy this detached view *) + ignore (trm.script#connect#destroy ~callback:w#destroy) in GAction.add_actions file_actions [ GAction.add_action "File" ~label:"_File"; @@ -2568,33 +2568,7 @@ let main files = ]; GAction.add_actions windows_actions [ GAction.add_action "Windows" ~label:"_Windows"; - GAction.add_action "Detach View" ~label:"Detach _View" - ~callback:(fun _ -> do_if_not_computing "detach view" - (function {script=v;analyzed_view=av} -> - let w = GWindow.window ~show:true - ~width:(!current.window_width*2/3) - ~height:(!current.window_height*2/3) - ~position:`CENTER - ~title:(match av#filename with - | None -> "*Unnamed*" - | Some f -> f) - () - in - let sb = GBin.scrolled_window - ~packing:w#add () - in - let nv = GText.view - ~buffer:v#buffer - ~packing:sb#add - () - in - nv#misc#modify_font - !current.text_font; - ignore (w#connect#destroy - ~callback: - (fun () -> av#remove_detached_view w)); - av#add_detached_view w) - [session_notebook#current_term]); + GAction.add_action "Detach View" ~label:"Detach _View" ~callback:detach_view ]; GAction.add_actions help_actions [ GAction.add_action "Help" ~label:"_Help"; @@ -2846,12 +2820,17 @@ let main files = \n-------------------\ \n" in + let display_log_file (b:GText.buffer) = + if !debug then + let file = match !logfile with None -> "stderr" | Some f -> f in + b#insert ("Debug mode is on, log file is "^file) + in let initial_about (b:GText.buffer) = let initial_string = "Welcome to CoqIDE, an Integrated Development Environment for Coq\n" in let coq_version = Coq.short_version () in - b#insert ~iter:b#start_iter "\n\n"; + display_log_file b; if Glib.Utf8.validate ("You are running " ^ coq_version) then b#insert ~iter:b#start_iter ("You are running " ^ coq_version); if Glib.Utf8.validate initial_string then @@ -2881,8 +2860,8 @@ let main files = then b#insert about_full_string; let coq_version = Coq.version () in if Glib.Utf8.validate coq_version - then b#insert coq_version - + then b#insert coq_version; + display_log_file b; in (* Remove default pango menu for textviews *) w#show (); diff --git a/ide/coqide.mli b/ide/coqide.mli index 18df1f6a..44de77f7 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -12,6 +12,9 @@ no /bin/sh when using create_process instead of open_process. *) val sup_args : string list ref +(** In debug mode under win32, messages are written to a log file *) +val logfile : string option ref + (** Filter the argv from coqide specific options, and set Minilib.coqtop_path accordingly *) val read_coqide_args : string list -> string list diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index f5138311..ebcecc17 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -6,18 +6,37 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -IFDEF QUARTZ THEN -external gtk_mac_init : (string -> unit) -> (unit -> bool) -> unit - = "caml_gtk_mac_init" +let _ = Coqide.ignore_break () +let _ = GtkMain.Main.init () -external gtk_mac_ready : ([> Gtk.widget ] as 'a) Gtk.obj -> ([> Gtk.widget ] as 'a) Gtk.obj -> - ([> Gtk.widget ] as 'a) Gtk.obj -> unit - = "caml_gtk_mac_ready" -END +(* We handle Gtk warning messages ourselves : + - on win32, we don't want them to end on a non-existing console + - we display critical messages via pop-ups *) -let initmac () = IFDEF QUARTZ THEN gtk_mac_init Coqide.do_load Coqide.forbid_quit_to_save ELSE () END +let catch_gtk_messages () = + let all_levels = + [`FLAG_RECURSION;`FLAG_FATAL;`ERROR;`CRITICAL;`WARNING; + `MESSAGE;`INFO;`DEBUG] + in + let handler ~level msg = + let header = "Coqide internal error: " in + let level_is tag = (level land Glib.Message.log_level tag) <> 0 in + if level_is `ERROR then + let () = GToolbox.message_box ~title:"Error" (header ^ msg) in + Coqide.crash_save 1 + else if level_is `CRITICAL then + GToolbox.message_box ~title:"Error" (header ^ msg) + else if level_is `DEBUG || Sys.os_type = "Win32" then + Ideutils.prerr_endline msg (* no-op unless in debug mode *) + else + Printf.eprintf "%s\n" msg + in + let catch domain = + ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler) + in + List.iter catch ["GLib";"Gtk";"Gdk";"Pango"] -let macready x y z = IFDEF QUARTZ THEN gtk_mac_ready x#as_widget y#as_widget z#as_widget ELSE () END +let () = catch_gtk_messages () (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) @@ -33,12 +52,18 @@ let set_win32_path () = *) let reroute_stdout_stderr () = + (* We anticipate a bit the argument parsing and look for -debug *) + let debug = List.mem "-debug" (Array.to_list Sys.argv) in + Ideutils.debug := debug; let out_descr = - if !Ideutils.debug then - Unix.descr_of_out_channel (snd (Filename.open_temp_file "coqide_" ".log")) + if debug then + let (name,chan) = Filename.open_temp_file "coqide_" ".log" in + Coqide.logfile := Some name; + Unix.descr_of_out_channel chan else snd (Unix.pipe ()) in + Unix.set_close_on_exec out_descr; Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr @@ -64,10 +89,17 @@ let () = reroute_stdout_stderr () END +IFDEF QUARTZ THEN + let osx = GosxApplication.osxapplication () + + let _ = + osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in + let _ = + osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in + () +END + let () = - Coqide.ignore_break (); - ignore (GtkMain.Main.init ()); - initmac () ; (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) @@ -82,13 +114,6 @@ let () = end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) - ignore ( - Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL; - `WARNING;`CRITICAL] - (fun ~level msg -> - if level land Glib.Message.log_level `WARNING <> 0 - then Printf.eprintf "Warning: %s\n" msg - else failwith ("Coqide internal error: " ^ msg))); let argl = Array.to_list Sys.argv in let argl = Coqide.read_coqide_args argl in let files = Coq.filter_coq_opts (List.tl argl) in @@ -96,9 +121,18 @@ let () = Coq.check_connection args; Coqide.sup_args := args; Coqide.main files; - if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); - macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") - (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); + if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()) + +IFDEF QUARTZ THEN + let () = + GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in + let () = + GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in + let () = + GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in + osx#ready () +END + while true do try GtkThread.main () diff --git a/ide/ide_mac_stubs.c b/ide/ide_mac_stubs.c deleted file mode 100644 index 2aeb2bf4..00000000 --- a/ide/ide_mac_stubs.c +++ /dev/null @@ -1,85 +0,0 @@ -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -GtkOSXApplication *theApp; -value open_file_fun, forbid_quit_fun, themenubar, pref_item, about_item; - -static void osx_accel_map_foreach_lcb(gpointer data,const gchar *accel_path, - guint accel_key, GdkModifierType accel_mods, - gboolean changed) { - if (accel_mods & GDK_CONTROL_MASK) { - accel_mods |= GDK_META_MASK; - accel_mods &= (accel_mods & GDK_MOD1_MASK) ? ~GDK_MOD1_MASK : ~GDK_CONTROL_MASK; - if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { - g_print("could not change accelerator %s\n",accel_path); - } - } - if (accel_mods & GDK_MOD1_MASK) { - accel_mods &= ~ GDK_MOD1_MASK; - accel_mods |= GDK_CONTROL_MASK; - if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { - g_print("could not change accelerator %s\n",accel_path); - } - } -} - -static gboolean deal_with_open(GtkOSXApplication *app, gchar *path, gpointer user_data) -{ - CAMLparam0(); - CAMLlocal2(string_path, res); - string_path = caml_copy_string(path); - res = caml_callback_exn(open_file_fun,string_path); - gboolean truc = !(Is_exception_result(res)); - CAMLreturnT(gboolean, truc); -} - -static gboolean deal_with_quit(GtkOSXApplication *app, gpointer user_data) -{ - CAMLparam0(); - CAMLlocal1(res); - res = caml_callback_exn(forbid_quit_fun,Val_unit); - gboolean truc = (Bool_val(res))||((Is_exception_result(res))); - CAMLreturnT(gboolean, truc); -} - -CAMLprim value caml_gtk_mac_init(value open_file_the_fun, value forbid_quit_the_fun) -{ - CAMLparam2(open_file_the_fun,forbid_quit_the_fun); - open_file_fun = open_file_the_fun; - caml_register_generational_global_root(&open_file_fun); - forbid_quit_fun = forbid_quit_the_fun; - caml_register_generational_global_root(&forbid_quit_fun); - theApp = g_object_new(GTK_TYPE_OSX_APPLICATION, NULL); - g_signal_connect(theApp, "NSApplicationOpenFile", G_CALLBACK(deal_with_open), NULL); - g_signal_connect(theApp, "NSApplicationBlockTermination", G_CALLBACK(deal_with_quit), NULL); - CAMLreturn (Val_unit); -} - -CAMLprim value caml_gtk_mac_ready(value menubar, value prefs, value about) -{ - GtkOSXApplicationMenuGroup * pref_grp, * about_grp; - CAMLparam3(menubar,prefs,about); - themenubar = menubar; - pref_item = prefs; - about_item = about; - caml_register_generational_global_root(&themenubar); - caml_register_generational_global_root(&pref_item); - caml_register_generational_global_root(&about_item); - /* gtk_accel_map_foreach(NULL, osx_accel_map_foreach_lcb);*/ - gtk_osxapplication_set_menu_bar(theApp,check_cast(GTK_MENU_SHELL,themenubar)); - gtk_osxapplication_insert_app_menu_item(theApp,check_cast(GTK_WIDGET,about_item),1); - gtk_osxapplication_insert_app_menu_item(theApp,gtk_separator_menu_item_new(),2); - gtk_osxapplication_insert_app_menu_item(theApp,check_cast(GTK_WIDGET,pref_item),3); - gtk_osxapplication_insert_app_menu_item(theApp,gtk_separator_menu_item_new(),4); - gtk_osxapplication_ready(theApp); - CAMLreturn(Val_unit); -} diff --git a/ide/preferences.ml b/ide/preferences.ml index 17216b92..2fb5023f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -35,6 +35,10 @@ let mod_to_str (m:Gdk.Tags.modifier) = | `MOD5 -> "" | `CONTROL -> "" | `SHIFT -> "" + | `HYPER -> "" + | `META -> "" + | `RELEASE -> "" + | `SUPER -> "" | `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> "" let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml index 57939266..905c3485 100644 --- a/ide/utils/okey.ml +++ b/ide/utils/okey.ml @@ -47,6 +47,10 @@ let int_of_modifier = function | `BUTTON3 -> 1024 | `BUTTON4 -> 2048 | `BUTTON5 -> 4096 + | `HYPER -> 1 lsl 22 + | `META -> 1 lsl 20 + | `RELEASE -> 1 lsl 30 + | `SUPER -> 1 lsl 21 let print_modifier l = List.iter @@ -65,7 +69,11 @@ let print_modifier l = | `BUTTON2 -> "B2" | `BUTTON3 -> "B3" | `BUTTON4 -> "B4" - | `BUTTON5 -> "B5") + | `BUTTON5 -> "B5" + | `HYPER -> "HYPER" + | `META -> "META" + | `RELEASE -> "" + | `SUPER -> "SUPER") m)^" ") ) l; diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 19e1fef5..20b9c2a3 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -250,7 +250,9 @@ and check_same_fix_binder bl1 bl2 = check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2) | _ -> failwith "not same binder") bl1 bl2 -let is_same_type c d = try let () = check_same_type c d in true with Failure _ -> false +let is_same_type c d = + try let () = check_same_type c d in true + with Failure _ | Invalid_argument _ -> false (**********************************************************************) (* mapping patterns to cases_pattern_expr *) @@ -374,11 +376,12 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | (keyrule,pat,n as _rule)::rules -> try match t,n with - | PatCstr (loc,(ind,_),l,na), n when n = Some 0 or n = None or - n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams -> + | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or + n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams) + && (match keyrule with SynDefRule _ -> true | _ -> false) -> (* Abbreviation for the constructor name only *) (match keyrule with - | NotationRule (sc,ntn) -> raise No_match + | NotationRule _ -> assert false | SynDefRule kn -> let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 45df005c..81e4501a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1411,7 +1411,8 @@ let internalize sigma globalenv env allow_patvar lvar c = | None -> [], None in let na = match tm', na with - | GVar (loc,id), None when Idset.mem id env.ids -> loc,Name id + | GVar (loc,id), None when not (List.mem_assoc id (snd lvar)) -> + loc,Name id | GRef (loc, VarRef id), None -> loc,Name id | _, None -> dummy_loc,Anonymous | _, Some (loc,na) -> loc,na in diff --git a/kernel/univ.ml b/kernel/univ.ml index 6aeb7390..028eaeb4 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -125,9 +125,12 @@ let sup u v = (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list } + { univ: UniverseLevel.t; + lt: UniverseLevel.t list; + le: UniverseLevel.t list; + rank: int } -let terminal u = {univ=u; lt=[]; le=[]} +let terminal u = {univ=u; lt=[]; le=[]; rank=0} (* A UniverseLevel.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) @@ -405,24 +408,46 @@ let setleq_if (g,arcu) v = (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = - match between g arcu arcv with - | arcu::v -> (* arcu is chosen as canonical and all others (v) are *) - (* redirected to it *) - let redirect (g,w,w') arcv = - let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',list_unionq arcv.lt w,arcv.le@w') - in - let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu w in - let g_arcu = List.fold_left setleq_if g_arcu w' in - fst g_arcu - | [] -> anomaly "Univ.between" + (* we find the arc with the biggest rank, and we redirect all others to it *) + let arcu, g, v = + let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = + if arc.rank >= max_rank + then (arc.rank, max_rank, arc, best_arc::rest) + else (max_rank, old_max_rank, best_arc, arc::rest) + in + match between g arcu arcv with + | [] -> anomaly "Univ.between" + | arc::rest -> + let (max_rank, old_max_rank, best_arc, rest) = + List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in + if max_rank > old_max_rank then best_arc, g, rest + else begin + (* one redirected node also has max_rank *) + let arcu = {best_arc with rank = max_rank + 1} in + arcu, enter_arc arcu g, rest + end + in + let redirect (g,w,w') arcv = + let g' = enter_equiv_arc arcv.univ arcu.univ g in + (g',list_unionq arcv.lt w,arcv.le@w') + in + let (g',w,w') = List.fold_left redirect (g,[],[]) v in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu w in + let g_arcu = List.fold_left setleq_if g_arcu w' in + fst g_arcu (* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) -let merge_disc g arcu arcv = +let merge_disc g arc1 arc2 = + let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, g = + if arc1.rank <> arc2.rank then arcu, g + else + let arcu = {arcu with rank = succ arcu.rank} in + arcu, enter_arc arcu g + in let g' = enter_equiv_arc arcv.univ arcu.univ g in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in @@ -563,7 +588,7 @@ let normalize_universes g = in let canonicalize u = function | Equiv _ -> Equiv (repr u) - | Canonical {univ=v; lt=lt; le=le} -> + | Canonical {univ=v; lt=lt; le=le; rank=rank} -> assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in @@ -575,6 +600,7 @@ let normalize_universes g = univ = v; lt = UniverseLSet.elements lt; le = UniverseLSet.elements le; + rank = rank } in UniverseLMap.mapi canonicalize g @@ -632,7 +658,8 @@ let bellman_ford bottom g = let node = Canonical { univ = bottom; lt = []; - le = UniverseLSet.elements vertices + le = UniverseLSet.elements vertices; + rank = 0 } in UniverseLMap.add bottom node g in let rec iter count accu = @@ -692,12 +719,12 @@ let sort_universes orig = | false, true -> push res v | false, false -> res end - | Canonical {univ=v; lt=lt; le=le} -> + | Canonical {univ=v; lt=lt; le=le; rank=r} -> assert (u == v); if filter u then let lt = List.filter filter lt in let le = List.filter filter le in - UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res + UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in @@ -717,7 +744,8 @@ let sort_universes orig = let g = UniverseLMap.add u (Canonical { univ = u; le = []; - lt = [types.(i+1)] + lt = [types.(i+1)]; + rank = 1 }) g in aux (i+1) g else g in aux 0 g diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml index bf931d75..19bab4f6 100644 --- a/lib/xml_parser.ml +++ b/lib/xml_parser.ml @@ -42,6 +42,7 @@ type error_msg = | AttributeValueExpected | EndOfTagExpected of string | EOFExpected + | Empty type error = error_msg * error_pos @@ -117,13 +118,13 @@ let rec read_node s = | Xml_lexer.PCData s -> PCData s | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) | Xml_lexer.Tag (tag, attr, false) -> - let elements = read_elems ~tag s in + let elements = read_elems tag s in Element (tag, attr, canonicalize elements) | t -> push t s; raise NoMoreData and - read_elems ?tag s = + read_elems tag s = let elems = ref [] in (try while true do @@ -137,12 +138,8 @@ and with NoMoreData -> ()); match pop s with - | Xml_lexer.Endtag s when Some s = tag -> List.rev !elems - | Xml_lexer.Eof when tag = None -> List.rev !elems - | t -> - match tag with - | None -> raise (Internal_error EOFExpected) - | Some s -> raise (Internal_error (EndOfTagExpected s)) + | Xml_lexer.Endtag s when s = tag -> List.rev !elems + | t -> raise (Internal_error (EndOfTagExpected tag)) let rec read_xml s = let node = read_node s in @@ -162,24 +159,25 @@ let convert = function | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity +let error_of_exn stk = function + | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty + | NoMoreData -> NodeExpected + | Internal_error e -> e + | Xml_lexer.Error e -> convert e + | e -> raise e + let do_parse xparser source = + let stk = Stack.create() in try Xml_lexer.init source; - let s = { source = source; xparser = xparser; stack = Stack.create(); } in + let s = { source = source; xparser = xparser; stack = stk } in let x = read_xml s in if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close source; x - with - | NoMoreData -> - Xml_lexer.close source; - raise (!xml_error NodeExpected source) - | Internal_error e -> - Xml_lexer.close source; - raise (!xml_error e source) - | Xml_lexer.Error e -> - Xml_lexer.close source; - raise (!xml_error (convert e) source) + with e -> + Xml_lexer.close source; + raise (!xml_error (error_of_exn stk e) source) let parse p = function | SChannel ch -> do_parse p (Lexing.from_channel ch) @@ -208,6 +206,7 @@ let error_msg = function | AttributeValueExpected -> "Attribute value expected" | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag | EOFExpected -> "End of file expected" + | Empty -> "Empty" let error (msg,pos) = if pos.emin = pos.emax then diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index e3e7ac4d..cc9bcd33 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -59,6 +59,7 @@ type error_msg = | AttributeValueExpected | EndOfTagExpected of string | EOFExpected + | Empty type error = error_msg * error_pos diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c866356a..184985b5 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -422,9 +422,9 @@ let extra_rules () = begin if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico]) in if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;A"-o";Px fo]); + (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;camlp4incl;A"-o";Px fo]); rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;A"-o";Px fb]); + (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;camlp4incl;A"-o";Px fb]); in (** Coq files dependencies *) diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 3720eb20..17ef9f85 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -260,7 +260,14 @@ let rec pr_generic prc prlc prtac prpat x = let rec tacarg_using_rule_token pr_gen = function | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al) - | None :: l, a :: al -> pr_gen a :: tacarg_using_rule_token pr_gen (l,al) + | None :: l, a :: al -> + let print_it = + match genarg_tag a with + | OptArgType _ -> fold_opt (fun _ -> true) false a + | _ -> true + in + let r = tacarg_using_rule_token pr_gen (l,al) in + if print_it then pr_gen a :: r else r | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" @@ -423,7 +430,7 @@ let pr_clauses default_is_concl pr_id = function (if occs = no_occurrences_expr then mt () else pr_with_occurrences (fun () -> str" |- *") (occs,()))) -let pr_orient b = if b then mt () else str " <-" +let pr_orient b = if b then mt () else str "<- " let pr_multi = function | Precisely 1 -> mt () @@ -806,17 +813,17 @@ and pr_atom1 = function (* Equivalence relations *) | TacReflexivity as x -> pr_atom0 x - | TacSymmetry cls -> str "symmetry " ++ pr_clauses (Some true) pr_ident cls + | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c | TacTransitivity None -> str "etransitivity" (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> - hov 1 (str (with_evars ev "rewrite") ++ + hov 1 (str (with_evars ev "rewrite") ++ spc () ++ prlist_with_sep (fun () -> str ","++spc()) (fun (b,m,c) -> - pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c) + pr_orient b ++ pr_multi m ++ pr_with_bindings c) l ++ pr_clauses (Some true) pr_ident cl ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index fd134899..956ece79 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -14,6 +14,10 @@ Require Import ExtrOcamlBasic. (** Disclaimer: trying to obtain efficient certified programs by extracting [nat] into [int] is definitively *not* a good idea: + - This is just a syntactic adaptation, many things can go wrong, + such as name captures (e.g. if you have a constant named "int" + in your development, or a module named "Pervasives"). See bug #2878. + - Since [int] is bounded while [nat] is (theoretically) infinite, you have to make sure by yourself that your program will not manipulate numbers greater than [max_int]. Otherwise you should @@ -34,17 +38,17 @@ Require Import ExtrOcamlBasic. (** Mapping of [nat] into [int]. The last string corresponds to a [nat_case], see documentation of [Extract Inductive]. *) -Extract Inductive nat => int [ "0" "succ" ] +Extract Inductive nat => int [ "0" "Pervasives.succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "(+)". -Extract Constant pred => "fun n -> max 0 (n-1)". -Extract Constant minus => "fun n m -> max 0 (n-m)". +Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant mult => "( * )". -Extract Inlined Constant max => max. -Extract Inlined Constant min => min. +Extract Inlined Constant max => "Pervasives.max". +Extract Inlined Constant min => "Pervasives.min". (*Extract Inlined Constant nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index c8c40e73..ab634329 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -34,12 +34,12 @@ Extract Inductive N => int [ "0" "" ] (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "(+)". -Extract Constant Pos.succ => "succ". -Extract Constant Pos.pred => "fun n -> max 1 (n-1)". -Extract Constant Pos.sub => "fun n m -> max 1 (n-m)". +Extract Constant Pos.succ => "Pervasives.succ". +Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". +Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". Extract Constant Pos.mul => "( * )". -Extract Constant Pos.min => "min". -Extract Constant Pos.max => "max". +Extract Constant Pos.min => "Pervasives.min". +Extract Constant Pos.max => "Pervasives.max". Extract Constant Pos.compare => "fun x y -> if x=y then Eq else if x @@ -47,12 +47,12 @@ Extract Constant Pos.compare_cont => Extract Constant N.add => "(+)". -Extract Constant N.succ => "succ". -Extract Constant N.pred => "fun n -> max 0 (n-1)". -Extract Constant N.sub => "fun n m -> max 0 (n-m)". +Extract Constant N.succ => "Pervasives.succ". +Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant N.mul => "( * )". -Extract Constant N.min => "min". -Extract Constant N.max => "max". +Extract Constant N.min => "Pervasives.min". +Extract Constant N.max => "Pervasives.max". Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". Extract Constant N.compare => @@ -60,19 +60,19 @@ Extract Constant N.compare => Extract Constant Z.add => "(+)". -Extract Constant Z.succ => "succ". -Extract Constant Z.pred => "pred". +Extract Constant Z.succ => "Pervasives.succ". +Extract Constant Z.pred => "Pervasives.pred". Extract Constant Z.sub => "(-)". Extract Constant Z.mul => "( * )". Extract Constant Z.opp => "(~-)". -Extract Constant Z.abs => "abs". -Extract Constant Z.min => "min". -Extract Constant Z.max => "max". +Extract Constant Z.abs => "Pervasives.abs". +Extract Constant Z.min => "Pervasives.min". +Extract Constant Z.max => "Pervasives.max". Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x "fun p -> p". -Extract Constant Z.abs_N => "abs". +Extract Constant Z.abs_N => "Pervasives.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index e76c6919..0a17453c 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -130,7 +130,7 @@ let rec nb_default_params env c = (* Enriching a signature with implicit information *) -let sign_with_implicits r s = +let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] @@ -139,7 +139,7 @@ let sign_with_implicits r s = if sign = Keep && List.mem i implicits then Kill Kother else sign in sign' :: add_impl (succ i) s in - add_impl 1 s + add_impl (1+nb_params) s (* Enriching a exception message *) @@ -667,20 +667,23 @@ and extract_cst_app env mle mlt kn args = let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in - let s_full = sign_with_implicits (ConstRef kn) s_full in + let s_full = sign_with_implicits (ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = - if not magic1 then + if magic1 || lang () <> Ocaml then mla + else try + (* for better optimisations later, we discard dependent args + of projections and replace them by fake args that will be + removed during final pretty-print. *) let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with _ -> mla - else mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left @@ -726,7 +729,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in - let s = sign_with_implicits (ConstructRef cp) s in + let s = sign_with_implicits (ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); @@ -805,7 +808,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) let s = List.map (type2sign env) oi.ip_types.(i) in - let s = sign_with_implicits r s in + let s = sign_with_implicits r s mi.ind_nparams in (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) @@ -876,7 +879,7 @@ let extract_std_constant env kn body typ = let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) - let s = sign_with_implicits (ConstRef kn) s in + let s = sign_with_implicits (ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all @@ -923,6 +926,19 @@ let extract_std_constant env kn body typ = in trm, type_expunge_from_sign env s t +(* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) +let extract_axiom env kn typ = + reset_meta_count (); + (* The short type [t] (i.e. possibly with abbreviations). *) + let t = snd (record_constant_type env kn (Some typ)) in + (* The real type [t']: without head products, expanded, *) + (* and with [Tvar] translated to [Tvar'] (not instantiable). *) + let l,_ = type_decomp (expand env (var2var' t)) in + let s = List.map (type2sign env) l in + (* Check for user-declared implicit information *) + let s = sign_with_implicits (ConstRef kn) s 0 in + type_expunge_from_sign env s t + let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in let types = Array.make n (Tdummy Kother) @@ -959,8 +975,8 @@ let extract_constant env kn cb = in Dtype (r, vl, t) in let mk_ax () = - let t = snd (record_constant_type env kn (Some typ)) in - Dterm (r, MLaxiom, type_expunge env t) + let t = extract_axiom env kn typ in + Dterm (r, MLaxiom, t) in let mk_def c = let e,t = extract_std_constant env kn c typ in diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 257e1c1c..bd997d2d 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -26,9 +26,9 @@ let rec msid_of_mt = function (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) -let se_iter do_decl do_spec = +let se_iter do_decl do_spec do_mp = let rec mt_iter = function - | MTident _ -> () + | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in @@ -38,7 +38,12 @@ let se_iter do_decl do_spec = in let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) - | MTwith (mt,_)->mt_iter mt + | MTwith (mt,ML_With_module(idl,mp))-> + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl + in + mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s @@ -51,15 +56,16 @@ let se_iter do_decl do_spec = me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function - | MEident _ -> () + | MEident mp -> do_mp mp | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt | MEapply (me,me') -> me_iter me; me_iter me' | MEstruct (msid, sel) -> List.iter se_iter sel in se_iter -let struct_iter do_decl do_spec s = - List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec) sel) s +let struct_iter do_decl do_spec do_mp s = + List.iter + (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) @@ -141,7 +147,7 @@ let decl_ast_search f = function | _ -> () let struct_ast_search f s = - try struct_iter (decl_ast_search f) (fun _ -> ()) s; false + try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false with Found -> true let rec type_search f = function @@ -165,7 +171,9 @@ let spec_type_search f = function | Sval (_,u) -> type_search f u let struct_type_search f s = - try struct_iter (decl_type_search f) (spec_type_search f) s; false + try + struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s; + false with Found -> true @@ -247,34 +255,32 @@ let dfix_to_mlfix rv av i = let c = Array.map (subst 0) av in MLfix(i, ids, c) +(* [optim_se] applies the [normalize] function everywhere and does the + inlining of code. The inlined functions are kept for the moment in + order to preserve the global interface, later [depcheck_se] will get + rid of them if possible *) + let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - if top && i && not (library ()) && not (List.mem r to_appear) - then optim_se top to_appear s lse - else - let d = match optimize_fix a with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) - | a -> Dterm (r, a, t) - in (l,SEdecl d) :: (optim_se top to_appear s lse) + let d = match optimize_fix a with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) + in + (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in - let all = ref true in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s - else all := false done; - if !all && top && not (library ()) - && (array_for_all (fun r -> not (List.mem r to_appear)) rv) - then optim_se top to_appear s lse - else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) @@ -289,7 +295,7 @@ and optim_me to_appear s = function (* After these optimisations, some dependencies may not be needed anymore. For non-library extraction, we recompute a minimal set of dependencies - for first-level objects *) + for first-level definitions (no module pruning yet). *) exception NoDepCheck @@ -362,7 +368,7 @@ let rec depcheck_se = function end | t :: se -> let se' = depcheck_se se in - se_iter compute_deps_decl compute_deps_spec t; + se_iter compute_deps_decl compute_deps_spec add_needed_mp t; t :: se' let rec depcheck_struct = function @@ -370,7 +376,7 @@ let rec depcheck_struct = function | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in - (mp,lse')::struc' + if lse' = [] then struc' else (mp,lse')::struc' let check_implicits = function | MLexn s -> @@ -389,9 +395,9 @@ let optimize_struct to_appear struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in - let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in ignore (struct_ast_search check_implicits opt_struc); - if library () then opt_struc + if library () then + List.filter (fun (_,lse) -> lse<>[]) opt_struc else begin reset_needed (); List.iter add_needed (fst to_appear); diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index c88c6669..43b08840 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -308,13 +308,14 @@ let build_constructors_of_type ind' argl = (Global.env ()) construct in - let argl = - if argl = [] - then + let argl = match argl with + | None -> Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) + (Array.init cst_narg (fun _ -> mkGHole ()) ) - else argl + | Some l -> + Array.to_list + (Array.init npar (fun _ -> mkGHole ()))@l in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) @@ -653,7 +654,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type ind None in assert (Array.length case_pats = 2); let brl = list_map_i @@ -669,12 +670,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = - List.map + Some (List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) - nal + nal) in let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 11d9a071..ab424c22 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -14,14 +14,14 @@ Delimit Scope Int_scope with I. Module Type Int. - Parameter int : Set. + Parameter t : Set. - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. - Parameter opp : int -> int. - Parameter minus : int -> int -> int. - Parameter mult : int -> int -> int. + Parameter zero : t. + Parameter one : t. + Parameter plus : t -> t -> t. + Parameter opp : t -> t. + Parameter minus : t -> t -> t. + Parameter mult : t -> t -> t. Notation "0" := zero : Int_scope. Notation "1" := one : Int_scope. @@ -33,14 +33,14 @@ Module Type Int. Open Scope Int_scope. (* First, int is a ring: *) - Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). + Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). (* int should also be ordered: *) - Parameter le : int -> int -> Prop. - Parameter lt : int -> int -> Prop. - Parameter ge : int -> int -> Prop. - Parameter gt : int -> int -> Prop. + Parameter le : t -> t -> Prop. + Parameter lt : t -> t -> Prop. + Parameter ge : t -> t -> Prop. + Parameter gt : t -> t -> Prop. Notation "x <= y" := (le x y): Int_scope. Notation "x < y" := (lt x y) : Int_scope. Notation "x >= y" := (ge x y) : Int_scope. @@ -61,7 +61,7 @@ Module Type Int. forall i j k, 0 < k -> i < j -> k*i int -> comparison. + Parameter compare : t -> t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i t1 = t2. Proof. - simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); - [ intros; elim beq_true with (1 := H); trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 H3; elim H with (1 := H3); trivial - | intros; elim beq_nat_true with (1 := H); trivial ]. + induction t1; destruct t2; simpl in *; try discriminate; + (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; + auto using beq_true, beq_nat_true. +Qed. + +Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. +Proof. + induction t0; simpl in *; try (apply andb_true_iff; split); trivial. + - now apply beq_iff. + - now apply beq_nat_true_iff. Qed. Ltac trivial_case := unfold not; intros; discriminate. @@ -1058,31 +1056,7 @@ Ltac trivial_case := unfold not; intros; discriminate. Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. Proof. - simple induction t1; - [ intros z t2; case t2; try trivial_case; simpl; unfold not; - intros; elim beq_false with (1 := H); simplify_eq H0; - auto - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t2; case t2; try trivial_case; simpl; intros t21 H3; - unfold not; intro H4; elim H1 with (1 := H3); - simplify_eq H4; auto - | intros n t2; case t2; try trivial_case; simpl; unfold not; - intros; elim beq_nat_false with (1 := H); simplify_eq H0; - auto ]. + intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. Qed. (* \subsubsection{Tactiques pour éliminer ces tests} @@ -1919,9 +1893,9 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := end end. -Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). +Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. - simple induction t; simpl; + simple induction trace; simpl; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; @@ -2093,11 +2067,8 @@ Definition constant_not_nul (i : nat) (h : hyps) := Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. - unfold valid_hyps, constant_not_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl. - - elim_beq i1 i0; auto; simpl; intros H1 H2; - elim H1; symmetry ; auto. + unfold valid_hyps, constant_not_nul; intros i ep e lp H. + generalize (nth_valid ep e i lp H); Simplify. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) @@ -2131,12 +2102,12 @@ Definition not_exact_divide (k1 k2 : int) (body : term) end. Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t i : nat), - valid_hyps (not_exact_divide k1 k2 body t i). + forall (k1 k2 : int) (body : term) (t0 i : nat), + valid_hyps (not_exact_divide k1 k2 body t0 i). Proof. unfold valid_hyps, not_exact_divide; intros; generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t e), <-H1. + rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. @@ -2509,9 +2480,9 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. -Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). +Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction t; simpl; + simple induction tr; simpl; [ unfold valid_list_hyps; simpl; intros; left; apply (constant_not_nul_valid n ep e lp H) | unfold valid_list_hyps; simpl; intros; left; @@ -2522,7 +2493,7 @@ Proof. (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) + apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply @@ -2618,10 +2589,10 @@ Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : - forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. + forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), + interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. Proof. - intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). + intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). Qed. @@ -2936,13 +2907,13 @@ Proof. | intro; apply ne_left_2; assumption ] | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); simpl; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; + [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); + | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); rewrite plus_opp_r; assumption | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); rewrite plus_opp_r; assumption | rewrite gt_lt_iff; apply lt_left_inv; assumption | apply lt_left_inv; assumption diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 6a5878b3..dfcc8526 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -663,6 +663,7 @@ let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in + let obls = Array.copy obls in Array.iteri (fun i x -> match x.obl_body with diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1819dc52..38355cf1 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1763,7 +1763,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) - let pred2 = lift (List.length arsign) t in + let pred2 = lift (List.length (List.flatten arsign)) t in [sigma1, pred1; sigma, pred2] (* Some type annotation *) | Some rtntyp, _ -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 69ff2af9..a74e4cb4 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -389,6 +389,8 @@ let rec detype (isgoal:bool) avoid env t = with _ -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) + | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> + detype isgoal avoid env c1 | Cast (c1,k,c2) -> GCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2)) | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index fa29243a..b0248a84 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -135,15 +135,20 @@ let whd_head_evar_stack sigma c = let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c) -let noccur_evar evd evk c = - let rec occur_rec c = match kind_of_term c with - | Evar (evk',_ as ev') -> +let noccur_evar env evd evk c = + let rec occur_rec k c = match kind_of_term c with + | Evar (evk',args' as ev') -> (match safe_evar_value evd ev' with - | Some c -> occur_rec c - | None -> if evk = evk' then raise Occur) - | _ -> iter_constr occur_rec c + | Some c -> occur_rec k c + | None -> + if evk = evk' then raise Occur else Array.iter (occur_rec k) args') + | Rel i when i > k -> + (match pi2 (Environ.lookup_rel (i-k) env) with + | None -> () + | Some b -> occur_rec k (lift i b)) + | _ -> iter_constr_with_binders succ occur_rec k c in - try occur_rec c; true with Occur -> false + try occur_rec 0 c; true with Occur -> false let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with @@ -741,7 +746,8 @@ let is_unification_pattern_meta env nb m l t = None let is_unification_pattern_evar env evd (evk,args) l t = - if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar evd evk t then + if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar env evd evk t + then let args = remove_instance_local_defs evd evk (Array.to_list args) in let n = List.length args in match find_unification_pattern_args env (args @ l) t with @@ -1112,10 +1118,11 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ | Not_found -> CannotInvert | NotUnique -> Invertible NoUniqueProjection -let invert_arg evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = +let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in match res with - | Invertible (UniqueProjection (c,_)) when not (noccur_evar evd evk c) -> + | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c) + -> CannotInvert | _ -> res @@ -1153,10 +1160,11 @@ let extract_candidates sols = let filter_of_projection = function Invertible _ -> true | _ -> false -let invert_invertible_arg evd aliases k (evk,argsv) args' = +let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let evi = Evd.find_undefined evd evk in let subst,_ = make_projectable_subst aliases evd evi argsv in - let projs = array_map_to_list (invert_arg evd aliases k evk subst) args' in + let projs = + array_map_to_list (invert_arg fullenv evd aliases k evk subst) args' in Array.of_list (extract_unique_projections projs) (* Redefines an evar with a smaller context (i.e. it may depend on less @@ -1364,12 +1372,14 @@ let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t = let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)= let filter1 = - restrict_upon_filter evd evk1 (noccur_evar evd evk2) (Array.to_list argsv1) + restrict_upon_filter evd evk1 (noccur_evar env evd evk2) + (Array.to_list argsv1) in let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in let filter2 = - restrict_upon_filter evd evk2 (noccur_evar evd evk1) (Array.to_list argsv2) + restrict_upon_filter evd evk2 (noccur_evar env evd evk1) + (Array.to_list argsv2) in let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in @@ -1389,7 +1399,7 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 try let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in - evd,mkEvar (evk1',invert_invertible_arg evd aliases k2 ev2 args1) + evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1) with | EvarSolvedWhileRestricting (evd,ev1) -> raise (EvarSolvedOnTheFly (evd,ev1)) @@ -1585,7 +1595,7 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in - let evd,body = project_evar_on_evar conv_algo env !evdref aliases k ev' ev in + let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k ev' ev in evdref := evd; body with diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 24c5ba5b..8e4b211f 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -346,8 +346,38 @@ let rec cases_pattern_of_glob_constr na = function | GHole (loc,_) -> PatVar (loc,na) | GRef (loc,ConstructRef cstr) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> - PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) -> + let mib,_ = Global.lookup_inductive ind in + let nparams = mib.Declarations.mind_nparams in + if nparams > List.length args then + user_err_loc (loc,"",Pp.str "Invalid notation for pattern."); + let params,args = list_chop nparams args in + List.iter (function GHole _ -> () + | _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern.")) + params; + let args = List.map (cases_pattern_of_glob_constr Anonymous) args in + PatCstr (loc,cstr,args,na) + | _ -> raise Not_found + +let rec cases_pattern_of_glob_constr na = function + | GVar (loc,id) when na<>Anonymous -> + (* Unable to manage the presence of both an alias and a variable *) + raise Not_found + | GVar (loc,id) -> PatVar (loc,Name id) + | GHole (loc,_) -> PatVar (loc,na) + | GRef (loc,ConstructRef cstr) -> + PatCstr (loc,cstr,[],na) + | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) -> + let mib,_ = Global.lookup_inductive ind in + let nparams = mib.Declarations.mind_nparams in + if nparams > List.length args then + user_err_loc (loc,"",Pp.str "Invalid notation for pattern."); + let params,args = list_chop nparams args in + List.iter (function GHole _ -> () + | _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern.")) + params; + let args = List.map (cases_pattern_of_glob_constr Anonymous) args in + PatCstr (loc,cstr,args,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 665491e7..22aacb29 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -42,6 +42,11 @@ let e_type_judgment env evdref j = evdref := evd; { utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j +let e_assumption_of_judgment env evdref j = + try (e_type_judgment env evdref j).utj_val + with TypeError _ -> + error_assumption env j + let e_judge_of_apply env evdref funj argjv = let rec apply_rec n typ = function | [] -> @@ -150,7 +155,7 @@ let rec execute env evdref cstr = | Evar ev -> let ty = Evd.existential_type !evdref ev in let jty = execute env evdref (whd_evar !evdref ty) in - let jty = assumption_of_judgment env jty in + let jty = e_assumption_of_judgment env evdref jty in { uj_val = cstr; uj_type = jty } | Rel n -> @@ -243,7 +248,7 @@ let rec execute env evdref cstr = and execute_recdef env evdref (names,lar,vdef) = let larj = execute_array env evdref lar in - let lara = Array.map (assumption_of_judgment env) larj in + let lara = Array.map (e_assumption_of_judgment env evdref) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in let vdefv = Array.map j_val vdefj in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c92c183d..63cdb378 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -198,11 +198,18 @@ type unify_flags = { (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *) modulo_delta : Names.transparent_state; - (* This controls which constant are unfoldable; this is on for apply *) + (* This controls which constants are unfoldable; this is on for apply *) (* (but not simple apply) since Feb 2008 for 8.2 *) modulo_delta_types : Names.transparent_state; + modulo_delta_in_merge : Names.transparent_state option; + (* This controls whether unfoldability is different when trying to unify *) + (* several instances of the same metavariable *) + (* Typical situation is when we give a pattern to be matched *) + (* syntactically against a subterm but we want the metas of the *) + (* pattern to be modulo convertibility *) + check_applied_meta_types : bool; (* This controls whether meta's applied to arguments have their *) (* type unified with the type of their instance *) @@ -240,12 +247,13 @@ type unify_flags = { } (* Default flag for unifying a type against a type (e.g. apply) *) -(* We set all conversion flags *) +(* We set all conversion flags (no flag should be modified anymore) *) let default_unify_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = full_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = true; @@ -258,24 +266,22 @@ let default_unify_flags = { (* in fact useless when not used in w_unify_to_subterm_list *) } +let set_merge_flags flags = + match flags.modulo_delta_in_merge with + | None -> flags + | Some ts -> + { flags with modulo_delta = ts; modulo_conv_on_closed_terms = Some ts } + (* Default flag for the "simple apply" version of unification of a *) (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; +let default_no_delta_unify_flags = { default_unify_flags with modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; check_applied_meta_types = false; - resolve_evars = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; - restrict_conv_on_strict_subterms = false; modulo_betaiota = false; - modulo_eta = true; - allow_K_in_toplevel_higher_order_unification = false } (* Default flags for looking for subterms in elimination tactics *) @@ -283,36 +289,16 @@ let default_no_delta_unify_flags = { (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; - check_applied_meta_types = true; - resolve_evars = false; - use_pattern_unification = true; - use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; +let elim_flags = { default_unify_flags with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; - modulo_eta = true; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; +let elim_no_delta_flags = { elim_flags with modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; check_applied_meta_types = false; - resolve_evars = false; use_pattern_unification = false; - use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; - restrict_conv_on_strict_subterms = false; (* ? *) - modulo_betaiota = false; - modulo_eta = true; - allow_K_in_toplevel_higher_order_unification = true } let set_no_head_reduction flags = @@ -865,7 +851,7 @@ let w_merge env with_types flags (evd,metas,evars) = if Evd.is_defined evd evk then let v = Evd.existential_value evd ev in let (evd,metas',evars'') = - unify_0 curenv evd CONV flags rhs v in + unify_0 curenv evd CONV (set_merge_flags flags) rhs v in w_merge_rec evd (metas'@metas) (evars''@evars') eqns else begin (* This can make rhs' ill-typed if metas are *) @@ -943,7 +929,7 @@ let w_merge env with_types flags (evd,metas,evars) = let sp_env = Global.env_of_context ev.evar_hyps in let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = - unify_0 sp_env evd' CUMUL flags + unify_0 sp_env evd' CUMUL (set_merge_flags flags) (get_type_of sp_env evd' c) ev.evar_concl in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' diff --git a/pretyping/unification.mli b/pretyping/unification.mli index e3fd46af..1ec5c1a2 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -15,6 +15,7 @@ type unify_flags = { use_metas_eagerly_in_conv_on_closed_terms : bool; modulo_delta : Names.transparent_state; modulo_delta_types : Names.transparent_state; + modulo_delta_in_merge : Names.transparent_state option; check_applied_meta_types : bool; resolve_evars : bool; use_pattern_unification : bool; diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index ca8fd6ae..d18ee73f 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -105,6 +105,7 @@ let fail_quick_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = false; use_pattern_unification = false; diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 5e314069..45e4a84e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -62,9 +62,12 @@ let get_undo _ = None let start_proof id str hyps c ?init_tac ?compute_guard hook = let goals = [ (Global.env_of_context hyps , c) ] in - let init_tac = Option.map Proofview.V82.tactic init_tac in Proof_global.start_proof id str goals ?compute_guard hook; - try Option.iter Proof_global.run_tactic init_tac + let tac = match init_tac with + | Some tac -> Proofview.V82.tactic tac + | None -> Proofview.tclUNIT () + in + try Proof_global.run_tactic tac with e -> Proof_global.discard_current (); raise e let restart_proof () = undo_todepth 1 diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index c8bf689b..5bc77457 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -63,16 +63,18 @@ let no_start = ref false let is_ocaml4 = Coq_config.caml_version.[0] <> '3' +(* Since the .cma are given with their relative paths (e.g. "lib/clib.cma"), + we only need to include directories mentionned in the temp main ml file + below (for accessing the corresponding .cmi). *) + let src_dirs = - [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] + [ []; ["lib"]; ["toplevel"]; ["kernel";"byterun"]; ] let includes () = - (if !Flags.boot then [] (* the include flags are given on the cmdline *) - else - let coqlib = Envars.coqlib () in - let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in - let camlp4incl = ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""] in - List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs camlp4incl) + let coqlib = if !Flags.boot then "." else Envars.coqlib () in + let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in + (List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs []) + @ ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""] @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else []) (* Transform bytecode object file names in native object file names *) @@ -242,8 +244,7 @@ let declare_loading_string () = (* create a temporary main file to link *) let create_tmp_main_file modules = - let main_name = Filename.temp_file "coqmain" ".ml" in - let oc = open_out main_name in + let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in try (* Add the pre-linked modules *) output_string oc "List.iter Mltop.add_known_module [\""; @@ -290,10 +291,10 @@ let main () = [] in (* the list of the loaded modules *) - let main_file = Filename.quote (create_tmp_main_file modules) in + let main_file = create_tmp_main_file modules in try - let args = - options @ (includes ()) @ copts @ tolink @ dynlink @ [ main_file ] in + let args = options @ includes () @ copts @ tolink @ dynlink in + let args = args @ [ Filename.quote main_file ] in (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *) let args = if !top then args @ [ "topstart.cmo" ] else args in (* Now, with the .cma, we MUST use the -linkall option *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 041bb44b..f7d63dcd 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1020,6 +1020,7 @@ let auto_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = true; use_pattern_unification = false; diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index e8ef545d..cf4a267f 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -77,6 +77,7 @@ let auto_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = var_full_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = false; use_pattern_unification = true; diff --git a/tactics/equality.ml b/tactics/equality.ml index 241a8bd2..a352355b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -87,6 +87,7 @@ let rewrite_unif_flags = { Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = empty_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -155,6 +156,7 @@ let rewrite_conv_closed_unif_flags = { Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; Unification.use_pattern_unification = true; diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index d3403a18..613779c2 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -194,7 +194,7 @@ let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" | Some l,_ -> str "in" ++ - Util.prlist (fun id -> spc () ++ pr_id id) l ++ + spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++ match concl with | true -> spc () ++ str "|-" ++ spc () ++ str "*" | _ -> mt () diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 8a1b5996..47e3b7ca 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -151,8 +151,9 @@ let match_with_disjunction ?(strict=false) t = | Ind ind -> let car = mis_constr_nargs ind in let (mib,mip) = Global.lookup_inductive ind in - if array_for_all (fun ar -> ar = 1) car && - not (mis_is_recursive (ind,mib,mip)) + if array_for_all (fun ar -> ar = 1) car + && not (mis_is_recursive (ind,mib,mip)) + && (mip.mind_nrealargs = 0) then if strict then if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index dbe61817..b90a911a 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -294,6 +294,7 @@ let rewrite_unif_flags = { Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -305,11 +306,12 @@ let rewrite_unif_flags = { Unification.allow_K_in_toplevel_higher_order_unification = true } -let rewrite2_unif_flags = +let rewrite2_unif_flags = { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = conv_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -327,6 +329,7 @@ let general_rewrite_unif_flags () = Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; Unification.modulo_delta_types = ts; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ff53bfe8..12292196 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1690,6 +1690,7 @@ let default_matching_flags sigma = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = Some full_transparent_state; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = false; diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index beba8df9..66307236 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -127,3 +127,12 @@ Identifier 'foo' now a keyword : nat fun _ : nat => 9 : nat -> nat +Identifier 'ONE' now a keyword +fun (x : nat) (p : x = x) => match p with + | ONE => ONE + end = p + : forall x : nat, x = x -> Prop +fun (x : nat) (p : x = x) => match p with + | 1 => 1 + end = p + : forall x : nat, x = x -> Prop diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 52f499ab..612b5325 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -262,3 +262,16 @@ Notation "'foo' n" := (S n) (at level 50): nat_scope. Check (foo 9). Check (fun _ : nat => 9). + +(* Checking parsing and printing of numerical and non-numerical notations for eq_refl *) + +(* This notation was not correctly printed until Pierre B.'s + improvements to the interpretation of patterns *) + +Notation "'ONE'" := eq_refl. +Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. + +(* This one used to failed at parsing until now *) + +Notation "1" := eq_refl. +Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index f445ca8e..c9a3c08e 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1865,3 +1865,9 @@ Type (fun n => match n with | Z0 => true | _ => false end). + +(* Check that types with unknown sort, as A below, are not fatal to + the pattern-matching compilation *) + +Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := + match p with eq_refl => u end. diff --git a/test-suite/success/set.v b/test-suite/success/set.v index 23019275..8116e897 100644 --- a/test-suite/success/set.v +++ b/test-suite/success/set.v @@ -1,8 +1,19 @@ +(* This used to fail in 8.0pl1 *) + Goal forall n, n+n=0->0=n+n. intros. - -(* This used to fail in 8.0pl1 *) set n in * |-. +Abort. + +(* This works from 8.4pl1, since merging of different instances of the + same metavariable in a pattern is done modulo conversion *) + +Notation "p .+1" := (S p) (at level 1, left associativity, format "p .+1"). + +Goal forall (f:forall n, n=0 -> Prop) n (H:(n+n).+1=0), f (n.+1+n) H. +intros. +set (f _ _). +Abort. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 980cfeac..c68216e6 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -35,6 +35,7 @@ Module Raw (Import I:Int)(X: OrderedType). Local Open Scope pair_scope. Local Open Scope lazy_bool_scope. Local Open Scope Int_scope. +Local Notation int := I.t. Definition key := X.t. Hint Transparent key. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index 1e66e2b5..db12ee31 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -44,6 +44,7 @@ Local Unset Case Analysis Schemes. Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X. Local Open Scope Int_scope. +Local Notation int := I.t. (** ** Generic trees instantiated with integer height *) diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 37074aba..5582438b 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -147,18 +147,14 @@ Definition lt_total := lt_trichotomy. Definition le_lteq := lt_eq_cases. Module Private_OrderTac. -Module Elts <: TotalOrder. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le := le. +Module IsTotal. Definition eq_equiv := eq_equiv. Definition lt_strorder := lt_strorder. Definition lt_compat := lt_compat. Definition lt_total := lt_total. Definition le_lteq := le_lteq. -End Elts. -Module Tac := !MakeOrderTac Elts. +End IsTotal. +Module Tac := !MakeOrderTac NZ IsTotal. End Private_OrderTac. Ltac order := Private_OrderTac.Tac.order. diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index 3b2a372e..a2bc5e26 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -42,6 +42,7 @@ Module BigQ <: QType <: OrderedTypeFull <: TotalOrder. Bind Scope bigQ_scope with t t_. Include !QProperties <+ HasEqBool2Dec <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. + Ltac order := Private_Tac.order. End BigQ. (** Notations about [BigQ] *) @@ -144,8 +145,7 @@ End TestField. (** [BigQ] can also benefit from an "order" tactic *) -Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ. -Ltac bigQ_order := BigQ_Order.order. +Ltac bigQ_order := BigQ.order. Section TestOrder. Let test : forall x y : bigQ, x<=y -> y<=x -> x==y. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 4747cfe1..be585871 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1486,6 +1486,8 @@ Qed. Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. +Ltac order := Private_Tac.order. + (** Minimum, maximum and constant one *) Lemma max_1_l n : max 1 n = n. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 5583142f..ffd0649a 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -40,34 +40,34 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. Definition max := gmax O.compare. Definition min := gmin O.compare. - Lemma ge_not_lt : forall x y, y<=x -> x False. + Lemma ge_not_lt x y : y<=x -> x False. Proof. - intros x y H H'. + intros H H'. apply (StrictOrder_Irreflexive x). rewrite le_lteq in *; destruct H as [H|H]. transitivity y; auto. rewrite H in H'; auto. Qed. - Lemma max_l : forall x y, y<=x -> max x y == x. + Lemma max_l x y : y<=x -> max x y == x. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. Qed. - Lemma max_r : forall x y, x<=y -> max x y == y. + Lemma max_r x y : x<=y -> max x y == y. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. - Lemma min_l : forall x y, x<=y -> min x y == x. + Lemma min_l x y : x<=y -> min x y == x. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. - Lemma min_r : forall x y, y<=x -> min x y == y. + Lemma min_r x y : y<=x -> min x y == y. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. @@ -76,31 +76,30 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. End GenericMinMax. -(** ** Consequences of the minimalist interface: facts about [max]. *) +(** ** Consequences of the minimalist interface: facts about [max] and [min]. *) -Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O). - Module Import Private_Tac := !MakeOrderTac O. +Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). + Module Import Private_Tac := !MakeOrderTac O O. (** An alternative caracterisation of [max], equivalent to [max_l /\ max_r] *) -Lemma max_spec : forall n m, - (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). +Lemma max_spec n m : + (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. - intros n m. destruct (lt_total n m); [left|right]. - split; auto. apply max_r. rewrite le_lteq; auto. - assert (m <= n) by (rewrite le_lteq; intuition). - split; auto. apply max_l; auto. + - split; auto. apply max_r. rewrite le_lteq; auto. + - assert (m <= n) by (rewrite le_lteq; intuition). + split; auto. now apply max_l. Qed. (** A more symmetric version of [max_spec], based only on [le]. Beware that left and right alternatives overlap. *) -Lemma max_spec_le : forall n m, +Lemma max_spec_le n m : (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. - intros. destruct (max_spec n m); [left|right]; intuition; order. + destruct (max_spec n m); [left|right]; intuition; order. Qed. Instance : Proper (eq==>eq==>iff) le. @@ -108,25 +107,24 @@ Proof. repeat red. intuition order. Qed. Instance max_compat : Proper (eq==>eq==>eq) max. Proof. -intros x x' Hx y y' Hy. -assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). -set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. -rewrite <- Hx, <- Hy in *. -destruct (lt_total x y); intuition order. + intros x x' Hx y y' Hy. + assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). + set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. + rewrite <- Hx, <- Hy in *. + destruct (lt_total x y); intuition order. Qed. - (** A function satisfying the same specification is equal to [max]. *) -Lemma max_unicity : forall n m p, - ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. +Lemma max_unicity n m p : + ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. Proof. - intros. assert (Hm := max_spec n m). + assert (Hm := max_spec n m). destruct (lt_total n m); intuition; order. Qed. -Lemma max_unicity_ext : forall f, - (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> +Lemma max_unicity_ext f : + (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> (forall n m, f n m == max n m). Proof. intros. apply max_unicity; auto. @@ -134,12 +132,12 @@ Qed. (** [max] commutes with monotone functions. *) -Lemma max_mono: forall f, +Lemma max_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, max (f x) (f y) == f (max x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f x <= f y) by (apply Lef; order). order. @@ -148,239 +146,232 @@ Qed. (** *** Semi-lattice algebraic properties of [max] *) -Lemma max_id : forall n, max n n == n. +Lemma max_id n : max n n == n. Proof. - intros. destruct (max_spec n n); intuition. + apply max_l; order. Qed. Notation max_idempotent := max_id (only parsing). -Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p. +Lemma max_assoc m n p : max m (max n p) == max (max m n) p. Proof. - intros. - destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. - destruct (max_spec m p); intuition; order. order. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order. - destruct (max_spec m p); intuition; order. + destruct (max_spec n p) as [(H,E)|(H,E)]; rewrite E; + destruct (max_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. + - apply max_r; order. + - symmetry. apply max_l; order. Qed. -Lemma max_comm : forall n m, max n m == max m n. +Lemma max_comm n m : max n m == max m n. Proof. - intros. - destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. + destruct (max_spec m n) as [(H,E)|(H,E)]; rewrite E; + (apply max_r || apply max_l); order. Qed. +Ltac solve_max := + match goal with |- context [max ?n ?m] => + destruct (max_spec n m); intuition; order + end. + (** *** Least-upper bound properties of [max] *) -Lemma le_max_l : forall n m, n <= max n m. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma le_max_l n m : n <= max n m. +Proof. solve_max. Qed. -Lemma le_max_r : forall n m, m <= max n m. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma le_max_r n m : m <= max n m. +Proof. solve_max. Qed. -Lemma max_l_iff : forall n m, max n m == n <-> m <= n. -Proof. - split. intro H; rewrite <- H. apply le_max_r. apply max_l. -Qed. +Lemma max_l_iff n m : max n m == n <-> m <= n. +Proof. solve_max. Qed. -Lemma max_r_iff : forall n m, max n m == m <-> n <= m. -Proof. - split. intro H; rewrite <- H. apply le_max_l. apply max_r. -Qed. +Lemma max_r_iff n m : max n m == m <-> n <= m. +Proof. solve_max. Qed. -Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m. +Lemma max_le n m p : p <= max n m -> p <= n \/ p <= m. Proof. - intros n m p H; destruct (max_spec n m); - [right|left]; intuition; order. + destruct (max_spec n m); [right|left]; intuition; order. Qed. -Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m. -Proof. - intros. split. apply max_le. - destruct (max_spec n m); intuition; order. -Qed. +Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. +Proof. split. apply max_le. solve_max. Qed. -Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m. +Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. Proof. - intros. destruct (max_spec n m); intuition; + destruct (max_spec n m); intuition; order || (right; order) || (left; order). Qed. -Lemma max_lub_l : forall n m p, max n m <= p -> n <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_l n m p : max n m <= p -> n <= p. +Proof. solve_max. Qed. -Lemma max_lub_r : forall n m p, max n m <= p -> m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_r n m p : max n m <= p -> m <= p. +Proof. solve_max. Qed. -Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub n m p : n <= p -> m <= p -> max n m <= p. +Proof. solve_max. Qed. -Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_iff n m p : max n m <= p <-> n <= p /\ m <= p. +Proof. solve_max. Qed. -Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_lt n m p : n < p -> m < p -> max n m < p. +Proof. solve_max. Qed. -Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_lt_iff n m p : max n m < p <-> n < p /\ m < p. +Proof. solve_max. Qed. -Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m. -Proof. - intros. - destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E. - assert (LE' := le_max_r p m). order. - apply le_max_l. -Qed. +Lemma max_le_compat_l n m p : n <= m -> max p n <= max p m. +Proof. intros. apply max_lub_iff. solve_max. Qed. -Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p. -Proof. - intros. rewrite (max_comm n p), (max_comm m p). - auto using max_le_compat_l. -Qed. +Lemma max_le_compat_r n m p : n <= m -> max n p <= max m p. +Proof. intros. apply max_lub_iff. solve_max. Qed. -Lemma max_le_compat : forall n m p q, n <= m -> p <= q -> - max n p <= max m q. +Lemma max_le_compat n m p q : n <= m -> p <= q -> max n p <= max m q. Proof. - intros n m p q Hnm Hpq. + intros Hnm Hpq. assert (LE := max_le_compat_l _ _ m Hpq). assert (LE' := max_le_compat_r _ _ p Hnm). order. Qed. -End MaxLogicalProperties. - - -(** ** Properties concernant [min], then both [min] and [max]. +(** Properties of [min] *) - To avoid too much code duplication, we exploit that [min] can be - seen as a [max] of the reversed order. -*) +Lemma min_spec n m : + (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. + destruct (lt_total n m); [left|right]. + - split; auto. apply min_l. rewrite le_lteq; auto. + - assert (m <= n) by (rewrite le_lteq; intuition). + split; auto. now apply min_r. +Qed. -Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). - Include MaxLogicalProperties O M. - Import Private_Tac. - - Module Import Private_Rev. - Module ORev := TotalOrderRev O. - Module MRev <: HasMax ORev. - Definition max x y := M.min y x. - Definition max_l x y := M.min_r y x. - Definition max_r x y := M.min_l y x. - End MRev. - Module MPRev := MaxLogicalProperties ORev MRev. - End Private_Rev. +Lemma min_spec_le n m : + (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. + destruct (min_spec n m); [left|right]; intuition; order. +Qed. Instance min_compat : Proper (eq==>eq==>eq) min. -Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed. +Proof. +intros x x' Hx y y' Hy. +assert (H1 := min_spec x y). assert (H2 := min_spec x' y'). +set (m := min x y) in *; set (m' := min x' y') in *; clearbody m m'. +rewrite <- Hx, <- Hy in *. +destruct (lt_total x y); intuition order. +Qed. -Lemma min_spec : forall n m, - (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. intros. exact (MPRev.max_spec m n). Qed. +Lemma min_unicity n m p : + ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. +Proof. + assert (Hm := min_spec n m). + destruct (lt_total n m); intuition; order. +Qed. -Lemma min_spec_le : forall n m, - (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. intros. exact (MPRev.max_spec_le m n). Qed. +Lemma min_unicity_ext f : + (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> + (forall n m, f n m == min n m). +Proof. + intros. apply min_unicity; auto. +Qed. -Lemma min_mono: forall f, +Lemma min_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, min (f x) (f y) == f (min x y). Proof. - intros. apply MPRev.max_mono; auto. compute in *; eauto. + intros Eqf Lef x y. + destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; + destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. + assert (f x <= f y) by (apply Lef; order). order. + assert (f y <= f x) by (apply Lef; order). order. Qed. -Lemma min_unicity : forall n m p, - ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. -Proof. intros n m p. apply MPRev.max_unicity. Qed. - -Lemma min_unicity_ext : forall f, - (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> - (forall n m, f n m == min n m). -Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed. - -Lemma min_id : forall n, min n n == n. -Proof. intros. exact (MPRev.max_id n). Qed. +Lemma min_id n : min n n == n. +Proof. + apply min_l; order. +Qed. Notation min_idempotent := min_id (only parsing). -Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p. -Proof. intros. symmetry; apply MPRev.max_assoc. Qed. +Lemma min_assoc m n p : min m (min n p) == min (min m n) p. +Proof. + destruct (min_spec n p) as [(H,E)|(H,E)]; rewrite E; + destruct (min_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. + - symmetry. apply min_l; order. + - apply min_r; order. +Qed. -Lemma min_comm : forall n m, min n m == min m n. -Proof. intros. exact (MPRev.max_comm m n). Qed. +Lemma min_comm n m : min n m == min m n. +Proof. + destruct (min_spec m n) as [(H,E)|(H,E)]; rewrite E; + (apply min_r || apply min_l); order. +Qed. -Lemma le_min_r : forall n m, min n m <= m. -Proof. intros. exact (MPRev.le_max_l m n). Qed. +Ltac solve_min := + match goal with |- context [min ?n ?m] => + destruct (min_spec n m); intuition; order + end. -Lemma le_min_l : forall n m, min n m <= n. -Proof. intros. exact (MPRev.le_max_r m n). Qed. +Lemma le_min_r n m : min n m <= m. +Proof. solve_min. Qed. -Lemma min_l_iff : forall n m, min n m == n <-> n <= m. -Proof. intros n m. exact (MPRev.max_r_iff m n). Qed. +Lemma le_min_l n m : min n m <= n. +Proof. solve_min. Qed. -Lemma min_r_iff : forall n m, min n m == m <-> m <= n. -Proof. intros n m. exact (MPRev.max_l_iff m n). Qed. +Lemma min_l_iff n m : min n m == n <-> n <= m. +Proof. solve_min. Qed. -Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p. -Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed. +Lemma min_r_iff n m : min n m == m <-> m <= n. +Proof. solve_min. Qed. -Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p. -Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed. +Lemma min_le n m p : min n m <= p -> n <= p \/ m <= p. +Proof. + destruct (min_spec n m); [left|right]; intuition; order. +Qed. + +Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. +Proof. split. apply min_le. solve_min. Qed. -Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p. -Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed. +Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. +Proof. + destruct (min_spec n m); intuition; + order || (right; order) || (left; order). +Qed. -Lemma min_glb_l : forall n m p, p <= min n m -> p <= n. -Proof. intros n m. exact (MPRev.max_lub_r m n). Qed. +Lemma min_glb_l n m p : p <= min n m -> p <= n. +Proof. solve_min. Qed. -Lemma min_glb_r : forall n m p, p <= min n m -> p <= m. -Proof. intros n m. exact (MPRev.max_lub_l m n). Qed. +Lemma min_glb_r n m p : p <= min n m -> p <= m. +Proof. solve_min. Qed. -Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m. -Proof. intros. apply MPRev.max_lub; auto. Qed. +Lemma min_glb n m p : p <= n -> p <= m -> p <= min n m. +Proof. solve_min. Qed. -Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m. -Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed. +Lemma min_glb_iff n m p : p <= min n m <-> p <= n /\ p <= m. +Proof. solve_min. Qed. -Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m. -Proof. intros. apply MPRev.max_lub_lt; auto. Qed. +Lemma min_glb_lt n m p : p < n -> p < m -> p < min n m. +Proof. solve_min. Qed. -Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m. -Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed. +Lemma min_glb_lt_iff n m p : p < min n m <-> p < n /\ p < m. +Proof. solve_min. Qed. -Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m. -Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed. +Lemma min_le_compat_l n m p : n <= m -> min p n <= min p m. +Proof. intros. apply min_glb_iff. solve_min. Qed. -Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p. -Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed. +Lemma min_le_compat_r n m p : n <= m -> min n p <= min m p. +Proof. intros. apply min_glb_iff. solve_min. Qed. -Lemma min_le_compat : forall n m p q, n <= m -> p <= q -> +Lemma min_le_compat n m p q : n <= m -> p <= q -> min n p <= min m q. -Proof. intros. apply MPRev.max_le_compat; auto. Qed. - +Proof. + intros Hnm Hpq. + assert (LE := min_le_compat_l _ _ m Hpq). + assert (LE' := min_le_compat_r _ _ p Hnm). + order. +Qed. (** *** Combined properties of min and max *) -Lemma min_max_absorption : forall n m, max n (min n m) == n. +Lemma min_max_absorption n m : max n (min n m) == n. Proof. intros. destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. @@ -388,7 +379,7 @@ Proof. destruct (max_spec n m); intuition; order. Qed. -Lemma max_min_absorption : forall n m, min n (max n m) == n. +Lemma max_min_absorption n m : min n (max n m) == n. Proof. intros. destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. @@ -398,35 +389,35 @@ Qed. (** Distributivity *) -Lemma max_min_distr : forall n m p, +Lemma max_min_distr n m p : max n (min m p) == min (max n m) (max n p). Proof. - intros. symmetry. apply min_mono. + symmetry. apply min_mono. eauto with *. repeat red; intros. apply max_le_compat_l; auto. Qed. -Lemma min_max_distr : forall n m p, +Lemma min_max_distr n m p : min n (max m p) == max (min n m) (min n p). Proof. - intros. symmetry. apply max_mono. + symmetry. apply max_mono. eauto with *. repeat red; intros. apply min_le_compat_l; auto. Qed. (** Modularity *) -Lemma max_min_modular : forall n m p, +Lemma max_min_modular n m p : max n (min m (max n p)) == min (max n m) (max n p). Proof. - intros. rewrite <- max_min_distr. + rewrite <- max_min_distr. destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. rewrite 2 max_l; try order. rewrite min_le_iff; auto. rewrite 2 max_l; try order. rewrite min_le_iff; auto. Qed. -Lemma min_max_modular : forall n m p, +Lemma min_max_modular n m p : min n (max m (min n p)) == max (min n m) (min n p). Proof. intros. rewrite <- min_max_distr. @@ -438,7 +429,7 @@ Qed. (** Disassociativity *) -Lemma max_min_disassoc : forall n m p, +Lemma max_min_disassoc n m p : min n (max m p) <= max (min n m) p. Proof. intros. rewrite min_max_distr. @@ -447,24 +438,24 @@ Qed. (** Anti-monotonicity swaps the role of [min] and [max] *) -Lemma max_min_antimono : forall f, +Lemma max_min_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. assert (f x <= f y) by (apply Lef; order). order. Qed. -Lemma min_max_antimono : forall f, +Lemma min_max_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. @@ -480,11 +471,11 @@ Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). (** Induction principles for [max]. *) -Lemma max_case_strong : forall n m (P:t -> Type), +Lemma max_case_strong n m (P:t -> Type) : (forall x y, x==y -> P x -> P y) -> (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). Proof. -intros n m P Compat Hl Hr. +intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply max_r; auto. @@ -494,26 +485,26 @@ assert (m<=n) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply max_l; auto. Defined. -Lemma max_case : forall n m (P:t -> Type), +Lemma max_case n m (P:t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (max n m). Proof. intros. apply max_case_strong; auto. Defined. (** [max] returns one of its arguments. *) -Lemma max_dec : forall n m, {max n m == n} + {max n m == m}. +Lemma max_dec n m : {max n m == n} + {max n m == m}. Proof. - intros n m. apply max_case; auto with relations. + apply max_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <-H; auto. Defined. (** Idem for [min] *) -Lemma min_case_strong : forall n m (P:O.t -> Type), +Lemma min_case_strong n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). Proof. -intros n m P Compat Hl Hr. +intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply min_l; auto. @@ -523,12 +514,12 @@ assert (m<=n) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply min_r; auto. Defined. -Lemma min_case : forall n m (P:O.t -> Type), +Lemma min_case n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (min n m). Proof. intros. apply min_case_strong; auto. Defined. -Lemma min_dec : forall n m, {min n m == n} + {min n m == m}. +Lemma min_dec n m : {min n m == n} + {min n m == m}. Proof. intros. apply min_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations. @@ -558,19 +549,19 @@ Module UsualMinMaxLogicalProperties Include MinMaxLogicalProperties O M. - Lemma max_monotone : forall f, Proper (le ==> le) f -> + Lemma max_monotone f : Proper (le ==> le) f -> forall x y, max (f x) (f y) = f (max x y). Proof. intros; apply max_mono; auto. congruence. Qed. - Lemma min_monotone : forall f, Proper (le ==> le) f -> + Lemma min_monotone f : Proper (le ==> le) f -> forall x y, min (f x) (f y) = f (min x y). Proof. intros; apply min_mono; auto. congruence. Qed. - Lemma min_max_antimonotone : forall f, Proper (le ==> inverse le) f -> + Lemma min_max_antimonotone f : Proper (le ==> inverse le) f -> forall x y, min (f x) (f y) = f (max x y). Proof. intros; apply min_max_antimono; auto. congruence. Qed. - Lemma max_min_antimonotone : forall f, Proper (le ==> inverse le) f -> + Lemma max_min_antimonotone f : Proper (le ==> inverse le) f -> forall x y, max (f x) (f y) = f (min x y). Proof. intros; apply max_min_antimono; auto. congruence. Qed. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index f84cdf32..75578195 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -108,19 +108,21 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. Proof. intros; destruct (compare x y); auto. Qed. - Module OrderElts <: Orders.TotalOrder. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le x y := lt x y \/ eq x y. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. - Proof. unfold le; intuition. Qed. - End OrderElts. - Module OrderTac := !MakeOrderTac OrderElts. + Module TO. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + Definition le x y := lt x y \/ eq x y. + End TO. + Module IsTO. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. + Proof. reflexivity. Qed. + End IsTO. + Module OrderTac := !MakeOrderTac TO IsTO. Ltac order := OrderTac.order. Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 66a672c9..68ffc379 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -40,16 +40,26 @@ Definition trans_ord o o' := Local Infix "+" := trans_ord. -(** ** The requirements of the tactic : [TotalOrder]. +(** ** The tactic requirements : a total order - [TotalOrder] contains an equivalence [eq], - a strict order [lt] total and compatible with [eq], and - a larger order [le] synonym for [lt\/eq]. + We need : + - an equivalence [eq], + - a strict order [lt] total and compatible with [eq], + - a larger order [le] synonym for [lt\/eq]. + + This used to be provided here via a [TotalOrder], but + for technical reasons related to extraction, we now ask + for two sperate parts: relations in a [EqLtLe] + properties in + [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder] *) +Module Type IsTotalOrder (O:EqLtLe) := + IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O. + (** ** Properties that will be used by the [order] tactic *) -Module OrderFacts(Import O:TotalOrder'). +Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O). +Include EqLtLeNotation O. (** Reflexivity rules *) @@ -57,7 +67,7 @@ Lemma eq_refl : forall x, x==x. Proof. reflexivity. Qed. Lemma le_refl : forall x, x<=x. -Proof. intros; rewrite le_lteq; right; reflexivity. Qed. +Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x y<=x -> x==y. Proof. - intros x y; rewrite 2 le_lteq. intuition. + intros x y; rewrite 2 P.le_lteq. intuition. elim (StrictOrder_Irreflexive x); transitivity y; auto. Qed. @@ -90,7 +100,7 @@ Local Notation "#" := interp_ord. Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; rewrite ?le_lteq; intuition; +destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. @@ -114,19 +124,19 @@ Proof. eauto using eq_trans, eq_sym. Qed. Lemma not_neq_eq : forall x y, ~~x==y -> x==y. Proof. -intros x y H. destruct (lt_total x y) as [H'|[H'|H']]; auto; +intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. Qed. Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. Proof. -intros x y H. rewrite le_lteq. generalize (lt_total x y); intuition. +intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. Qed. Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x
    \n\n
    \n
    Index" !index_name; - if !header_trailer then - if !footer_file_spec then + if !header_trailer && !footer_file_spec then let cin = Pervasives.open_in !footer_file in try while true do @@ -545,12 +538,14 @@ module Html = struct printf "%s\n" s done with End_of_file -> Pervasives.close_in cin - else - begin - printf "
    This page has been generated by "; - printf "coqdoc\n" Coq_config.wwwcoq; - printf "
    \n\n
    \n\n\n" - end + else + begin + if !index && (get_module false) <> "Index" then + printf "
    \n\n
    \n
    Index" !index_name; + printf "
    This page has been generated by "; + printf "coqdoc\n" Coq_config.wwwcoq; + printf "
    \n\n\n\n\n" + end let start_module () = let ln = !lib_name in @@ -620,15 +615,6 @@ module Html = struct | Some n -> n | None -> addr) - let module_ref m s = - match find_module m with - | Local -> - printf "%s" m s - | External m when !externals -> - printf "%s" m s - | External _ | Unknown -> - output_string s - let ident_ref m fid typ s = match find_module m with | Local -> @@ -645,12 +631,8 @@ module Html = struct | Def (fullid,ty) -> printf "" fullid; printf "%s" (type_name ty) s - | Mod (m,s') when s = s' -> - module_ref m s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s - | Mod _ -> - printf "%s" s let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in @@ -667,6 +649,7 @@ module Html = struct Tokens.output_tagged_symbol_char tag c let initialize () = + initialize_tex_html(); Tokens.token_tree := token_tree_html; Tokens.outfun := output_sublexer_string diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 1e889639..22a36ede 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -21,7 +21,7 @@ let eval_call (call:'a Ide_intf.call) = Xml_utils.print_xml (snd !coqtop) xml_query; flush (snd !coqtop); let xml_answer = Xml_parser.parse p (Xml_parser.SChannel (fst !coqtop)) in - let res = Ide_intf.to_answer xml_answer in + let res = Ide_intf.to_answer xml_answer call in prerr_endline (Ide_intf.pr_full_value call res); match res with Interface.Fail _ -> exit 1 | _ -> () diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml index 0df24c7a..28f97dc8 100644 --- a/toplevel/ide_intf.ml +++ b/toplevel/ide_intf.ml @@ -45,7 +45,7 @@ type handler = { evars : unit -> evar list option; hints : unit -> (hint list * hint) option; status : unit -> status; - search : search_flags -> search_answer list; + search : search_flags -> string coq_object list; get_options : unit -> (option_name * option_state) list; set_options : (option_name * option_value) list -> unit; inloadpath : string -> bool; @@ -63,7 +63,7 @@ let goals : goals option call = Goal let evars : evar list option call = Evars let hints : (hint list * hint) option call = Hints let status : status call = Status -let search flags : search_answer list call = Search flags +let search flags : string coq_object list call = Search flags let get_options : (option_name * option_state) list call = GetOptions let set_options l : unit call = SetOptions l let inloadpath s : bool call = InLoadPath s @@ -81,7 +81,7 @@ let abstract_eval_call handler c = | Evars -> Obj.magic (handler.evars () : evar list option) | Hints -> Obj.magic (handler.hints () : (hint list * hint) option) | Status -> Obj.magic (handler.status () : status) - | Search flags -> Obj.magic (handler.search flags : search_answer list) + | Search flags -> Obj.magic (handler.search flags : string coq_object list) | GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list) | SetOptions opts -> Obj.magic (handler.set_options opts : unit) | InLoadPath s -> Obj.magic (handler.inloadpath s : bool) @@ -130,6 +130,12 @@ let bool_arg tag b = if b then [tag, ""] else [] (** Base types *) +let of_unit () = Element ("unit", [], []) + +let to_unit = function + | Element ("unit", [], []) -> () + | _ -> raise Marshal_error + let of_bool b = if b then constructor "bool" "true" [] else constructor "bool" "false" [] @@ -166,7 +172,8 @@ let to_string = function let of_int i = Element ("int", [], [PCData (string_of_int i)]) let to_int = function -| Element ("int", [], [PCData s]) -> int_of_string s +| Element ("int", [], [PCData s]) -> + (try int_of_string s with Failure _ -> raise Marshal_error) | _ -> raise Marshal_error let of_pair f g (x, y) = Element ("pair", [], [f x; g y]) @@ -232,20 +239,20 @@ let to_search_constraint xml = do_match xml "search_constraint" | "include_blacklist" -> Include_Blacklist | _ -> raise Marshal_error) -let of_search_answer ans = - let path = of_list of_string ans.search_answer_full_path in - let name = of_string ans.search_answer_base_name in - let tpe = of_string ans.search_answer_type in - Element ("search_answer", [], [path; name; tpe]) - -let to_search_answer = function -| Element ("search_answer", [], [path; name; tpe]) -> - let path = to_list to_string path in - let name = to_string name in - let tpe = to_string tpe in { - search_answer_full_path = path; - search_answer_base_name = name; - search_answer_type = tpe; +let of_coq_object f ans = + let prefix = of_list of_string ans.coq_object_prefix in + let qualid = of_list of_string ans.coq_object_qualid in + let obj = f ans.coq_object_object in + Element ("coq_object", [], [prefix; qualid; obj]) + +let to_coq_object f = function +| Element ("coq_object", [], [prefix; qualid; obj]) -> + let prefix = to_list to_string prefix in + let qualid = to_list to_string qualid in + let obj = f obj in { + coq_object_prefix = prefix; + coq_object_qualid = qualid; + coq_object_object = obj; } | _ -> raise Marshal_error @@ -412,51 +419,74 @@ let to_coq_info = function } | _ -> raise Marshal_error -let of_hints = - let of_hint = of_list (of_pair of_string of_string) in - of_option (of_pair (of_list of_hint) of_hint) - -let of_answer (q : 'a call) (r : 'a value) = - let convert = match q with - | Interp _ -> Obj.magic (of_string : string -> xml) - | Rewind _ -> Obj.magic (of_int : int -> xml) - | Goal -> Obj.magic (of_option of_goals : goals option -> xml) - | Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml) - | Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml) - | Status -> Obj.magic (of_status : status -> xml) - | Search _ -> Obj.magic (of_list of_search_answer : search_answer list -> xml) - | GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml) - | SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], [])) - | InLoadPath _ -> Obj.magic (of_bool : bool -> xml) - | MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml) - | Quit -> Obj.magic (fun _ -> Element ("unit", [], [])) - | About -> Obj.magic (of_coq_info : coq_info -> xml) +(** Conversions between ['a value] and xml answers + + When decoding an xml answer, we dynamically check that it is compatible + with the original call. For that we now rely on the fact that all + sub-fonctions [to_xxx : xml -> xxx] check that the current xml element + is "xxx", and raise [Marshal_error] if anything goes wrong. +*) + +type value_type = + | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info + | Option of value_type + | List of value_type + | Coq_object of value_type + | Pair of value_type * value_type + +let hint = List (Pair (String, String)) +let option_name = List String + +let expected_answer_type = function + | Interp _ -> String + | Rewind _ -> Int + | Goal -> Option Goals + | Evars -> Option (List Evar) + | Hints -> Option (Pair (List hint, hint)) + | Status -> State + | Search _ -> List (Coq_object String) + | GetOptions -> List (Pair (option_name, Option_state)) + | SetOptions _ -> Unit + | InLoadPath _ -> Bool + | MkCases _ -> List (List String) + | Quit -> Unit + | About -> Coq_info + +let of_answer (q : 'a call) (r : 'a value) : xml = + let rec convert ty : 'a -> xml = match ty with + | Unit -> Obj.magic of_unit + | Bool -> Obj.magic of_bool + | String -> Obj.magic of_string + | Int -> Obj.magic of_int + | State -> Obj.magic of_status + | Option_state -> Obj.magic of_option_state + | Coq_info -> Obj.magic of_coq_info + | Goals -> Obj.magic of_goals + | Evar -> Obj.magic of_evar + | List t -> Obj.magic (of_list (convert t)) + | Option t -> Obj.magic (of_option (convert t)) + | Coq_object t -> Obj.magic (of_coq_object (convert t)) + | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2)) in - of_value convert r - -let to_answer xml = - let rec convert elt = match elt with - | Element (tpe, attrs, l) -> - begin match tpe with - | "unit" -> Obj.magic () - | "string" -> Obj.magic (to_string elt : string) - | "int" -> Obj.magic (to_int elt : int) - | "status" -> Obj.magic (to_status elt : status) - | "bool" -> Obj.magic (to_bool elt : bool) - | "list" -> Obj.magic (to_list convert elt : 'a list) - | "option" -> Obj.magic (to_option convert elt : 'a option) - | "pair" -> Obj.magic (to_pair convert convert elt : ('a * 'b)) - | "goals" -> Obj.magic (to_goals elt : goals) - | "evar" -> Obj.magic (to_evar elt : evar) - | "option_value" -> Obj.magic (to_option_value elt : option_value) - | "option_state" -> Obj.magic (to_option_state elt : option_state) - | "coq_info" -> Obj.magic (to_coq_info elt : coq_info) - | "search_answer" -> Obj.magic (to_search_answer elt : search_answer) - | _ -> raise Marshal_error - end - | _ -> raise Marshal_error + of_value (convert (expected_answer_type q)) r + +let to_answer xml (c : 'a call) : 'a value = + let rec convert ty : xml -> 'a = match ty with + | Unit -> Obj.magic to_unit + | Bool -> Obj.magic to_bool + | String -> Obj.magic to_string + | Int -> Obj.magic to_int + | State -> Obj.magic to_status + | Option_state -> Obj.magic to_option_state + | Coq_info -> Obj.magic to_coq_info + | Goals -> Obj.magic to_goals + | Evar -> Obj.magic to_evar + | List t -> Obj.magic (to_list (convert t)) + | Option t -> Obj.magic (to_option (convert t)) + | Coq_object t -> Obj.magic (to_coq_object (convert t)) + | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2)) in - to_value convert xml + to_value (convert (expected_answer_type c)) xml (** * Debug printing *) diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli index 26c6b671..7d0685b1 100644 --- a/toplevel/ide_intf.mli +++ b/toplevel/ide_intf.mli @@ -77,7 +77,7 @@ type handler = { evars : unit -> evar list option; hints : unit -> (hint list * hint) option; status : unit -> status; - search : search_flags -> search_answer list; + search : search_flags -> string coq_object list; get_options : unit -> (option_name * option_state) list; set_options : (option_name * option_value) list -> unit; inloadpath : string -> bool; @@ -104,7 +104,7 @@ val of_call : 'a call -> xml val to_call : xml -> 'a call val of_answer : 'a call -> 'a value -> xml -val to_answer : xml -> 'a value +val to_answer : xml -> 'a call -> 'a value (** * Debug printing *) diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index 681eec0d..d67b272e 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -127,25 +127,25 @@ let hyp_next_tac sigma env (id,_,ast) = let id_s = Names.string_of_id id in let type_s = string_of_ppcmds (pr_ltype_env env ast) in [ - ("clear "^id_s),("clear "^id_s^".\n"); - ("apply "^id_s),("apply "^id_s^".\n"); - ("exact "^id_s),("exact "^id_s^".\n"); - ("generalize "^id_s),("generalize "^id_s^".\n"); - ("absurd <"^id_s^">"),("absurd "^type_s^".\n") + ("clear "^id_s),("clear "^id_s^"."); + ("apply "^id_s),("apply "^id_s^"."); + ("exact "^id_s),("exact "^id_s^"."); + ("generalize "^id_s),("generalize "^id_s^"."); + ("absurd <"^id_s^">"),("absurd "^type_s^".") ] @ [ - ("discriminate "^id_s),("discriminate "^id_s^".\n"); - ("injection "^id_s),("injection "^id_s^".\n") + ("discriminate "^id_s),("discriminate "^id_s^"."); + ("injection "^id_s),("injection "^id_s^".") ] @ [ - ("rewrite "^id_s),("rewrite "^id_s^".\n"); - ("rewrite <- "^id_s),("rewrite <- "^id_s^".\n") + ("rewrite "^id_s),("rewrite "^id_s^"."); + ("rewrite <- "^id_s),("rewrite <- "^id_s^".") ] @ [ - ("elim "^id_s), ("elim "^id_s^".\n"); - ("inversion "^id_s), ("inversion "^id_s^".\n"); - ("inversion clear "^id_s), ("inversion_clear "^id_s^".\n") + ("elim "^id_s), ("elim "^id_s^"."); + ("inversion "^id_s), ("inversion "^id_s^"."); + ("inversion clear "^id_s), ("inversion_clear "^id_s^".") ] let concl_next_tac sigma concl = - let expand s = (s,s^".\n") in + let expand s = (s,s^".") in List.map expand ([ "intro"; "intros"; @@ -312,16 +312,26 @@ let search flags = in let ans = ref [] in let print_function ref env constr = - let name = Names.string_of_id (Nametab.basename_of_global ref) in - let make_path = Names.string_of_id in - let path = - List.rev_map make_path (Names.repr_dirpath (Nametab.dirpath_of_global ref)) - in - let answer = { - Interface.search_answer_full_path = path; - Interface.search_answer_base_name = name; - Interface.search_answer_type = string_of_ppcmds (pr_lconstr_env env constr); - } in + let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in + let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in + let (shortpath, basename) = Libnames.repr_qualid qualid in + let shortpath = repr_dirpath shortpath in + (* [shortpath] is a suffix of [fullpath] and we're looking for the missing + prefix *) + let rec prefix full short accu = match full, short with + | _, [] -> + let full = List.rev_map string_of_id full in + (full, accu) + | _ :: full, m :: short -> + prefix full short (string_of_id m :: accu) + | _ -> assert false + in + let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in + let answer = { + Interface.coq_object_prefix = prefix; + Interface.coq_object_qualid = qualid; + Interface.coq_object_object = string_of_ppcmds (pr_lconstr_env env constr); + } in ans := answer :: !ans; in let () = Search.gen_filtered_search filter_function print_function in @@ -432,6 +442,9 @@ let loop () = let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in Ide_intf.of_answer q r with + | Xml_parser.Error (Xml_parser.Empty, _) -> + pr_debug ("End of input, exiting"); + exit 0 | Xml_parser.Error (err, loc) -> let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in fail msg diff --git a/toplevel/interface.mli b/toplevel/interface.mli index 39fb2a0e..7b4312a3 100644 --- a/toplevel/interface.mli +++ b/toplevel/interface.mli @@ -86,10 +86,14 @@ type search_constraint = the flag should be negated. *) type search_flags = (search_constraint * bool) list -type search_answer = { - search_answer_full_path : string list; - search_answer_base_name : string; - search_answer_type : string; +(** A named object in Coq. [coq_object_qualid] is the shortest path defined for + the user. [coq_object_prefix] is the missing part to recover the fully + qualified name, i.e [fully_qualified = coq_object_prefix + coq_object_qualid]. + [coq_object_object] is the actual content of the object. *) +type 'a coq_object = { + coq_object_prefix : string list; + coq_object_qualid : string list; + coq_object_object : 'a; } type coq_info = { diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fe6bf7db..6618b695 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -208,7 +208,7 @@ let show_match id = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" in msg (v 1 (str "match # with" ++ fnl () ++ - prlist_with_sep fnl pr_branch patterns ++ fnl ())) + prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) (* "Print" commands *) -- cgit v1.2.3 From 499a11a45b5711d4eaabe84a80f0ad3ae539d500 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 8 May 2013 17:47:10 +0200 Subject: Imported Upstream version 8.4pl2dfsg --- CHANGES | 29 ++++++++++++ checker/check.ml | 6 +-- checker/checker.ml | 3 +- checker/mod_checking.ml | 7 ++- configure | 2 +- dev/base_include | 4 +- dev/top_printers.ml | 6 +-- ide/coqide.ml | 7 ++- ide/coqide_main.ml4 | 52 +++++++++------------ ide/gtk_parsing.ml | 1 + ide/ide_win32_stubs.c | 44 ++++++++--------- interp/constrextern.ml | 33 +++++++------ interp/constrextern.mli | 9 ++-- interp/constrintern.ml | 14 +++--- interp/implicit_quantifiers.ml | 4 +- interp/notation.ml | 2 +- kernel/csymtable.ml | 4 +- kernel/mod_subst.ml | 25 ++++++---- kernel/modops.ml | 2 +- kernel/modops.mli | 3 +- kernel/names.ml | 10 ++-- kernel/pre_env.ml | 2 +- kernel/safe_typing.ml | 5 +- kernel/subtyping.ml | 12 +++-- lib/envars.ml | 19 ++++---- lib/errors.ml | 13 +++++- lib/errors.mli | 8 ++++ lib/flags.ml | 4 +- lib/hashtbl_alt.ml | 2 +- lib/pp.ml4 | 2 +- lib/profile.ml | 30 ++++++------ lib/store.ml | 2 +- lib/system.ml | 24 ++++++---- lib/system.mli | 2 +- lib/xml_parser.ml | 6 +-- library/declaremods.ml | 4 +- library/heads.ml | 2 +- library/impargs.ml | 4 +- library/library.ml | 17 +++---- myocamlbuild.ml | 15 +++--- parsing/argextend.ml4 | 2 +- parsing/egrammar.ml | 2 +- parsing/g_tactic.ml4 | 2 +- parsing/g_xml.ml4 | 3 +- parsing/prettyp.ml | 8 ++-- parsing/printer.ml | 65 ++++++++++++++++++++++++-- parsing/printer.mli | 11 +++++ parsing/printmod.ml | 59 +++++++++++++++-------- parsing/tacextend.ml4 | 4 +- parsing/vernacextend.ml4 | 4 +- plugins/cc/ccalgo.ml | 7 ++- plugins/cc/cctac.ml | 4 +- plugins/decl_mode/decl_mode.ml | 4 +- plugins/decl_mode/decl_proof_instr.ml | 9 ++-- plugins/extraction/extract_env.ml | 18 ++++--- plugins/extraction/extraction.ml | 4 +- plugins/extraction/haskell.ml | 4 +- plugins/extraction/mlutil.ml | 4 +- plugins/extraction/ocaml.ml | 5 +- plugins/extraction/table.ml | 6 +-- plugins/firstorder/g_ground.ml4 | 2 +- plugins/firstorder/instances.ml | 2 +- plugins/fourier/fourier.ml | 2 +- plugins/fourier/fourierR.ml | 18 ++++--- plugins/funind/functional_principles_proofs.ml | 23 +++++---- plugins/funind/functional_principles_types.ml | 13 ++---- plugins/funind/g_indfun.ml4 | 4 +- plugins/funind/glob_term_to_relation.ml | 13 +++--- plugins/funind/glob_termops.ml | 6 ++- plugins/funind/indfun.ml | 14 +++--- plugins/funind/indfun_common.ml | 18 +++---- plugins/funind/invfun.ml | 17 ++++--- plugins/funind/merge.ml | 6 +-- plugins/funind/recdef.ml | 37 +++++++++------ plugins/micromega/certificate.ml | 7 +-- plugins/micromega/coq_micromega.ml | 24 ++++++---- plugins/micromega/csdpcert.ml | 6 +-- plugins/micromega/mfourier.ml | 3 +- plugins/micromega/mutils.ml | 12 +++-- plugins/micromega/persistent_cache.ml | 10 ++-- plugins/nsatz/ideal.ml | 5 +- plugins/nsatz/polynom.ml | 4 +- plugins/nsatz/utile.ml | 16 ++++--- plugins/omega/coq_omega.ml | 5 +- plugins/quote/quote.ml | 5 +- plugins/ring/ring.ml | 3 +- plugins/romega/const_omega.ml | 4 +- plugins/romega/refl_omega.ml | 30 +++++++----- plugins/subtac/g_subtac.ml4 | 3 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_cases.ml | 5 +- plugins/subtac/subtac_coercion.ml | 4 +- plugins/subtac/subtac_command.ml | 4 +- plugins/subtac/subtac_obligations.ml | 7 +-- plugins/subtac/subtac_pretyping_F.ml | 6 ++- plugins/subtac/subtac_utils.ml | 8 ++-- plugins/xml/cic2acic.ml | 2 +- plugins/xml/doubleTypeInference.ml | 3 +- plugins/xml/xmlcommand.ml | 2 +- pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 6 +-- pretyping/evarconv.ml | 8 ++-- pretyping/evarutil.ml | 27 +++++++---- pretyping/evarutil.mli | 1 + pretyping/evd.ml | 5 +- pretyping/evd.mli | 1 + pretyping/inductiveops.ml | 1 + pretyping/pretyping.ml | 11 +++-- pretyping/recordops.ml | 8 ++-- pretyping/reductionops.ml | 10 +++- pretyping/retyping.ml | 12 ++--- pretyping/tacred.ml | 10 ++-- pretyping/typeclasses.ml | 10 ++-- pretyping/unification.ml | 13 ++++-- pretyping/vnorm.ml | 24 +++++++--- proofs/evar_refiner.ml | 2 +- proofs/goal.ml | 16 +++++-- proofs/goal.mli | 2 +- proofs/logic.ml | 2 +- proofs/pfedit.ml | 6 +-- proofs/proof.ml | 10 ++-- proofs/proofview.ml | 10 ++-- proofs/refiner.ml | 8 ++-- proofs/tactic_debug.ml | 8 ++-- scripts/coqmktop.ml | 13 +++--- tactics/auto.ml | 11 +++-- tactics/autorewrite.ml | 12 +++-- tactics/class_tactics.ml4 | 7 ++- tactics/eauto.ml4 | 3 +- tactics/equality.ml | 5 +- tactics/extratactics.ml4 | 2 +- tactics/hipattern.ml4 | 10 +++- tactics/inv.ml | 4 +- tactics/rewrite.ml4 | 25 ++++++---- tactics/tacinterp.ml | 64 +++++++++++++------------ tactics/tactics.ml | 15 ++++-- test-suite/bugs/closed/2955.v | 52 +++++++++++++++++++++ test-suite/bugs/closed/shouldsucceed/2629.v | 22 +++++++++ test-suite/bugs/closed/shouldsucceed/2668.v | 6 +++ test-suite/bugs/closed/shouldsucceed/2734.v | 15 ++++++ test-suite/bugs/closed/shouldsucceed/2750.v | 23 +++++++++ test-suite/bugs/closed/shouldsucceed/2928.v | 11 +++++ test-suite/bugs/closed/shouldsucceed/2983.v | 8 ++++ test-suite/bugs/closed/shouldsucceed/2995.v | 9 ++++ test-suite/bugs/closed/shouldsucceed/3000.v | 2 + test-suite/bugs/closed/shouldsucceed/3004.v | 7 +++ test-suite/bugs/closed/shouldsucceed/3008.v | 29 ++++++++++++ test-suite/output/inference.out | 4 ++ test-suite/output/inference.v | 12 +++++ test-suite/success/remember.v | 8 ++++ theories/Numbers/NatInt/NZOrder.v | 2 +- toplevel/auto_ind_decl.ml | 44 +++++++++-------- toplevel/autoinstance.ml | 3 +- toplevel/backtrack.ml | 4 +- toplevel/classes.ml | 11 +++-- toplevel/coqinit.ml | 4 +- toplevel/coqtop.ml | 9 ++-- toplevel/himsg.ml | 11 +++-- toplevel/ide_intf.ml | 6 +-- toplevel/ide_slave.ml | 11 +++-- toplevel/ind_tables.ml | 5 +- toplevel/indschemes.ml | 7 +-- toplevel/lemmas.ml | 27 +++++++---- toplevel/metasyntax.ml | 13 ++++-- toplevel/mltop.ml4 | 11 +++-- toplevel/search.ml | 2 +- toplevel/toplevel.ml | 12 ++--- toplevel/vernac.ml | 24 +++++----- toplevel/vernacentries.ml | 13 ++++-- toplevel/vernacinterp.ml | 4 +- 170 files changed, 1205 insertions(+), 632 deletions(-) create mode 100644 test-suite/bugs/closed/2955.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2629.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2668.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2734.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2750.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2928.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2983.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2995.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3000.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3004.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3008.v (limited to 'tactics/auto.ml') diff --git a/CHANGES b/CHANGES index fa0cca0c..a696ad71 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,30 @@ +Changes from V8.4pl1 to V8.4pl2 +=============================== + +Bug fixes + +- Solved bugs : + #2466 #2629 #2668 #2750 #2839 #2869 #2954 #2955 #2959 #2962 #2966 #2967 + #2969 #2970 #2975 #2976 #2977 #2978 #2981 #2983 #2995 #3000 #3004 #3008 +- Partially fixed bugs : #2830 #2949 +- Coqtop should now react more reliably when receiving interrupt signals: + all the "try...with" constructs have been protected against undue + handling of the Sys.Break exception. + +Coqide + +- The Windows-specific code handling the interrupt button of Coqide + had to be reworked (cf. bug #2869). Now, in Win32 this button does + not target a specific coqtop client, but instead sends a Ctrl-C to + any process sharing its console with Coqide. To avoid awkward + effects, it is recommended to launch Coqide via its icon, its menu, + or in a dedicated console window. + +Extraction + +- The option Extraction AccessOpaque is now set by default, + restoring compatibility of older versions of Coq (cf bug #2952). + Changes from V8.4 to V8.4pl1 ============================ @@ -2438,3 +2465,5 @@ New user contributions - Correctness proof of Stalmarck tautology checker algorithm [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis) + + LocalWords: recommended diff --git a/checker/check.ml b/checker/check.ml index 237eb079..fb0dc12a 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -290,9 +290,9 @@ let intern_from_file (dir, f) = let (md,table,digest) = try let ch = with_magic_number_check raw_intern_library f in - let (md:library_disk) = System.marshal_in ch in - let digest = System.marshal_in ch in - let table = (System.marshal_in ch : Safe_typing.LightenLibrary.table) in + let (md:library_disk) = System.marshal_in f ch in + let digest = System.marshal_in f ch in + let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in close_in ch; if dir <> md.md_name then errorlabstrm "load_physical_library" diff --git a/checker/checker.ml b/checker/checker.ml index 945abde4..e5e20b1a 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -371,7 +371,8 @@ let run () = compile_files (); flush_all() with e -> - (Pp.ppnl(explain_exn e); + (flush_all(); + Pp.ppnl(explain_exn e); flush_all(); exit 1) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index e3431fec..dc3ed452 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -133,6 +133,11 @@ let lookup_modtype mp env = with Not_found -> failwith ("Unknown module type: "^string_of_mp mp) +let lookup_module mp env = + try Environ.lookup_module mp env + with Not_found -> + failwith ("Unknown module: "^string_of_mp mp) + let rec check_with env mtb with_decl mp= match with_decl with | With_definition_body (idl,c) -> @@ -199,7 +204,7 @@ and check_with_mod env mtb (idl,mp1) mp = SFBmodule msb -> msb | _ -> error_not_a_module l in - let (_:module_body) = (lookup_module mp1 env) in () + let (_:module_body) = (Environ.lookup_module mp1 env) in () else let old = match spec with SFBmodule msb -> msb diff --git a/configure b/configure index 589cba6e..f7bdf154 100755 --- a/configure +++ b/configure @@ -6,7 +6,7 @@ # ################################## -VERSION=8.4pl1 +VERSION=8.4pl2 VOMAGIC=08400 STATEMAGIC=58400 DATE=`LC_ALL=C LANG=C date +"%B %Y"` diff --git a/dev/base_include b/dev/base_include index ad2a3aec..9a788b7b 100644 --- a/dev/base_include +++ b/dev/base_include @@ -200,8 +200,8 @@ let pf_e gl s = (* Set usual printing since the global env is available from the tracer *) let _ = Constrextern.in_debugger := false -let _ = Constrextern.set_debug_global_reference_printer - (fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; +let _ = Constrextern.set_extern_reference + (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; open Toplevel let go = loop diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0038e78a..c55c4377 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -459,7 +459,7 @@ let encode_path loc prefix mpdir suffix id = Qualid (loc, make_qualid (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id) -let raw_string_of_ref loc = function +let raw_string_of_ref loc _ = function | ConstRef cst -> let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id) @@ -475,7 +475,7 @@ let raw_string_of_ref loc = function | VarRef id -> encode_path loc "SECVAR" None [] id -let short_string_of_ref loc = function +let short_string_of_ref loc _ = function | VarRef id -> Ident (loc,id) | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst))) | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn))) @@ -491,5 +491,5 @@ let short_string_of_ref loc = function pretty-printer should not make calls to the global env since ocamldebug runs in a different process and does not have the proper env at hand *) let _ = Constrextern.in_debugger := true -let _ = Constrextern.set_debug_global_reference_printer +let _ = Constrextern.set_extern_reference (if !rawdebug then raw_string_of_ref else short_string_of_ref) diff --git a/ide/coqide.ml b/ide/coqide.ml index 07de4daf..94be8318 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -212,6 +212,9 @@ let ignore_break () = try Sys.set_signal i (Sys.Signal_handle crash_save) with _ -> prerr_endline "Signal ignored (normal if Win32)") signals_to_crash; + (* We ignore the Ctrl-C, this is required for the Stop button to work, + since we will actually send Ctrl-C to all processes sharing + our console (including us) *) Sys.set_signal Sys.sigint Sys.Signal_ignore @@ -902,7 +905,7 @@ object(self) if stop#compare start > 0 && is_sentence_end stop#backward_char then Some (start,stop) else None - with Not_found -> None + with StartError -> None method complete_at_offset (offset:int) = prerr_endline ("Completion at offset : " ^ string_of_int offset); @@ -2449,7 +2452,7 @@ let main files = try configure ~apply:update_notebook_pos () with _ -> flash_info "Cannot save preferences" end; - reset_revert_timer ()) ~accel:"," ~stock:`PREFERENCES; + reset_revert_timer ()) ~accel:"comma" ~stock:`PREFERENCES; (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; GAction.add_actions view_actions [ GAction.add_action "View" ~label:"_View"; diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index ebcecc17..aaede465 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -38,6 +38,11 @@ let catch_gtk_messages () = let () = catch_gtk_messages () +(* We anticipate a bit the argument parsing and look for -debug *) + +let early_set_debug () = + Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv) + (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) @@ -46,47 +51,32 @@ let set_win32_path () = (Filename.dirname Sys.executable_name ^ ";" ^ (try Sys.getenv "PATH" with _ -> "")) -(* On win32, since coqide is now console-free, we re-route stdout/stderr - to avoid Sys_error if someone writes to them. We write to a pipe which - is never read (by default) or to a temp log file (when in debug mode). -*) - -let reroute_stdout_stderr () = - (* We anticipate a bit the argument parsing and look for -debug *) - let debug = List.mem "-debug" (Array.to_list Sys.argv) in - Ideutils.debug := debug; - let out_descr = - if debug then - let (name,chan) = Filename.open_temp_file "coqide_" ".log" in - Coqide.logfile := Some name; - Unix.descr_of_out_channel chan - else - snd (Unix.pipe ()) - in +(* On win32, in debug mode we duplicate stdout/stderr in a log file. *) + +let log_stdout_stderr () = + let (name,chan) = Filename.open_temp_file "coqide_" ".log" in + Coqide.logfile := Some name; + let out_descr = Unix.descr_of_out_channel chan in Unix.set_close_on_exec out_descr; Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr (* We also provide specific kill and interrupt functions. *) -(* Since [win32_interrupt] involves some hack about the process console, - only one should run at the same time, we simply skip execution of - [win32_interrupt] if another instance is already running *) - -let ctrl_c_mtx = Mutex.create () - -let ctrl_c_protect f i = - if not (Mutex.try_lock ctrl_c_mtx) then () - else try f i; Mutex.unlock ctrl_c_mtx with _ -> Mutex.unlock ctrl_c_mtx - IFDEF WIN32 THEN external win32_kill : int -> unit = "win32_kill" -external win32_interrupt : int -> unit = "win32_interrupt" +external win32_interrupt_all : unit -> unit = "win32_interrupt_all" +external win32_hide_console : unit -> unit = "win32_hide_console" + let () = - Coq.killer := win32_kill; - Coq.interrupter := ctrl_c_protect win32_interrupt; set_win32_path (); - reroute_stdout_stderr () + Coq.killer := win32_kill; + Coq.interrupter := (fun pid -> win32_interrupt_all ()); + early_set_debug (); + if !Ideutils.debug then + log_stdout_stderr () + else + win32_hide_console () END IFDEF QUARTZ THEN diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 67f7e649..47096e6f 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ideutils let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0) diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c index c09bf37d..c170b1a9 100644 --- a/ide/ide_win32_stubs.c +++ b/ide/ide_win32_stubs.c @@ -19,31 +19,33 @@ CAMLprim value win32_kill(value pseudopid) { CAMLreturn(Val_unit); } - /* Win32 emulation of a kill -2 (SIGINT) */ -/* This code rely of the fact that coqide is now without initial console. - Otherwise, no console creation in win32unix/createprocess.c, hence - the same console for coqide and all coqtop, and everybody will be - signaled at the same time by the code below. */ +/* For simplicity, we signal all processes sharing a console with coqide. + This shouldn't be an issue since currently at most one coqtop is busy + at a given time. Earlier, we tried to be more precise via + FreeConsole and AttachConsole before generating the Ctrl-C, but + that wasn't working so well (see #2869). + This code rely now on the fact that coqide is a console app, + and that coqide itself ignores Ctrl-C. +*/ + +CAMLprim value win32_interrupt_all(value unit) { + CAMLparam1(unit); + GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); + CAMLreturn(Val_unit); +} -/* Moreover, AttachConsole exists only since WinXP, and GetProcessId - since WinXP SP1. For avoiding the GetProcessId, we could adapt code - from win32unix/createprocess.c to make it return both the pid and the - handle. For avoiding the AttachConsole, I don't know, maybe having - an intermediate process between coqide and coqtop ? */ +/* Get rid of the nasty console window (only if we created it) */ -CAMLprim value win32_interrupt(value pseudopid) { - CAMLparam1(pseudopid); - HANDLE h; +CAMLprim value win32_hide_console (value unit) { + CAMLparam1(unit); DWORD pid; - FreeConsole(); /* Normally unnecessary, just to be sure... */ - h = (HANDLE)(Long_val(pseudopid)); - pid = GetProcessId(h); - AttachConsole(pid); - /* We want to survive the Ctrl-C that will also concerns us */ - SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */ - GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */ - FreeConsole(); + HWND hw = GetConsoleWindow(); + if (hw != NULL) { + GetWindowThreadProcessId(hw, &pid); + if (pid == GetCurrentProcessId()) + ShowWindow(hw, SW_HIDE); + } CAMLreturn(Val_unit); } diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 20b9c2a3..ee529fe0 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -137,20 +137,21 @@ let insert_pat_alias loc p = function let extern_evar loc n l = if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None) -let debug_global_reference_printer = - ref (fun _ -> failwith "Cannot print a global reference") +(** We allow customization of the global_reference printer. + For instance, in the debugger the tables of global references + may be inaccurate *) -let in_debugger = ref false +let default_extern_reference loc vars r = + Qualid (loc,shortest_qualid_of_global vars r) -let set_debug_global_reference_printer f = - debug_global_reference_printer := f +let my_extern_reference = ref default_extern_reference -let extern_reference loc vars r = - if !in_debugger then - (* Debugger does not have the tables of global reference at hand *) - !debug_global_reference_printer loc r - else - Qualid (loc,shortest_qualid_of_global vars r) +let set_extern_reference f = my_extern_reference := f +let get_extern_reference () = !my_extern_reference + +let extern_reference loc vars l = !my_extern_reference loc vars l + +let in_debugger = ref false (************************************************************************) @@ -303,10 +304,10 @@ let make_notation_gen loc ntn mknot mkprim destprim l = match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with _ -> mknot (loc,ntn,[])) + with e when Errors.noncritical e -> mknot (loc,ntn,[])) | [Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.of_string x)) - with _ -> mknot (loc,ntn,[])) + with e when Errors.noncritical e -> mknot (loc,ntn,[])) | _ -> mknot (loc,ntn,l) @@ -816,12 +817,14 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function match f with | GRef (_,ref) -> let subscopes = - try list_skipn n (find_arguments_scope ref) with _ -> [] in + try list_skipn n (find_arguments_scope ref) + with e when Errors.noncritical e -> [] in let impls = let impls = select_impargs_size (List.length args) (implicits_of_global ref) in - try list_skipn n impls with _ -> [] in + try list_skipn n impls + with e when Errors.noncritical e -> [] in subscopes,impls | _ -> [], [] in diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 1a1560e5..55fababd 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -50,9 +50,12 @@ val print_universes : bool ref val print_no_symbol : bool ref val print_projections : bool ref -(** Debug printing options *) -val set_debug_global_reference_printer : - (loc -> global_reference -> reference) -> unit +(** Customization of the global_reference printer *) +val set_extern_reference : + (loc -> Idset.t -> global_reference -> reference) -> unit +val get_extern_reference : + unit -> (loc -> Idset.t -> global_reference -> reference) + val in_debugger : bool ref (** This governs printing of implicit arguments. If [with_implicits] is diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 81e4501a..e806686a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -650,7 +650,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; GRef (loc, ref), impls, scopes, [] - with _ -> + with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] @@ -716,7 +716,7 @@ let intern_applied_reference intern env namedctx lvar args = function try let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in find_appl_head_data r, args2 - with e -> + with e when Errors.noncritical e -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (GVar (loc,id), [], [], []),args @@ -969,15 +969,15 @@ let sort_fields mode loc l completer = | [] -> anomaly "Number of projections mismatch" | (_, regular)::tm -> let boolean = not regular in - if ConstRef name = global_reference_of_reference refer - then + (match global_reference_of_reference refer with + | ConstRef name' when eq_constant name name' -> if boolean && mode then user_err_loc (loc, "", str"No local fields allowed in a record construction.") else build_patt b tm (i + 1) (i, snd acc) (* we found it *) - else + | _ -> build_patt b tm (if boolean&&mode then i else i + 1) (if boolean && mode then acc - else fst acc, (i, ConstRef name) :: snd acc)) + else fst acc, (i, ConstRef name) :: snd acc))) | None :: b-> (* we don't want anonymous fields *) if mode then user_err_loc (loc, "", str "This record contains anonymous fields.") @@ -1009,7 +1009,7 @@ let sort_fields mode loc l completer = (loc, "", str "This record contains fields of different records.") | (i, a) :: b-> - if glob_refer = a + if eq_gr glob_refer a then (i,List.rev_append acc l) else add_patt b ((i,a)::acc) in diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 9950178c..2c000258 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -88,8 +88,8 @@ let is_freevar ids env x = if Idset.mem x ids then false else try ignore(Environ.lookup_named x env) ; false - with _ -> not (is_global x) - with _ -> true + with e when Errors.noncritical e -> not (is_global x) + with e when Errors.noncritical e -> true (* Auxiliary functions for the inference of implicitly quantified variables. *) diff --git a/interp/notation.ml b/interp/notation.ml index e3fb5d5e..03fa23a3 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -838,4 +838,4 @@ let _ = let with_notation_protection f x = let fs = freeze () in try let a = f x in unfreeze fs; a - with e -> unfreeze fs; raise e + with reraise -> unfreeze fs; raise reraise diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 8d09cbd7..9c9f6a57 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -190,7 +190,9 @@ and eval_to_patch env (buff,pl,fv) = and val_of_constr env c = let (_,fun_code,_ as ccfv) = try compile env c - with e -> print_string "can not compile \n";Format.print_flush();raise e in + with reraise -> + print_string "can not compile \n";Format.print_flush();raise reraise + in eval_to_patch env (to_memory ccfv) let set_transparent_const kn = diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 15a48e1c..9aeaf110 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -83,13 +83,14 @@ let string_of_hint = function | Equiv kn -> string_of_kn kn let debug_string_of_delta resolve = - let kn_to_string kn hint s = - s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint) + let kn_to_string kn hint l = + (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l in - let mp_to_string mp mp' s = - s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp') + let mp_to_string mp mp' l = + (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l in - Deltamap.fold mp_to_string kn_to_string resolve "" + let l = Deltamap.fold mp_to_string kn_to_string resolve [] in + String.concat ", " (List.rev l) let list_contents sub = let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in @@ -173,7 +174,7 @@ let solve_delta_kn resolve kn = let kn_of_delta resolve kn = try solve_delta_kn resolve kn - with _ -> kn + with e when Errors.noncritical e -> kn let constant_of_delta_kn resolve kn = constant_of_kn_equiv kn (kn_of_delta resolve kn) @@ -182,7 +183,7 @@ let gen_of_delta resolve x kn fix_can = try let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn - with _ -> x + with e when Errors.noncritical e -> x let constant_of_delta resolve con = let kn = user_con con in @@ -223,8 +224,10 @@ let constant_of_delta_with_inline resolve con = let kn1,kn2 = canonical_con con,user_con con in try find_inline_of_delta kn2 resolve with Not_found -> - try find_inline_of_delta kn1 resolve - with Not_found -> None + if kn1 == kn2 then None + else + try find_inline_of_delta kn1 resolve + with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = @@ -272,7 +275,9 @@ type sideconstantsubst = | Canonical let gen_subst_mp f sub mp1 mp2 = - match subst_mp0 sub mp1, subst_mp0 sub mp2 with + let o1 = subst_mp0 sub mp1 in + let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in + match o1, o2 with | None, None -> raise No_subst | Some (mp',resolve), None -> User, (f mp' mp2), resolve | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve diff --git a/kernel/modops.ml b/kernel/modops.ml index af32288c..a81f868e 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -33,7 +33,7 @@ type signature_mismatch_error = | NotConvertibleInductiveField of identifier | NotConvertibleConstructorField of identifier | NotConvertibleBodyField - | NotConvertibleTypeField + | NotConvertibleTypeField of env * types * types | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool diff --git a/kernel/modops.mli b/kernel/modops.mli index d03d61bd..daea3258 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -9,6 +9,7 @@ open Util open Names open Univ +open Term open Environ open Declarations open Entries @@ -60,7 +61,7 @@ type signature_mismatch_error = | NotConvertibleInductiveField of identifier | NotConvertibleConstructorField of identifier | NotConvertibleBodyField - | NotConvertibleTypeField + | NotConvertibleTypeField of env * types * types | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool diff --git a/kernel/names.ml b/kernel/names.ml index 17bda124..8c228404 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -205,7 +205,9 @@ type constant = kernel_name*kernel_name let constant_of_kn kn = (kn,kn) let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) let make_con mp dir l = constant_of_kn (mp,dir,l) -let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let make_con_equiv mp1 mp2 dir l = + if mp1 == mp2 then make_con mp1 dir l + else ((mp1,dir,l),(mp2,dir,l)) let canonical_con con = snd con let user_con con = fst con let repr_con con = fst con @@ -263,8 +265,10 @@ let constr_modpath c = ind_modpath (fst c) let mind_of_kn kn = (kn,kn) let mind_of_kn_equiv kn1 kn2 = (kn1,kn2) -let make_mind mp dir l = ((mp,dir,l),(mp,dir,l)) -let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let make_mind mp dir l = mind_of_kn (mp,dir,l) +let make_mind_equiv mp1 mp2 dir l = + if mp1 == mp2 then make_mind mp1 dir l + else ((mp1,dir,l),(mp2,dir,l)) let canonical_mind mind = snd mind let user_mind mind = fst mind let repr_mind mind = fst mind diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 6c08c34c..f0a3292c 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -90,7 +90,7 @@ let push_rel d env = let lookup_rel_val n env = try List.nth env.env_rel_val (n - 1) - with _ -> raise Not_found + with e when Errors.noncritical e -> raise Not_found let env_of_rel n env = { env with diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 1d606782..ec891e13 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -477,7 +477,7 @@ let end_module l restype senv = in let str = match sign with | SEBstruct(str_l) -> str_l - | _ -> error ("You cannot Include a high-order structure.") + | _ -> error ("You cannot Include a higher-order structure.") in let senv = update_resolver (add_delta_resolver resolver) senv in @@ -873,7 +873,8 @@ end = struct let k = key_of_lazy_constr k in let access key = try (Lazy.force table).(key) - with _ -> error "Error while retrieving an opaque body" + with e when Errors.noncritical e -> + error "Error while retrieving an opaque body" in match load_proof with | Flags.Force -> diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index e2c5f48c..c809572a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -219,6 +219,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = + let err = NotConvertibleTypeField (env, t1, t2) in + (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of @@ -257,12 +259,12 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = (the user has to use an explicit type in the interface *) error NoTypeConstraintExpected with NotArity -> - error NotConvertibleTypeField end + error err end | _ -> t1,t2 else (t1,t2) in - check_conv NotConvertibleTypeField cst conv_leq env t1 t2 + check_conv err cst conv_leq env t1 t2 in match info1 with @@ -301,7 +303,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = if constant_has_body cb2 then error DefinitionFieldExpected; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2 + let error = NotConvertibleTypeField (env, arity1, typ2) in + check_conv error cst conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -312,7 +315,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = if constant_has_body cb2 then error DefinitionFieldExpected; let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv NotConvertibleTypeField cst conv env ty1 ty2 + let error = NotConvertibleTypeField (env, ty1, ty2) in + check_conv error cst conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in diff --git a/lib/envars.ml b/lib/envars.ml index 4ec68a27..c672d30c 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -23,6 +23,8 @@ let _ = if Coq_config.arch = "win32" then Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "") +let exe s = s ^ Coq_config.exec_extension + let reldir instdir testfile oth = let rpath = if Coq_config.local then [] else instdir in let out = List.fold_left Filename.concat coqroot rpath in @@ -87,19 +89,19 @@ let rec which l f = else which tl f let guess_camlbin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in - which lpath "ocamlc" + which lpath (exe "ocamlc") let guess_camlp4bin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in - which lpath Coq_config.camlp4 + which lpath (exe Coq_config.camlp4) let camlbin () = if !Flags.camlbin_spec then !Flags.camlbin else if !Flags.boot then Coq_config.camlbin else - try guess_camlbin () with _ -> Coq_config.camlbin + try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin let camllib () = if !Flags.boot @@ -113,9 +115,10 @@ let camllib () = let camlp4bin () = if !Flags.camlp4bin_spec then !Flags.camlp4bin else if !Flags.boot then Coq_config.camlp4bin else - try guess_camlp4bin () with _ -> let cb = camlbin () in - if Sys.file_exists (Filename.concat cb Coq_config.camlp4) then cb - else Coq_config.camlp4bin + try guess_camlp4bin () with e when e <> Sys.Break -> + let cb = camlbin () in + if Sys.file_exists (Filename.concat cb (exe Coq_config.camlp4)) then cb + else Coq_config.camlp4bin let camlp4lib () = if !Flags.boot diff --git a/lib/errors.ml b/lib/errors.ml index 3b5e6770..6affea23 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -28,7 +28,7 @@ let rec print_gen bottom stk e = try h e with | Unhandled -> print_gen bottom stk' e - | e' -> print_gen bottom stk' e' + | any -> print_gen bottom stk' any (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always @@ -66,3 +66,14 @@ let _ = register_handler begin function | _ -> raise Unhandled end +(** Critical exceptions shouldn't be catched and ignored by mistake + by inner functions during a [vernacinterp]. They should be handled + only at the very end of interp, to be displayed to the user. *) + +(** NB: in the 8.4 branch, for maximal compatibility, anomalies + are considered non-critical *) + +let noncritical = function + | Sys.Break | Out_of_memory | Stack_overflow -> false + | _ -> true + diff --git a/lib/errors.mli b/lib/errors.mli index eb7fde8e..ae4d0b85 100644 --- a/lib/errors.mli +++ b/lib/errors.mli @@ -39,3 +39,11 @@ val print_no_report : exn -> Pp.std_ppcmds (** Same as [print], except that anomalies are not printed but re-raised (used for the Fail command) *) val print_no_anomaly : exn -> Pp.std_ppcmds + +(** Critical exceptions shouldn't be catched and ignored by mistake + by inner functions during a [vernacinterp]. They should be handled + only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user. + Typical example: [Sys.Break]. In the 8.4 branch, for maximal + compatibility, anomalies are not considered as critical... +*) +val noncritical : exn -> bool diff --git a/lib/flags.ml b/lib/flags.ml index 3474573e..32c68b25 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -9,12 +9,12 @@ let with_option o f x = let old = !o in o:=true; try let r = f x in o := old; r - with e -> o := old; raise e + with reraise -> o := old; raise reraise let without_option o f x = let old = !o in o:=false; try let r = f x in o := old; r - with e -> o := old; raise e + with reraise -> o := old; raise reraise let boot = ref false diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml index 2780afe8..bb2252da 100644 --- a/lib/hashtbl_alt.ml +++ b/lib/hashtbl_alt.ml @@ -89,7 +89,7 @@ module Make (E : Hashtype) = match rest2 with | Empty -> add hash key; key | Cons (k3, h3, rest3) -> - if hash == h2 && E.equals key k3 then k3 + if hash == h3 && E.equals key k3 then k3 else find_rec hash key rest3 end diff --git a/lib/pp.ml4 b/lib/pp.ml4 index 7777d091..569a028f 100644 --- a/lib/pp.ml4 +++ b/lib/pp.ml4 @@ -279,7 +279,7 @@ let pp_dirs ft = try Stream.iter pp_dir dirstream; com_brk ft with - | e -> Format.pp_print_flush ft () ; raise e + | reraise -> Format.pp_print_flush ft () ; raise reraise (* pretty print on stdout and stderr *) diff --git a/lib/profile.ml b/lib/profile.ml index 2472d75d..39e08721 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -260,7 +260,7 @@ let time_overhead_B_C () = let _dw = dummy_spent_alloc () in let _dt = get_time () in () - with _ -> assert false + with e when e <> Sys.Break -> assert false done; let after = get_time () in let beforeloop = get_time () in @@ -390,7 +390,7 @@ let profile1 e f a = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -403,7 +403,7 @@ let profile1 e f a = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile2 e f a b = let dw = spent_alloc () in @@ -432,7 +432,7 @@ let profile2 e f a b = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -445,7 +445,7 @@ let profile2 e f a b = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile3 e f a b c = let dw = spent_alloc () in @@ -474,7 +474,7 @@ let profile3 e f a b c = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -487,7 +487,7 @@ let profile3 e f a b c = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile4 e f a b c d = let dw = spent_alloc () in @@ -516,7 +516,7 @@ let profile4 e f a b c d = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -529,7 +529,7 @@ let profile4 e f a b c d = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile5 e f a b c d g = let dw = spent_alloc () in @@ -558,7 +558,7 @@ let profile5 e f a b c d g = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -571,7 +571,7 @@ let profile5 e f a b c d g = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile6 e f a b c d g h = let dw = spent_alloc () in @@ -600,7 +600,7 @@ let profile6 e f a b c d g h = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -613,7 +613,7 @@ let profile6 e f a b c d g h = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile7 e f a b c d g h i = let dw = spent_alloc () in @@ -642,7 +642,7 @@ let profile7 e f a b c d g h i = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -655,7 +655,7 @@ let profile7 e f a b c d g h i = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise (* Some utilities to compute the logical and physical sizes and depth of ML objects *) diff --git a/lib/store.ml b/lib/store.ml index bc1b335f..28eb65c8 100644 --- a/lib/store.ml +++ b/lib/store.ml @@ -53,7 +53,7 @@ let field () = in let get s = try Some (Obj.obj (Util.Intmap.find fid s)) - with _ -> None + with Not_found -> None in let remove s = Util.Intmap.remove fid s diff --git a/lib/system.ml b/lib/system.ml index a99c29f2..ae637708 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -140,7 +140,8 @@ let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames let ok_dirname f = f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) && - try ignore (check_ident f); true with _ -> false + try ignore (check_ident f); true + with e when e <> Sys.Break -> false let all_subdirs ~unix_path:root = let l = ref [] in @@ -223,17 +224,22 @@ let file_readable_p name = try access name [R_OK];true with Unix_error (_, _, _) -> false let open_trapping_failure name = - try open_out_bin name with _ -> error ("Can't open " ^ name) + try open_out_bin name + with e when e <> Sys.Break -> error ("Can't open " ^ name) let try_remove filename = try Sys.remove filename - with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++ - str filename ++ str" which is corrupted!" ) + with e when e <> Sys.Break -> + msgnl (str"Warning: " ++ str"Could not remove file " ++ + str filename ++ str" which is corrupted!" ) let marshal_out ch v = Marshal.to_channel ch v [] -let marshal_in ch = +let marshal_in filename ch = try Marshal.from_channel ch - with End_of_file -> error "corrupted file: reached end of file" + with + | End_of_file -> error "corrupted file: reached end of file" + | Failure _ (* e.g. "truncated object" *) -> + error (filename ^ " is corrupted, try to rebuild it.") exception Bad_magic_number of string @@ -259,14 +265,14 @@ let extern_intern ?(warn=true) magic suffix = try marshal_out channel val_0; close_out channel - with e -> - begin try_remove filename; raise e end + with reraise -> + begin try_remove filename; raise reraise end with Sys_error s -> error ("System error: " ^ s) and intern_state paths name = try let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in let channel = raw_intern filename in - let v = marshal_in channel in + let v = marshal_in filename channel in close_in channel; v with Sys_error s -> diff --git a/lib/system.mli b/lib/system.mli index 4a79b874..d8420e7d 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -47,7 +47,7 @@ val find_file_in_path : when the check fails, with the full file name. *) val marshal_out : out_channel -> 'a -> unit -val marshal_in : in_channel -> 'a +val marshal_in : string -> in_channel -> 'a exception Bad_magic_number of string diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml index 19bab4f6..600796f7 100644 --- a/lib/xml_parser.ml +++ b/lib/xml_parser.ml @@ -175,7 +175,7 @@ let do_parse xparser source = if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close source; x - with e -> + with e when e <> Sys.Break -> Xml_lexer.close source; raise (!xml_error (error_of_exn stk e) source) @@ -190,9 +190,9 @@ let parse p = function close_in ch; x with - e -> + reraise -> close_in ch; - raise e + raise reraise let error_msg = function diff --git a/library/declaremods.ml b/library/declaremods.ml index 80da9e73..db7b8915 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -990,9 +990,9 @@ let declare_include_ interp_struct me_asts = let protect_summaries f = let fs = Summary.freeze_summaries () in try f fs - with e -> + with reraise -> (* Something wrong: undo the whole process *) - Summary.unfreeze_summaries fs; raise e + Summary.unfreeze_summaries fs; raise reraise let declare_include interp_struct me_asts = protect_summaries diff --git a/library/heads.ml b/library/heads.ml index b860dc2a..c33ea9b1 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -88,7 +88,7 @@ let kind_of_head env t = | Sort _ | Ind _ | Prod _ -> RigidHead RigidType | Cast (c,_,_) -> aux k l c b | Lambda (_,_,c) when l = [] -> assert (not b); aux (k+1) [] c b - | Lambda (_,_,c) -> aux (k+1) (List.tl l) (subst1 (List.hd l) c) b + | Lambda (_,_,c) -> aux k (List.tl l) (subst1 (List.hd l) c) b | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b diff --git a/library/impargs.ml b/library/impargs.ml index c79edb99..930b8f09 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -74,9 +74,9 @@ let with_implicits flags f x = let rslt = f x in implicit_args := oflags; rslt - with e -> begin + with reraise -> begin implicit_args := oflags; - raise e + raise reraise end let set_maximality imps b = diff --git a/library/library.ml b/library/library.ml index 30e7b675..c857fc86 100644 --- a/library/library.ml +++ b/library/library.ml @@ -368,14 +368,14 @@ let explain_locate_library_error qid = function let try_locate_absolute_library dir = try locate_absolute_library dir - with e -> + with e when Errors.noncritical e -> explain_locate_library_error (qualid_of_dirpath dir) e let try_locate_qualified_library (loc,qid) = try let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in dir,f - with e -> + with e when Errors.noncritical e -> explain_locate_library_error qid e @@ -398,20 +398,20 @@ let fetch_opaque_table (f,pos,digest) = try let ch = System.with_magic_number_check raw_intern_library f in seek_in ch pos; - if System.marshal_in ch <> digest then failwith "File changed!"; - let table = (System.marshal_in ch : LightenLibrary.table) in + if System.marshal_in f ch <> digest then failwith "File changed!"; + let table = (System.marshal_in f ch : LightenLibrary.table) in close_in ch; table - with _ -> + with e when Errors.noncritical e -> error ("The file "^f^" is inaccessible or has changed,\n" ^ "cannot load some opaque constant bodies in it.\n") let intern_from_file f = let ch = System.with_magic_number_check raw_intern_library f in - let lmd = System.marshal_in ch in + let lmd = System.marshal_in f ch in let pos = pos_in ch in - let digest = System.marshal_in ch in + let digest = System.marshal_in f ch in let table = lazy (fetch_opaque_table (f,pos,digest)) in register_library_filename lmd.md_name f; let library = mk_library lmd table digest in @@ -655,7 +655,8 @@ let save_library_to dir f = System.marshal_out ch di; System.marshal_out ch table; close_out ch - with e -> warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise e + with reraise -> + warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise reraise (************************************************************************) (*s Display the memory use of a library. *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 184985b5..7a214bcd 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -393,14 +393,17 @@ let extra_rules () = begin Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc; A "--output-format";A "coff";A "--output"; Px o])); -(** The windows version of Coqide is now a console-free win32 app, - which moreover contains the Coq icon. If necessary, the mkwinapp - tool can be used later to restore or suppress the console of Coqide. *) +(** Embed the Coq icon inside the windows version of Coqide *) if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico]; - - if w32 then flag ["link"; "ocaml"; "program"; "ide"] - (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]); + if w32 then flag ["link"; "ocaml"; "program"; "ide"] (P w32ico); + +(** Ealier we tried to make Coqide a console-free win32 app, + but that was troublesome (unavailable stdout/stderr, issues + with the stop button,...). If somebody really want to try again, + the extra args to add are : + [A "-ccopt"; A "-link -Wl,-subsystem,windows"] + Other solution: use the mkwinapp tool. *) (** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". Let's tweak that... *) diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 1888ef17..214a6b98 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -146,7 +146,7 @@ let possibly_empty_subentries loc (prods,act) = (* an exception rather than returning a value; *) (* declares loc because some code can refer to it; *) (* ensures loc is used to avoid "unused variable" warning *) - (true, <:expr< try Some $aux prods$ with [ _ -> None ] >>) + (true, <:expr< try Some $aux prods$ with [ e when Errors.noncritical e -> None ] >>) else (* Static optimisation *) (false, aux prods) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index c68ba137..12359776 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -365,4 +365,4 @@ let _ = let with_grammar_rule_protection f x = let fs = freeze () in try let a = f x in unfreeze fs; a - with e -> unfreeze fs; raise e + with reraise -> unfreeze fs; raise reraise diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index d265729a..1609e541 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -126,7 +126,7 @@ let mk_cofix_tac (loc,id,bl,ann,ty) = let induction_arg_of_constr (c,lbind as clbind) = if lbind = NoBindings then try ElimOnIdent (constr_loc c,snd(coerce_to_id c)) - with _ -> ElimOnConstr clbind + with e when Errors.noncritical e -> ElimOnConstr clbind else ElimOnConstr clbind let mkTacCase with_evar = function diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 9dd0e369..869674f4 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -104,7 +104,8 @@ let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) let get_xml_inductive_kn al = inductive_of_cdata (* uriType apparent synonym of uri *) - (try get_xml_attr "uri" al with _ -> get_xml_attr "uriType" al) + (try get_xml_attr "uri" al + with e when Errors.noncritical e -> get_xml_attr "uriType" al) let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index d3eb40d0..99e10908 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -273,7 +273,9 @@ let print_inductive_implicit_args = let print_inductive_renames = print_args_data_of_inductive_ids - (fun r -> try List.hd (Arguments_renaming.arguments_names r) with _ -> []) + (fun r -> + try List.hd (Arguments_renaming.arguments_names r) + with e when Errors.noncritical e -> []) ((<>) Anonymous) print_renames_list @@ -737,7 +739,7 @@ let print_coercions () = let index_of_class cl = try fst (class_info cl) - with _ -> + with e when Errors.noncritical e -> errorlabstrm "index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") @@ -747,7 +749,7 @@ let print_path_between cls clt = let p = try lookup_path_between_class (i,j) - with _ -> + with e when Errors.noncritical e -> errorlabstrm "index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") diff --git a/parsing/printer.ml b/parsing/printer.ml index 9f0cb00d..29ebe4fa 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -24,6 +24,7 @@ open Pfedit open Ppconstr open Constrextern open Tacexpr +open Declarations open Store.Field @@ -118,6 +119,63 @@ let pr_sort s = pr_glob_sort (extern_sort s) let _ = Termops.set_print_constr pr_lconstr_env + +(** Term printers resilient to [Nametab] errors *) + +(** When the nametab isn't up-to-date, the term printers above + could raise [Not_found] during [Nametab.shortest_qualid_of_global]. + In this case, we build here a fully-qualified name based upon + the kernel modpath and label of constants, and the idents in + the [mutual_inductive_body] for the inductives and constructors + (needs an environment for this). *) + +let id_of_global env = function + | ConstRef kn -> id_of_label (con_label kn) + | IndRef (kn,0) -> id_of_label (mind_label kn) + | IndRef (kn,i) -> + (Environ.lookup_mind kn env).mind_packets.(i).mind_typename + | ConstructRef ((kn,i),j) -> + (Environ.lookup_mind kn env).mind_packets.(i).mind_consnames.(j-1) + | VarRef v -> v + +let cons_dirpath id dp = make_dirpath (id :: repr_dirpath dp) + +let rec dirpath_of_mp = function + | MPfile sl -> sl + | MPbound uid -> make_dirpath [id_of_mbid uid] + | MPdot (mp,l) -> cons_dirpath (id_of_label l) (dirpath_of_mp mp) + +let dirpath_of_global = function + | ConstRef kn -> dirpath_of_mp (con_modpath kn) + | IndRef (kn,_) | ConstructRef ((kn,_),_) -> + dirpath_of_mp (mind_modpath kn) + | VarRef _ -> empty_dirpath + +let qualid_of_global env r = + Libnames.make_qualid (dirpath_of_global r) (id_of_global env r) + +let safe_gen f env c = + let orig_extern_ref = Constrextern.get_extern_reference () in + let extern_ref loc vars r = + try orig_extern_ref loc vars r + with e when Errors.noncritical e -> + Libnames.Qualid (loc, qualid_of_global env r) + in + Constrextern.set_extern_reference extern_ref; + try + let p = f env c in + Constrextern.set_extern_reference orig_extern_ref; + p + with e when Errors.noncritical e -> + Constrextern.set_extern_reference orig_extern_ref; + str "??" + +let safe_pr_lconstr_env = safe_gen pr_lconstr_env +let safe_pr_constr_env = safe_gen pr_constr_env +let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t +let safe_pr_constr t = safe_pr_constr_env (Global.env()) t + + (**********************************************************************) (* Global references *) @@ -389,7 +447,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals = | None -> let exl = Evarutil.non_instantiated sigma in if exl = [] then - (str"No more subgoals." + (str"No more subgoals." ++ fnl () ++ emacs_print_dependent_evars sigma seeds) else let pei = pr_evars_int 1 exl in @@ -415,7 +473,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals = v 0 ( int(List.length rest+1) ++ str" subgoals" ++ str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut () - ++ goals + ++ goals ++ fnl () ++ emacs_print_dependent_evars sigma seeds ) | g1::rest,a::l -> @@ -589,7 +647,7 @@ let pr_assumptionset env s = str (string_of_mp mp ^ "." ^ string_of_label lab) in let safe_pr_ltype typ = - try str " : " ++ pr_ltype typ with _ -> mt () + try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt () in let (vars,axioms,opaque) = ContextObjectMap.fold (fun t typ r -> @@ -647,7 +705,6 @@ let pr_instance_gmap insts = (** Inductive declarations *) -open Declarations open Termops open Reduction open Inductive diff --git a/parsing/printer.mli b/parsing/printer.mli index a034f0ed..3abe90e7 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -31,6 +31,17 @@ val pr_lconstr : constr -> std_ppcmds val pr_constr_env : env -> constr -> std_ppcmds val pr_constr : constr -> std_ppcmds +(** Same, but resilient to [Nametab] errors. Prints fully-qualified + names when [shortest_qualid_of_global] has failed. Prints "??" + in case of remaining issues (such as reference not in env). *) + +val safe_pr_lconstr_env : env -> constr -> std_ppcmds +val safe_pr_lconstr : constr -> std_ppcmds + +val safe_pr_constr_env : env -> constr -> std_ppcmds +val safe_pr_constr : constr -> std_ppcmds + + val pr_open_constr_env : env -> open_constr -> std_ppcmds val pr_open_constr : open_constr -> std_ppcmds diff --git a/parsing/printmod.ml b/parsing/printmod.ml index b4a8fdfd..b46cf42d 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -68,12 +68,17 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn +(** Each time we have to print a non-globally visible structure, + we place its elements in a fake fresh namespace. *) + +let mk_fake_top = + let r = ref 0 in + fun () -> incr r; id_of_string ("FAKETOP"^(string_of_int !r)) + let nametab_register_dir mp = - let id = id_of_string "FAKETOP" in - let fp = Libnames.make_path empty_dirpath id in + let id = mk_fake_top () in let dir = make_dirpath [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))); - fp + Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here @@ -81,9 +86,10 @@ let nametab_register_dir mp = the user names. This works nonetheless since we search now [Nametab.the_globrevtab] modulo user name. *) -let nametab_register_body mp fp (l,body) = +let nametab_register_body mp dir (l,body) = let push id ref = - Nametab.push (Nametab.Until 1) (make_path (dirpath fp) id) ref + Nametab.push (Nametab.Until (1+List.length (repr_dirpath dir))) + (make_path dir id) ref in match body with | SFBmodule _ -> () (* TODO *) @@ -99,6 +105,27 @@ let nametab_register_body mp fp (l,body) = mip.mind_consnames) mib.mind_packets +let nametab_register_module_body mp struc = + (* If [mp] is a globally visible module, we simply import it *) + try Declaremods.really_import_module mp + with Not_found -> + (* Otherwise we try to emulate an import by playing with nametab *) + nametab_register_dir mp; + List.iter (nametab_register_body mp empty_dirpath) struc + +let nametab_register_module_param mbid seb = + (* For algebraic seb, we use a Declaremods function that converts into mse *) + try Declaremods.process_module_seb_binding mbid seb + with e when Errors.noncritical e -> + (* Otherwise, for expanded structure, we try to play with the nametab *) + match seb with + | SEBstruct struc -> + let mp = MPbound mbid in + let dir = make_dirpath [id_of_mbid mbid] in + nametab_register_dir mp; + List.iter (nametab_register_body mp dir) struc + | _ -> () + let print_body is_impl env mp (l,body) = let name = str (string_of_label l) in hov 2 (match body with @@ -126,19 +153,11 @@ let print_body is_impl env mp (l,body) = try let env = Option.get env in Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib - with _ -> + with e when Errors.noncritical e -> (if mib.mind_finite then str "Inductive " else str "CoInductive") ++ name) let print_struct is_impl env mp struc = - begin - (* If [mp] is a globally visible module, we simply import it *) - try Declaremods.really_import_module mp - with _ -> - (* Otherwise we try to emulate an import by playing with nametab *) - let fp = nametab_register_dir mp in - List.iter (nametab_register_body mp fp) struc - end; prlist_with_sep spc (print_body is_impl env mp) struc let rec flatten_app mexpr l = match mexpr with @@ -156,7 +175,7 @@ let rec print_modtype env mp locals mty = let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - (try Declaremods.process_module_seb_binding mbid seb1 with _ -> ()); + nametab_register_module_param mbid seb1; hov 2 (str "Funsig" ++ spc () ++ str "(" ++ pr_id (id_of_mbid mbid) ++ str ":" ++ print_modtype env mp1 locals seb1 ++ @@ -164,6 +183,7 @@ let rec print_modtype env mp locals mty = | SEBstruct (sign) -> let env' = Option.map (Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in + nametab_register_module_body mp sign; hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++ brk (1,-2) ++ str "End") | SEBapply _ -> @@ -190,13 +210,14 @@ let rec print_modexpr env mp locals mexpr = match mexpr with (Modops.add_module (Modops.module_body_of_type mp' mty)) env in let typ = Option.default mty.typ_expr mty.typ_expr_alg in let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - (try Declaremods.process_module_seb_binding mbid typ with _ -> ()); + nametab_register_module_param mbid typ; hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ str ":" ++ print_modtype env mp' locals typ ++ str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr) | SEBstruct struc -> let env' = Option.map (Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in + nametab_register_module_body mp struc; hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++ brk (1,-2) ++ str "End") | SEBapply _ -> @@ -243,7 +264,7 @@ let print_module with_body mp = try if !short then raise ShortPrinting; print_module' (Some (Global.env ())) mp with_body me ++ fnl () - with _ -> + with e when Errors.noncritical e -> print_module' None mp with_body me ++ fnl () let print_modtype kn = @@ -254,5 +275,5 @@ let print_modtype kn = (try if !short then raise ShortPrinting; print_modtype' (Some (Global.env ())) kn mtb.typ_expr - with _ -> + with e when Errors.noncritical e -> print_modtype' None kn mtb.typ_expr)) diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index dbc06856..77364180 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -188,11 +188,11 @@ let declare_tactic loc s cl = Tacexpr.TacExtend($default_loc$,$se$,l))) | None -> () ]) $atomic_tactics$ - with e -> + with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in tactic extend " ^ $se$ ^": ")) - (Errors.print e)); + (Errors.print e)) ]; Egrammar.extend_tactic_grammar $se$ $gl$; List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >> ]) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 4f39019f..bcdf7cff 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -55,11 +55,11 @@ let declare_command loc s nt cl = declare_str_items loc [ <:str_item< do { try Vernacinterp.vinterp_add $se$ $funcl$ - with e -> + with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in vernac extend " ^ $se$ ^": ")) - (Errors.print e)); + (Errors.print e)) ]; Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$ } >> ] diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index d0f81dad..1c021eee 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -404,7 +404,8 @@ let rec canonize_name c = let build_subst uf subst = Array.map (fun i -> try term uf i - with _ -> anomaly "incomplete matching") subst + with e when Errors.noncritical e -> + anomaly "incomplete matching") subst let rec inst_pattern subst = function PVar i -> @@ -730,9 +731,7 @@ 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 new_hyps = - Environ.push_named_context_val (id,None,typ) (Goal.V82.hyps sigma gl) in - let gls = Goal.V82.new_goal_with sigma gl new_hyps in + let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in state.gls<- gls; id diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 95ff4d34..764e36b0 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -129,7 +129,9 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) with _ -> raise Not_found in + try destApp (whd_delta env term) + with e when Errors.noncritical e -> raise Not_found + in if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index 730051c1..da88d48d 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -75,9 +75,9 @@ let mode_of_pftreestate pts = Mode_proof let get_current_mode () = - try + try mode_of_pftreestate (Pfedit.get_pftreestate ()) - with _ -> Mode_none + with e when Errors.noncritical e -> Mode_none let check_not_proof_mode str = if get_current_mode () = Mode_proof then diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 72caeaed..ab161b35 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -381,7 +381,7 @@ let find_subsubgoal c ctyp skip submetas gls = se.se_meta submetas se.se_meta_list} else dfs (pred n) - with _ -> + with e when Errors.noncritical e -> begin enstack_subsubgoals env se stack gls; dfs n @@ -519,7 +519,10 @@ let decompose_eq id gls = let instr_rew _thus rew_side cut gls0 = let last_id = - try get_last (pf_env gls0) with _ -> error "No previous equality." in + try get_last (pf_env gls0) + with e when Errors.noncritical e -> + error "No previous equality." + in let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with @@ -849,7 +852,7 @@ let build_per_info etype casee gls = let ind = try destInd hd - with _ -> + with e when Errors.noncritical e -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 6aa47eff..b7ee3c1a 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -397,8 +397,10 @@ let mono_filename f = in let id = if lang () <> Haskell then default_id - else try id_of_string (Filename.basename f) - with _ -> error "Extraction: provided filename is not a valid identifier" + else + try id_of_string (Filename.basename f) + with e when Errors.noncritical e -> + error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id @@ -473,8 +475,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; - with e -> - Option.iter close_out cout; raise e + with reraise -> + Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; (* Now, let's print the signature *) @@ -487,8 +489,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; - with e -> - close_out cout; raise e + with reraise -> + close_out cout; raise reraise end; info_file si) (if dry then None else si); @@ -527,7 +529,9 @@ let rec locate_ref = function | r::l -> let q = snd (qualid_of_reference r) in let mpo = try Some (Nametab.locate_module q) with Not_found -> None - and ro = try Some (Smartlocate.global_with_alias r) with _ -> None + and ro = + try Some (Smartlocate.global_with_alias r) + with e when Errors.noncritical e -> None in match mpo, ro with | None, None -> Nametab.error_global_not_found q diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0a17453c..e5357336 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -149,7 +149,7 @@ let rec handle_exn r n fn_name = function (fun i -> assert ((0 < i) && (i <= n)); MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with _ -> MLexn s) + with e when Errors.noncritical e -> MLexn s) | a -> ast_map (handle_exn r n fn_name) a (*S Management of type variable contexts. *) @@ -683,7 +683,7 @@ and extract_cst_app env mle mlt kn args = let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla - with _ -> mla + with e when Errors.noncritical e -> mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 6c78b533..b6fc5ac8 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -81,7 +81,9 @@ let kn_sig = let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false - | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) + | Tvar i -> + (try pr_id (List.nth vl (pred i)) + with e when Errors.noncritical e -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a38b303f..d0bf387a 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -879,7 +879,7 @@ let is_program_branch = function (try ignore (int_of_string (String.sub s n (String.length s - n))); String.sub s 0 n = br - with _ -> false) + with e when Errors.noncritical e -> false) | Tmp _ | Dummy -> false let expand_linear_let o id e = @@ -1312,7 +1312,7 @@ let inline_test r t = let c = match r with ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) - with _ -> false + with e when Errors.noncritical e -> false in has_body && (let t1 = eta_red t in diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 289b2a1d..4e8d8145 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -119,7 +119,8 @@ let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) - with _ -> (str "'a" ++ int i)) + with e when Errors.noncritical e -> + (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r @@ -188,7 +189,7 @@ let rec pp_expr par env args = let args = list_skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with _ -> apply (pp_global Term r)) + with e when Errors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index e0a6e843..497ddf03 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -255,7 +255,7 @@ let safe_basename_of_global r = let string_of_global r = try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) - with _ -> string_of_id (safe_basename_of_global r) + with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) @@ -263,7 +263,7 @@ let safe_pr_global r = str (string_of_global r) let safe_pr_long_global r = try Printer.pr_global r - with _ -> match r with + with e when Errors.noncritical e -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) @@ -452,7 +452,7 @@ let my_bool_option name initval = (*s Extraction AccessOpaque *) -let access_opaque = my_bool_option "AccessOpaque" false +let access_opaque = my_bool_option "AccessOpaque" true (*s Extraction AutoInline *) diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 9d3d8c99..29d41b81 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -85,7 +85,7 @@ let gen_ground_tac flag taco ids bases gl= extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in let result=ground_tac solver startseq gl in qflag:=backup;result - with e ->qflag:=backup;raise e + with reraise ->qflag:=backup;raise reraise (* special for compatibility with Intuition diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 68f112d6..4b07c609 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -129,7 +129,7 @@ let mk_open_instance id gl m t= | _-> anomaly "can't happen" in let ntt=try Pretyping.Default.understand evmap env (raux m rawt) - with _ -> + with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index 043c9e51..1574e21e 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -175,7 +175,7 @@ let unsolvable lie = raise (Failure "contradiction found")) |_->assert false) lr) - with _ -> ()); + with e when Errors.noncritical e -> ()); !res ;; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index cdd10d70..e0e4f7d6 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -40,7 +40,7 @@ type flin = {fhom: rational Constrhash.t; let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};; -let flin_coef f x = try (Constrhash.find f.fhom x) with _-> r0;; +let flin_coef f x = try (Constrhash.find f.fhom x) with Not_found -> r0;; let flin_add f x c = let cx = flin_coef f x in @@ -141,10 +141,12 @@ let rec flin_of_constr c = (try (let a=(rational_of_constr args.(0)) in try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(1) a)) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rational_of_constr args.(1)))) | "Rinv"-> @@ -154,7 +156,8 @@ let rec flin_of_constr c = (let b=(rational_of_constr args.(1)) in try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rinv b))) |_->assert false) @@ -164,7 +167,8 @@ let rec flin_of_constr c = |"R0" -> flin_zero () |_-> assert false) |_-> assert false) - with _ -> flin_add (flin_zero()) + with e when Errors.noncritical e -> + flin_add (flin_zero()) c r1 ;; @@ -494,13 +498,13 @@ let rec fourier gl= |_->assert false) |_->assert false in tac gl) - with _ -> + with e when Errors.noncritical e -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with _ -> ()) + with e when Errors.noncritical e -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) if !lineq=[] then Util.error "No inequalities"; diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 33d77568..48205019 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -33,9 +33,12 @@ let observennl strm = let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with e -> - let e = Cerrors.process_vernac_interp_error e in - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + with reraise -> + let e = Cerrors.process_vernac_interp_error reraise in + let goal = + try (Printer.pr_goal g) + with e when Errors.noncritical e -> assert false + in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; @@ -119,7 +122,7 @@ let is_trivial_eq t = eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end - with _ -> false + with e when Errors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res @@ -145,7 +148,7 @@ let is_incompatible_eq t = (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false - with _ -> false + with e when Errors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res @@ -232,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" - with _ -> nochange "not an equality" + with e when Errors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = @@ -608,7 +611,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let my_orelse tac1 tac2 g = try tac1 g - with e -> + with e when Errors.noncritical e -> (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g @@ -1212,7 +1215,11 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try - let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let pte = + try destVar pte + with e when Errors.noncritical e -> + anomaly "Property is not a variable" + in let fix_info = Idmap.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 00e966fb..04fcc8d4 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -302,11 +302,8 @@ let defined () = "defined" ((try str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () - with _ -> mt () + with e when Errors.noncritical e -> mt () ) ++msg) - | e -> raise e - - let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) @@ -401,7 +398,7 @@ let generate_functional_principle Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook - with e -> + with e when Errors.noncritical e -> begin begin try @@ -413,7 +410,7 @@ let generate_functional_principle then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end @@ -554,7 +551,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) - with e -> + with e when Errors.noncritical e -> begin begin try @@ -566,7 +563,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 85d79214..6b6e4838 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -208,14 +208,14 @@ VERNAC COMMAND EXTEND NewFunctionalScheme try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 43b08840..b9e0e62a 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -948,7 +948,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue + try Pretyping.Default.understand Evd.empty env t + with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = @@ -1247,7 +1248,7 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b l := param::!l ) rels_params.(0) - with _ -> + with e when Errors.noncritical e -> () in List.rev !l @@ -1453,7 +1454,7 @@ let do_build_inductive in observe (msg); raise e - | e -> + | reraise -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = @@ -1464,16 +1465,16 @@ let do_build_inductive str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ - Errors.print e + Errors.print reraise in observe msg; - raise e + raise reraise let build_inductive funnames funsargs returned_types rtl = try do_build_inductive funnames funsargs returned_types rtl - with e -> raise (Building_graph e) + with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index cdd0eaf7..6cc932b1 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -534,7 +534,8 @@ let rec are_unifiable_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" + with e when Errors.noncritical e -> + anomaly "are_unifiable_aux" in are_unifiable_aux eqs' @@ -556,7 +557,8 @@ let rec eq_cases_pattern_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" + with e when Errors.noncritical e -> + anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 8caeca57..d2c065a0 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -82,7 +82,7 @@ let functional_induction with_clean c princl pat = List.fold_right (fun a acc -> try Idset.add (destVar a) acc - with _ -> acc + with e when Errors.noncritical e -> acc ) args Idset.empty @@ -166,8 +166,8 @@ let build_newrecursive sigma rec_sign rec_impls def ) lnameargsardef - with e -> - States.unfreeze fs; raise e in + with reraise -> + States.unfreeze fs; raise reraise in States.unfreeze fs; def in recdef,rec_impls @@ -251,12 +251,12 @@ let derive_inversion fix_names = (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) fix_names ) - with e -> + with e when Errors.noncritical e -> let e' = Cerrors.process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) - with _ -> () + with e when Errors.noncritical e -> () let warning_error names e = let e = Cerrors.process_vernac_interp_error e in @@ -346,7 +346,7 @@ let generate_principle on_error Array.iter (add_Function is_general) funs_kn; () end - with e -> + with e when Errors.noncritical e -> on_error names e let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = @@ -413,7 +413,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e -> + with e when Errors.noncritical e -> (* No proof done *) () in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index dd475315..827191b1 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -55,7 +55,6 @@ let locate_with_msg msg f x = f x with | Not_found -> raise (Util.UserError("", msg)) - | e -> raise e let filter_map filter f = @@ -123,7 +122,7 @@ let def_of_const t = (try (match Declarations.body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) - with _ -> assert false) + with e when Errors.noncritical e -> assert false) |_ -> assert false let coq_constant s = @@ -215,13 +214,13 @@ let with_full_print f a = Dumpglob.continue (); res with - | e -> + | reraise -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Dumpglob.continue (); - raise e + raise reraise @@ -350,7 +349,8 @@ open Term let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ - (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ + (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) + with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ @@ -502,22 +502,22 @@ exception ToShow of exn let init_constant dir s = try Coqlib.gen_constant "Function" dir s - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq () = try (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_rec () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 55451a9f..7b5dd763 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -59,14 +59,17 @@ let observennl strm = let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + let goal = + try Printer.pr_goal g + with e when Errors.noncritical e -> assert false + in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with e -> - let e' = Cerrors.process_vernac_interp_error e in + with reraise -> + let e' = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e' ++ str " on goal " ++ goal ); - raise e;; + raise reraise;; let observe_tac s tac g = @@ -568,7 +571,7 @@ let rec reflexivity_with_destruct_cases g = observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity - with _ -> reflexivity + with e when Errors.noncritical e -> reflexivity in let eq_ind = Coqlib.build_coq_eq () in let discr_inject = @@ -862,11 +865,11 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g update_Function {finfo with completeness_lemma = Some lem_cst} ) funs; - with e -> + with reraise -> (* In case of problem, we reset all the lemmas *) Pfedit.delete_all_proofs (); States.unfreeze previous_state; - raise e + raise reraise diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 6ee2f352..bd1a1710 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -70,7 +70,7 @@ let ident_global_exist id = let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true - with _ -> false + with e when Errors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) @@ -793,10 +793,10 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with _ -> [] in + with e when Errors.noncritical e -> [] in let params2 = try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with _ -> [] in + with e when Errors.noncritical e -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 892c1a77..9853fd73 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -94,11 +94,11 @@ let do_observe_tac s tac g = let v = tac g in ignore(Stack.pop debug_queue); v - with e -> + with reraise -> if not (Stack.is_empty debug_queue) then - print_debug_queue true e; - raise e + print_debug_queue true reraise; + raise reraise let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff @@ -140,7 +140,7 @@ let def_of_const t = (try (match body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) - with _ -> + with e when Errors.noncritical e -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) @@ -380,7 +380,11 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + let _,args = + try destApp ty_teq + with e when Errors.noncritical e -> + Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false + in args.(1),args.(2) in cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1 @@ -701,12 +705,17 @@ let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier) (match find_call_occs nb_arg 0 f_constr expr with _,[] -> (try observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> (msgerrnl (str "failure in base case");raise e )) + with reraise -> + (msgerrnl (str "failure in base case");raise reraise )) | _, _::_ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr)) in v - with e -> begin msgerrnl(str "failure in proveterminate"); raise e end + with reraise -> + begin + msgerrnl(str "failure in proveterminate"); + raise reraise + end in proveterminate @@ -931,7 +940,7 @@ let is_rec_res id = let id_name = string_of_id id in try String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with _ -> false + with e when Errors.noncritical e -> false let clear_goals = let rec clear_goal t = @@ -969,7 +978,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ | Some s -> s | None -> try (add_suffix current_proof_name "_subproof") - with _ -> anomaly "open_new_goal with an unamed theorem" + with e when Errors.noncritical e -> + anomaly "open_new_goal with an unamed theorem" in let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in @@ -1439,7 +1449,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let stop = ref false in begin try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) - with e -> + with e when Errors.noncritical e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) @@ -1474,9 +1484,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num using_lemmas (List.length res_vars) hook - with e -> + with reraise -> begin - (try ignore (Backtrack.backto previous_label) with _ -> ()); + (try ignore (Backtrack.backto previous_label) + with e when Errors.noncritical e -> ()); (* anomaly "Cannot create termination Lemma" *) - raise e + raise reraise end diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 25579a87..a5b0da9c 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -331,7 +331,7 @@ let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = | Inr _ -> None | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) - with x -> + with x when Errors.noncritical x -> if debug then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; @@ -377,8 +377,9 @@ let linear_prover n_spec l = let linear_prover n_spec l = - try linear_prover n_spec l with - x -> (print_string (Printexc.to_string x); None) + try linear_prover n_spec l + with x when x <> Sys.Break -> + (print_string (Printexc.to_string x); None) let linear_prover_with_cert spec l = match linear_prover spec l with diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 2020447f..ff08aeb3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -937,7 +937,8 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with _ -> (* if the exponent is a variable *) + with e when e <> Sys.Break -> + (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end | Ukn s -> @@ -1112,8 +1113,12 @@ struct let parse_formula parse_atom env tg term = - let parse_atom env tg t = try let (at,env) = parse_atom env t in - (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in + let parse_atom env tg t = + try + let (at,env) = parse_atom env t in + (A(at,tg,t), env,Tag.next tg) + with e when e <> Sys.Break -> (X(t),env,tg) + in let rec xparse_formula env tg term = match kind_of_term term with @@ -1189,7 +1194,8 @@ let same_proof sg cl1 cl2 = let rec xsame_proof sg = match sg with | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + | n::sg -> + (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false) && (xsame_proof sg ) in xsame_proof sg @@ -1253,7 +1259,7 @@ let btree_of_array typ a = let btree_of_array typ a = try btree_of_array typ a - with x -> + with x when x <> Sys.Break -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = @@ -1322,7 +1328,7 @@ let rec parse_hyps parse_arith env tg hyps = try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) - with _ -> (lhyps,env,tg) + with e when e <> Sys.Break -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) @@ -1466,7 +1472,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x -> + let res = try prover.compact prf remap with x when x <> Sys.Break -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (List.map fst new_cl) with @@ -2031,13 +2037,13 @@ let xlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ linear_Z ] gl - with z -> (*Printexc.print_backtrace stdout ;*) raise z + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise let xnlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ nlinear_Z ] gl - with z -> (*Printexc.print_backtrace stdout ;*) raise z + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index dfda5984..0f26575c 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -150,7 +150,7 @@ let real_nonlinear_prover d l = S (Some proof) with | Sos_lib.TooDeep -> S None - | x -> F (Printexc.to_string x) + | x when x <> Sys.Break -> F (Printexc.to_string x) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = @@ -174,7 +174,7 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x -> (* May be that could be refined *) S None + | x when x <> Sys.Break -> (* May be that could be refined *) S None @@ -203,7 +203,7 @@ let main () = Marshal.to_channel chan (cert:csdp_certificate) [] ; flush chan ; exit 0 - with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) + with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) ;; diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index d9201722..6effa4c4 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -728,7 +728,8 @@ struct try Some (bound_of_variable IMap.empty fresh s.sys) with - x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None + x when x <> Sys.Break -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None let find_point cstrs = diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index ccbf0406..3129e54d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -29,10 +29,10 @@ let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let map_option f x = match x with @@ -431,14 +431,16 @@ let command exe_path args vl = | Unix.WEXITED 0 -> let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch - with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) + with x when x <> Sys.Break -> + failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) (* Cleanup *) (fun () -> - List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) + List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ()) + [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index cb7a9280..6d1a2927 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -82,10 +82,10 @@ let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let read_key_elem inch = @@ -93,7 +93,7 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | _ -> raise InvalidTableFormat + | e when e <> Sys.Break -> raise InvalidTableFormat (** In win32, it seems that we should unlock the exact zone that has been locked, and not the whole file *) @@ -151,7 +151,7 @@ let open_in f = Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; flush outch ; - with _ -> () ) + with e when e <> Sys.Break -> () ) ; unlock out ; { outch = outch ; diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 996dbadd..68fb2626 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -237,7 +237,8 @@ open Format let getvar lv i = try (nth lv i) - with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv) + with e when Errors.noncritical e -> + (fold_left (fun r x -> r^" "^x) "lv= " lv) ^" i="^(string_of_int i) let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef @@ -590,7 +591,7 @@ let coefpoldep = Hashtbl.create 51 (* coef of q in p = sum_i c_i*q_i *) let coefpoldep_find p q = try (Hashtbl.find coefpoldep (p.num,q.num)) - with _ -> [] + with Not_found -> [] let coefpoldep_remove p q = Hashtbl.remove coefpoldep (p.num,q.num) diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 0eea961d..fdc8e865 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -173,7 +173,7 @@ let rec equal p q = then failwith "raté") p1; true) - with _ -> false) + with e when Errors.noncritical e -> false) | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized @@ -524,7 +524,7 @@ let div_pol_rat p q= q x in (* degueulasse, mais c 'est pour enlever un warning *) if s==s then true else true) - with _ -> false + with e when Errors.noncritical e -> false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index c16bd425..17c8654b 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -33,10 +33,11 @@ let set_of_list_eq eq l = let memos s memoire nf f x = try (let v = Hashtbl.find memoire (nf x) in pr s;v) - with _ -> (pr "#"; - let v = f x in - Hashtbl.add memoire (nf x) v; - v) + with e when Errors.noncritical e -> + (pr "#"; + let v = f x in + Hashtbl.add memoire (nf x) v; + v) (********************************************************************** @@ -64,7 +65,7 @@ let facteurs_liste div constant lp = if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) - with _ -> ()) + with e when Errors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 @@ -75,7 +76,8 @@ let facteurs_liste div constant lp = List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) - with _ -> lmin1:=q::(!lmin1)) + with e when Errors.noncritical e -> + lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) (* au moins un q de lmin divise p non trivialement *) @@ -105,7 +107,7 @@ let factorise_tableau div zero c f l1 = li:=j::(!li); r:=rr; done) - with _ -> ()) + with e when Errors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 028ef95d..ffa99fc7 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -885,7 +885,7 @@ let rec transform p t = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> + with e when Errors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -924,7 +924,8 @@ let rec transform p t = | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) with _ -> default false t) + (try ([],Oz(recognize_number t)) + with e when Errors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index f0ca3bb9..216a719d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -221,7 +221,10 @@ let compute_rhs bodyi index_of_f = (*s Now the function [compute_ivs] itself *) let compute_ivs gl f cs = - let cst = try destConst f with _ -> i_can't_do_that () in + let cst = + try destConst f + with e when Errors.noncritical e -> i_can't_do_that () + in let body = Environ.constant_value (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index ae73069d..7b0d96bb 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -292,7 +292,8 @@ let unbox = function (* Protects the convertibility test against undue exceptions when using it with untyped terms *) -let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false +let safe_pf_conv_x gl c1 c2 = + try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false (* Add a Ring or a Semi-Ring to the database after a type verification *) diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index e810e15c..fb45e816 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -335,7 +335,7 @@ let parse_term t = | Kapp("Z.succ",[t]) -> Tsucc t | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with _ -> Tother) + (try Tnum (recognize t) with e when Errors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother @@ -357,6 +357,6 @@ let is_scalar t = | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in - try aux t with _ -> false + try aux t with e when Errors.noncritical e -> false end diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 4a6d462e..e57230cb 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -225,7 +225,8 @@ let add_reified_atom t env = env.terms <- env.terms @ [t]; i let get_reified_atom env = - try List.nth env.terms with _ -> failwith "get_reified_atom" + try List.nth env.terms + with e when Errors.noncritical e -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) @@ -235,7 +236,9 @@ let add_prop env t = let i = List.length env.props in env.props <- env.props @ [t]; i (* accès a une proposition *) -let get_prop v env = try List.nth v env with _ -> failwith "get_prop" +let get_prop v env = + try List.nth v env + with e when Errors.noncritical e -> failwith "get_prop" (* \subsection{Gestion du nommage des équations} *) (* Ajout d'une equation dans l'environnement de reification *) @@ -247,7 +250,8 @@ let add_equation env e = (* accès a une equation *) let get_equation env id = try Hashtbl.find env.equations id - with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e + with Not_found as e -> + Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) let rec oprint ch = function @@ -349,7 +353,8 @@ let rec reified_of_formula env = function app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = - begin try reified_of_formula env f with e -> oprint stderr f; raise e end + try reified_of_formula env f + with reraise -> oprint stderr f; raise reraise let rec reified_of_proposition env = function Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> @@ -380,8 +385,8 @@ let rec reified_of_proposition env = function | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - begin try reified_of_proposition env f - with e -> pprint stderr f; raise e end + try reified_of_proposition env f + with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) @@ -397,11 +402,11 @@ let reified_of_omega env body constant = List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = - begin try + try reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e - end + with reraise -> + display_eq display_omega_var (body,c); raise reraise + (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie @@ -1000,10 +1005,11 @@ let rec solve_with_constraints all_solutions path = let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = try select_smaller weighted - with e -> + with reraise -> Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise e in + List.iter display_depend path; raise reraise + in build_tree winner_sol (List.rev path) winner_deps let find_path {o_hyp=id;o_path=p} env = diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index 956ccf09..6e7a8d32 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -90,7 +90,8 @@ VERNAC COMMAND EXTEND Subtac let try_catch_exn f e = try f e - with exn -> errorlabstrm "Program" (Errors.print exn) + with exn when Errors.noncritical exn -> + errorlabstrm "Program" (Errors.print exn) let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 281e981b..ad248bfb 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -221,6 +221,6 @@ let subtac (loc, command) = | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | Loc.Exc_located (loc, e') as e) -> raise e - | e -> + | reraise -> (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) - raise e + raise reraise diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 221b57ee..0b1ed9bb 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -342,7 +342,7 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = let pred = predicate 0 c in let env' = push_rel_context (context_of_arsign arsign) env in ignore(Typing.sort_of env' evm pred); pred - with _ -> lift nar c + with e when Errors.noncritical e -> lift nar c module Cases_F(Coercion : Coercion.S) : S = struct @@ -1465,7 +1465,8 @@ let extract_arity_signatures env0 tomatchl tmsign = | None -> list_tabulate (fun _ -> Anonymous) nrealargs in let arsign = fst (get_arity env0 indf) in (na,None,build_dependent_inductive env0 indf) - ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in + ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign + with e when Errors.noncritical e -> assert false) in let rec buildrec = function | [],[] -> [] | (_,tm)::ltm, x::tmsign -> diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index 168a799d..0c03fb4c 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -356,7 +356,7 @@ module Coercion = struct jres), jres.uj_type) (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" + with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env isevars j = let isevars = ref isevars in @@ -506,5 +506,5 @@ module Coercion = struct with NoSubtacCoercion -> error_cannot_coerce env' isevars (t, t')) else isevars - with _ -> isevars + with e when Errors.noncritical e -> isevars end diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index 14a09032..537a8301 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -248,7 +248,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t | _, _ -> error () - with _ -> error () + with e when Errors.noncritical e -> error () in let measure = interp_casted_constr isevars binders_env measure relargty in let wf_rel, wf_rel_fun, measure_fn = @@ -440,7 +440,7 @@ let interp_recursive fixkind l = let sort = Retyping.get_type_of env !evdref t in let fixprot = try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|]) - with e -> t + with e when Errors.noncritical e -> t in (id,None,fixprot) :: env') [] fixnames fixtypes diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index dfcc8526..d8f46098 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -121,7 +121,7 @@ let obl_substitution expand obls deps = let xobl = obls.(x) in let oblb = try get_obligation_body expand xobl - with _ -> assert(false) + with e when Errors.noncritical e -> assert(false) in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) deps [] @@ -498,7 +498,8 @@ let rec solve_obligation prg num tac = let obls = Array.copy obls in let _ = obls.(num) <- obl in let res = try update_obls prg obls (pred rem) - with e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) + with e when Errors.noncritical e -> + pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in match res with | Remain n when n > 0 -> @@ -552,7 +553,7 @@ and solve_obligation_by_tac prg obls i tac = | Refiner.FailError (_, s) -> user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) | Util.Anomaly _ as e -> raise e - | e -> false + | e when Errors.noncritical e -> false and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index 95e756ab..f0579711 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -302,7 +302,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Loc.raise loc e); + (try check_cofix env cofix + with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon @@ -601,7 +602,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct ~split:true ~fail:true env !evdref; evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env !evdref - with e -> if fail_evar then raise e else ()); + with e when Errors.noncritical e -> + if fail_evar then raise e else ()); evdref := consider_remaining_unif_problems env !evdref; let c = if expand_evar then nf_evar !evdref c' else c' in if fail_evar then check_evars env Evd.empty !evdref c; diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index fbb44811..e32bb9e0 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -232,7 +232,7 @@ let build_dependent_sum l = let hyptype = substl names t in trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) - with _ -> ()); + with e when Errors.noncritical e -> ()); let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> @@ -331,7 +331,7 @@ let destruct_ex ext ex = Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 -> let (dom, rng) = try (args.(0), args.(1)) - with _ -> assert(false) + with e when Errors.noncritical e -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in let rng_body = @@ -375,9 +375,9 @@ let solve_by_tac evi t = Inductiveops.control_only_guard (Global.env ()) const.Entries.const_entry_body; const.Entries.const_entry_body - with e -> + with reraise -> Pfedit.delete_current_proof(); - raise e + raise reraise (* let apply_tac t goal = t goal *) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index da0a65ff..a14eda60 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -349,7 +349,7 @@ let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids if computeinnertypes then try Acic.CicHash.find terms_to_types tt -with _ -> +with e when e <> Sys.Break -> (*CSC: Warning: it really happens, for example in Ring_theory!!! *) Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false else diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index a21a919a..c22c16f0 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -147,7 +147,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: universes. *) (try Typeops.judge_of_type u - with _ -> (* Successor of a non universe-variable universe anomaly *) + with e when e <> Sys.Break -> + (* Successor of a non universe-variable universe anomaly *) (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; Typeops.judge_of_type (Termops.new_univ ()) ) diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 1037bbf0..867aac71 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -143,7 +143,7 @@ let rec join_dirs cwd = | he::tail -> (try Unix.mkdir cwd 0o775 - with _ -> () (* Let's ignore the errors on mkdir *) + with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *) ) ; let newcwd = cwd ^ "/" ^ he in join_dirs newcwd tail diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index bdf94e0d..86f96c7c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -126,7 +126,7 @@ module Default = struct jres), jres.uj_type) (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" + with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env evd j = let t = whd_betadeltaiota env evd j.uj_type in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a74e4cb4..0166b64c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -272,7 +272,7 @@ let is_nondep_branch c n = try let sign,ccl = decompose_lam_n_assum n c in noccur_between 1 (rel_context_length sign) ccl - with _ -> (* Not eta-expanded or not reduced *) + with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false let extract_nondep_branches test c b n = @@ -386,7 +386,7 @@ let rec detype (isgoal:bool) avoid env t = | Var id -> (try let _ = Global.lookup_named id in GRef (dl, VarRef id) - with _ -> + with e when Errors.noncritical e -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -492,7 +492,7 @@ and detype_eqns isgoal avoid env ci computable constructs consnargsl bl = let mat = build_tree Anonymous isgoal (avoid,env) ci bl in List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c)) mat - with _ -> + with e when Errors.noncritical e -> Array.to_list (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 14f35941..0eed1949 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -454,7 +454,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) else Evd.set_leq_sort evd s1 s2 in (evd', true) with Univ.UniverseInconsistency _ -> (evd, false) - | _ -> (evd, false)) + | e when Errors.noncritical e -> (evd, false)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> ise_and evd @@ -730,12 +730,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let (term2,l2 as appr2) = decompose_app t2 in match kind_of_term term1, kind_of_term term2 with | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] - & array_for_all (fun a -> eq_constr a term2 or isEvar a) args1 -> + & List.for_all (fun a -> eq_constr a term2 or isEvar a) + (remove_instance_local_defs evd evk1 (Array.to_list args1)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk1 evd term2 args1 | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] - & array_for_all (fun a -> eq_constr a term1 or isEvar a) args2 -> + & List.for_all (fun a -> eq_constr a term1 or isEvar a) + (remove_instance_local_defs evd evk2 (Array.to_list args2)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk2 evd term1 args2 diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index b0248a84..fc29ba6c 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -1194,10 +1194,9 @@ let filter_candidates evd evk filter candidates = let closure_of_filter evd evk filter = let evi = Evd.find_undefined evd evk in - let vars = collect_vars (evar_concl evi) in - let ids = List.map pi1 (evar_context evi) in - let test id b = b || Idset.mem id vars in - let newfilter = List.map2 test ids filter in + let vars = collect_vars (nf_evar evd (evar_concl evi)) in + let test (id,c,_) b = b || Idset.mem id vars || c <> None in + let newfilter = List.map2 test (evar_context evi) filter in if newfilter = evar_filter evi then None else Some newfilter let restrict_hyps evd evk filter candidates = @@ -1352,9 +1351,14 @@ let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with | Construct (ind,_) -> - let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in - let params,_ = array_chop nparams args in - array_for_all (is_constrainable_in k g) params + let nparams = + (fst (Global.lookup_inductive ind)).Declarations.mind_nparams + in + if nparams > Array.length args + then true (* We don't try to be more clever *) + else + let params,_ = array_chop nparams args in + array_for_all (is_constrainable_in k g) params | Ind _ -> array_for_all (is_constrainable_in k g) args | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2 | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*) @@ -1442,7 +1446,7 @@ let check_evar_instance evd evk1 body conv_algo = (* FIXME: The body might be ill-typed when this is called from w_merge *) let ty = try Retyping.get_type_of evenv evd body - with _ -> error "Ill-typed evar instance" + with e when Errors.noncritical e -> error "Ill-typed evar instance" in let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in if b then evd else @@ -1492,7 +1496,10 @@ let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = (filter_compatible_candidates conv_algo env evd evi args rhs) l in match l' with | [] -> error_cannot_unify env evd (mkEvar ev, rhs) - | [c,evd] -> Evd.define evk c evd + | [c,evd] -> + (* solve_candidates might have been called recursively in the mean *) + (* time and the evar been solved by the filtering process *) + if Evd.is_undefined evd evk then Evd.define evk c evd else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (Some candidates) @@ -1643,7 +1650,7 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in t::l - with _ -> l in + with e when Errors.noncritical e -> l in (match candidates with | [x] -> x | _ -> diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 2b326fd1..591a008c 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -230,3 +230,4 @@ val generalize_evar_over_rels : evar_map -> existential -> types * constr list val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun -> evar_map +val remove_instance_local_defs : evar_map -> existential_key -> constr list -> constr list diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 6d5c98ce..4d9eb897 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -67,9 +67,12 @@ let evar_hyps evi = evi.evar_hyps let evar_context evi = named_context_of_val evi.evar_hyps let evar_body evi = evi.evar_body let evar_filter evi = evi.evar_filter -let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps let evar_filtered_context evi = snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi)) +let evar_filtered_hyps evi = + List.fold_right push_named_context_val (evar_filtered_context evi) + empty_named_context_val +let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps let evar_env evi = List.fold_right push_named (evar_filtered_context evi) (reset_context (Global.env())) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 4813d3b9..dbaf803b 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -127,6 +127,7 @@ val evar_concl : evar_info -> constr val evar_context : evar_info -> named_context val evar_filtered_context : evar_info -> named_context val evar_hyps : evar_info -> named_context_val +val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_filter : evar_info -> bool list val evar_unfiltered_env : evar_info -> env diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bb0a0e92..bdccc57b 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -290,6 +290,7 @@ let find_rectype env sigma c = match kind_of_term t with | Ind ind -> let (mib,mip) = Inductive.lookup_mind_specif env ind in + if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = list_chop mib.mind_nparams l in IndType((ind, par),rargs) | _ -> raise Not_found diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d8678371..1dd71fab 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -69,8 +69,9 @@ let search_guard loc env possible_indexes fixdefs = if List.for_all (fun l->1=List.length l) possible_indexes then let indexes = Array.of_list (List.map List.hd possible_indexes) in let fix = ((indexes, 0),fixdefs) in - (try check_fix env fix with - | e -> if loc = dummy_loc then raise e else Loc.raise loc e); + (try check_fix env fix + with e when Errors.noncritical e -> + if loc = dummy_loc then raise e else Loc.raise loc e); indexes else (* we now search recursively amoungst all combinations *) @@ -109,7 +110,8 @@ let resolve_evars env evdref fail_evar resolve_classes = (* Resolve eagerly, potentially making wrong choices *) evdref := (try consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env !evdref - with e -> if fail_evar then raise e else !evdref) + with e when Errors.noncritical e -> + if fail_evar then raise e else !evdref) let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) = let evdref = ref evd in @@ -441,7 +443,8 @@ module Pretyping_F (Coercion : Coercion.S) = struct make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Loc.raise loc e); + (try check_cofix env cofix + with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 0f04549f..434fe80c 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -207,16 +207,16 @@ let cs_pattern_of_constr t = match kind_of_term t with App (f,vargs) -> begin - try Const_cs (global_of_constr f) , -1, Array.to_list vargs with - _ -> raise Not_found + try Const_cs (global_of_constr f) , -1, Array.to_list vargs + with e when Errors.noncritical e -> raise Not_found end | Rel n -> Default_cs, pred n, [] | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, -1, [a; Termops.pop b] | Sort s -> Sort_cs (family_of_sort s), -1, [] | _ -> begin - try Const_cs (global_of_constr t) , -1, [] with - _ -> raise Not_found + try Const_cs (global_of_constr t) , -1, [] + with e when Errors.noncritical e -> raise Not_found end (* Intended to always succeed *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index fddc7fc7..993ad46b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -924,7 +924,10 @@ let meta_reducible_instance evd b = let u = whd_betaiota Evd.empty u in match kind_of_term u with | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) -> - let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + let m = + try destMeta c + with e when Errors.noncritical e -> destMeta (pi1 (destCast c)) + in (match try let g,s = List.assoc m metas in @@ -934,7 +937,10 @@ let meta_reducible_instance evd b = | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) -> - let m = try destMeta f with _ -> destMeta (pi1 (destCast f)) in + let m = + try destMeta f + with e when Errors.noncritical e -> destMeta (pi1 (destCast f)) + in (match try let g,s = List.assoc m metas in diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index f16eed6c..3b679fce 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -30,12 +30,12 @@ let rec subst_type env sigma typ = function (* et sinon on substitue *) let sort_of_atomic_type env sigma ft args = - let rec concl_of_arity env ar = - match kind_of_term (whd_betadeltaiota env sigma ar) with - | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b - | Sort s -> s - | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args)) - in concl_of_arity env ft + let rec concl_of_arity env ar args = + match kind_of_term (whd_betadeltaiota env sigma ar), args with + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l + | Sort s, [] -> s + | _ -> anomaly "Not a sort" + in concl_of_arity env ft (Array.to_list args) let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index b43b9adb..78b239c0 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -125,12 +125,12 @@ type constant_evaluation = (* We use a cache registered as a global table *) -let eval_table = ref Cmap.empty +let eval_table = ref Cmap_env.empty -type frozen = (int * constant_evaluation) Cmap.t +type frozen = (int * constant_evaluation) Cmap_env.t let init () = - eval_table := Cmap.empty + eval_table := Cmap_env.empty let freeze () = !eval_table @@ -291,10 +291,10 @@ let compute_consteval sigma env ref = let reference_eval sigma env = function | EvalConst cst as ref -> (try - Cmap.find cst !eval_table + Cmap_env.find cst !eval_table with Not_found -> begin let v = compute_consteval sigma env ref in - eval_table := Cmap.add cst v !eval_table; + eval_table := Cmap_env.add cst v !eval_table; v end) | ref -> compute_consteval sigma env ref diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b78850d3..0344ebcc 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -118,7 +118,7 @@ let _ = let class_info c = try Gmap.find c !classes - with _ -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (constr_of_global c) let global_class_of_constr env c = try class_info (global_of_constr c) @@ -132,7 +132,9 @@ let dest_class_arity env c = let rels, c = Term.decompose_prod_assum c in rels, dest_class_app env c -let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with _ -> None +let class_of_constr c = + try Some (dest_class_arity (Global.env ()) c) + with e when Errors.noncritical e -> None let rec is_class_type evd c = match kind_of_term c with @@ -215,7 +217,7 @@ let rebuild_class cl = try let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in set_typeclass_transparency cst false false; cl - with _ -> cl + with e when Errors.noncritical e -> cl let class_input : typeclass -> obj = declare_object @@ -238,7 +240,7 @@ let check_instance env sigma c = let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in Evd.is_empty (Evd.undefined_evars evd) - with _ -> false + with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = let rec aux pri c = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 63cdb378..df5eff6a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -430,8 +430,9 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) - with _ -> error_cannot_unify curenv sigma (m,n)) - + with e when Errors.noncritical e -> + error_cannot_unify curenv sigma (m,n)) + | Lambda (na,t1,c1), Lambda (_,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV true wt (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2 @@ -708,10 +709,12 @@ let merge_instances env sigma flags st1 st2 c1 c2 = else (right, st2, res) | (IsSuperType,IsSubType) -> (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1) - with _ -> (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) + with e when Errors.noncritical e -> + (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) | (IsSubType,IsSuperType) -> (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2) - with _ -> (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) + with e when Errors.noncritical e -> + (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) (* Unification * @@ -913,7 +916,7 @@ let w_merge env with_types flags (evd,metas,evars) = let rec process_eqns failures = function | (mv,status,c)::eqns -> (match (try Inl (unify_type env evd flags mv status c) - with e -> Inr e) + with e when Errors.noncritical e -> Inr e) with | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns | Inl (evd,metas,evars) -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 00efa981..3966146d 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -44,7 +44,7 @@ let invert_tag cst tag reloc_tbl = let find_rectype_a env c = let (t, l) = let t = whd_betadeltaiota env c in - try destApp t with _ -> (t,[||]) in + try destApp t with e when Errors.noncritical e -> (t,[||]) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found @@ -176,7 +176,10 @@ and nf_stk env c t stk = nf_stk env (mkApp(c,args)) t stk | Zfix (f,vargs) :: stk -> let fa, typ = nf_fix_app env f vargs in - let _,_,codom = try decompose_prod env typ with _ -> exit 120 in + let _,_,codom = + try decompose_prod env typ + with e when Errors.noncritical e -> exit 120 + in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> let (mind,_ as ind),allargs = find_rectype_a env t in @@ -206,7 +209,10 @@ and nf_predicate env ind mip params v pT = | Vfun f, Prod _ -> let k = nb_rel env in let vb = body_of_vfun k f in - let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in + let name,dom,codom = + try decompose_prod env pT + with e when Errors.noncritical e -> exit 121 + in let dep,body = nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in dep, mkLambda(name,dom,body) @@ -228,7 +234,10 @@ and nf_args env vargs t = let args = Array.init len (fun i -> - let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in + let _,dom,codom = + try decompose_prod env !t + with e when Errors.noncritical e -> exit 123 + in let c = nf_val env (arg vargs i) dom in t := subst1 c codom; c) in !t,args @@ -239,7 +248,10 @@ and nf_bargs env b t = let args = Array.init len (fun i -> - let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in + let _,dom,codom = + try decompose_prod env !t + with e when Errors.noncritical e -> exit 124 + in let c = nf_val env (bfield b i) dom in t := subst1 c codom; c) in args @@ -249,7 +261,7 @@ and nf_fun env f typ = let vb = body_of_vfun k f in let name,dom,codom = try decompose_prod env typ - with _ -> + with e when Errors.noncritical e -> raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ)) in let body = nf_val (push_rel (name,None,dom) env) vb codom in diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 4462062c..f271a6bd 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -42,7 +42,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = let sigma',typed_c = try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var (Pretyping.OfType (Some evi.evar_concl)) rawc - with _ -> + with e when Errors.noncritical e -> let loc = Glob_term.loc_of_glob_constr rawc in user_err_loc (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ diff --git a/proofs/goal.ml b/proofs/goal.ml index dc1ac5dd..37ebce67 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -276,7 +276,7 @@ let check_typability env sigma c = let recheck_typability (what,id) env sigma t = try check_typability env sigma t - with _ -> + with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(Names.string_of_id id) in @@ -474,7 +474,7 @@ module V82 = struct (* Old style hyps primitive *) let hyps evars gl = let evi = content evars gl in - evi.Evd.evar_hyps + Evd.evar_filtered_hyps evi (* Access to ".evar_concl" *) let concl evars gl = @@ -554,10 +554,16 @@ module V82 = struct with a good implementation of them. *) - (* Used for congruence closure *) - let new_goal_with sigma gl new_hyps = + (* Used for congruence closure and change *) + let new_goal_with sigma gl extra_hyps = let evi = content sigma gl in - let new_evi = { evi with Evd.evar_hyps = new_hyps } in + let hyps = evi.Evd.evar_hyps in + let new_hyps = + List.fold_right Environ.push_named_context_val extra_hyps hyps in + let extra_filter = List.map (fun _ -> true) extra_hyps in + let new_filter = extra_filter @ evi.Evd.evar_filter in + let new_evi = + { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in let evk = Evarutil.new_untyped_evar () in let new_sigma = Evd.add Evd.empty evk new_evi in diff --git a/proofs/goal.mli b/proofs/goal.mli index 9cd439ab..c0a094d3 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -232,7 +232,7 @@ module V82 : sig val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Environ.named_context_val -> goal Evd.sigma + val new_goal_with : Evd.evar_map -> goal -> Sign.named_context -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index d240c1e1..497ab1fa 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -105,7 +105,7 @@ let clear_hyps sigma ids sign cl = let recheck_typability (what,id) env sigma t = try check_typability env sigma t - with _ -> + with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(string_of_id id) in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 45e4a84e..7bac87d2 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -68,7 +68,7 @@ let start_proof id str hyps c ?init_tac ?compute_guard hook = | None -> Proofview.tclUNIT () in try Proof_global.run_tactic tac - with e -> Proof_global.discard_current (); raise e + with reraise -> Proof_global.discard_current (); raise reraise let restart_proof () = undo_todepth 1 @@ -164,9 +164,9 @@ let build_constant_by_tactic id sign typ tac = let _,(const,_,_,_) = cook_proof (fun _ -> ()) in delete_current_proof (); const - with e -> + with reraise -> delete_current_proof (); - raise e + raise reraise let build_by_tactic env typ tac = let id = id_of_string ("temporary_proof"^string_of_int (next())) in diff --git a/proofs/proof.ml b/proofs/proof.ml index a4e556c5..012a4dc1 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -323,7 +323,7 @@ let rec rollback pr = let transaction pr t = init_transaction pr; try t (); commit pr - with e -> rollback pr; raise e + with reraise -> rollback pr; raise reraise (* Focus command (focuses on the [i]th subgoal) *) @@ -429,9 +429,9 @@ let run_tactic env tac pr = let tacticced_proofview = Proofview.apply env tac sp in pr.state <- { pr.state with proofview = tacticced_proofview }; push_undo starting_point pr - with e -> + with reraise -> restore_state starting_point pr; - raise e + raise reraise (*** Commands ***) @@ -476,7 +476,7 @@ module V82 = struct let new_proofview = Proofview.V82.instantiate_evar n com sp in pr.state <- { pr.state with proofview = new_proofview }; push_undo starting_point pr - with e -> + with reraise -> restore_state starting_point pr; - raise e + raise reraise end diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 74e40e3b..d299a520 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -320,10 +320,12 @@ let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step -> (* takes a tactic which can raise exception and makes it pure by *failing* on with these exceptions. Does not catch anomalies. *) let purify t = - let t' env = { go = fun sk fk step -> try (t env).go (fun x -> sk (Util.Inl x)) fk step - with Util.Anomaly _ as e -> raise e - | e -> sk (Util.Inr e) fk step - } + let t' env = + { go = fun sk fk step -> + try (t env).go (fun x -> sk (Util.Inl x)) fk step + with Util.Anomaly _ as e -> raise e + | e when Errors.noncritical e -> sk (Util.Inr e) fk step + } in tclBIND t' begin function | Util.Inl x -> tclUNIT x diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 37c63644..21b43212 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -255,7 +255,7 @@ let tclORELSE0 t1 t2 g = try t1 g with (* Breakpoint *) - | e -> catch_failerror e; t2 g + | e when Errors.noncritical e -> catch_failerror e; t2 g (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, then applies t2 *) @@ -267,7 +267,7 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 let tclORELSE_THEN t1 t2then t2else gls = match try Some(tclPROGRESS t1 gls) - with e -> catch_failerror e; None + with e when Errors.noncritical e -> catch_failerror e; None with | None -> t2else gls | Some sgl -> @@ -298,7 +298,7 @@ let ite_gen tcal tac_if continue tac_else gl= try tcal tac_if0 continue gl with (* Breakpoint *) - | e -> catch_failerror e; tac_else0 e gl + | e when Errors.noncritical e -> catch_failerror e; tac_else0 e gl (* Try the first tactic and, if it succeeds, continue with the second one, and if it fails, use the third one *) @@ -352,7 +352,7 @@ let tclTIMEOUT n t g = | TacTimeout | Loc.Exc_located(_,TacTimeout) -> restore_timeout (); errorlabstrm "Refiner.tclTIMEOUT" (str"Timeout!") - | e -> restore_timeout (); raise e + | reraise -> restore_timeout (); raise reraise (* Beware: call by need of CAML, g is needed *) let rec tclREPEAT t g = diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index b56cb844..27ab990c 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -140,11 +140,11 @@ let debug_prompt lev g tac f = else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in (* What to execute *) try f newlevel - with e -> + with reraise -> skip:=0; skipped:=0; - if Logic.catchable_exception e then - ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e); - raise e + if Logic.catchable_exception reraise then + ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error reraise); + raise reraise (* Prints a constr *) let db_constr debug env c = diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 5bc77457..b75984e3 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -45,8 +45,7 @@ let camlp4topobjs = [ "Camlp4Top.cmo"; "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo"; "Camlp4Parsers/Camlp4OCamlParser.cmo"; - "Camlp4Parsers/Camlp4GrammarParser.cmo"; - "q_util.cmo"; "q_coqast.cmo" ] + "Camlp4Parsers/Camlp4GrammarParser.cmo" ] let topobjs = camlp4topobjs let gramobjs = [] @@ -257,8 +256,8 @@ let create_tmp_main_file modules = output_string oc "Coqtop.start();;\n"; close_out oc; main_name - with e -> - clean main_name; raise e + with reraise -> + clean main_name; raise reraise (* main part *) let main () = @@ -311,10 +310,10 @@ let main () = clean main_file; (* command gives the exit code in HSB, and signal in LSB !!! *) if retcode > 255 then retcode lsr 8 else retcode - with e -> - clean main_file; raise e + with reraise -> + clean main_file; raise reraise let retcode = - try Printexc.print main () with _ -> 1 + try Printexc.print main () with any -> 1 let _ = exit retcode diff --git a/tactics/auto.ml b/tactics/auto.ml index f7d63dcd..44fea151 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -829,7 +829,8 @@ let prepare_hint env (sigma,c) = let path_of_constr_expr c = match c with - | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny) + | Topconstr.CRef r -> + (try PathHints [global r] with e when Errors.noncritical e -> PathAny) | _ -> PathAny let interp_hints h = @@ -1170,9 +1171,9 @@ let tclLOG (dbg,depth,trace) pp tac = let out = tac gl in msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out - with e -> + with reraise -> msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); - raise e + raise reraise end | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -1181,9 +1182,9 @@ let tclLOG (dbg,depth,trace) pp tac = let out = tac gl in trace := (depth, Some pp) :: !trace; out - with e -> + with reraise -> trace := (depth, None) :: !trace; - raise e + raise reraise end (** For info, from the linear trace information, we reconstitute the part diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 039f022d..8e1d7cbf 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -208,8 +208,14 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl = (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = - let base = try find_base rbase with _ -> HintDN.empty in - let max = try fst (Util.list_last (HintDN.find_all base)) with _ -> 0 in + let base = + try find_base rbase + with e when Errors.noncritical e -> HintDN.empty + in + let max = + try fst (Util.list_last (HintDN.find_all base)) + with e when Errors.noncritical e -> 0 + in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab @@ -248,7 +254,7 @@ let evd_convertible env evd x y = try ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true (* try ignore(Evarconv.the_conv_x env x y evd); true *) - with _ -> false + with e when Errors.noncritical e -> false let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index cf4a267f..d05ae680 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -685,7 +685,7 @@ let resolve_typeclass_evars debug m env evd filter split fail = let evd = try Evarconv.consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env evd - with _ -> evd + with e when Errors.noncritical e -> evd in resolve_all_evars debug m env (initial_select_evars filter) evd split fail @@ -776,7 +776,10 @@ END let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = try - let dbs = list_map_filter (fun db -> try Some (Auto.searchtable_map db) with _ -> None) dbs in + let dbs = list_map_filter + (fun db -> try Some (Auto.searchtable_map db) + with e when Errors.noncritical e -> None) dbs + in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 68dd5dba..6981a733 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -205,7 +205,8 @@ module SearchProblem = struct (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) (lgls,pptac) :: aux tacl - with e -> Refiner.catch_failerror e; aux tacl + with e when Errors.noncritical e -> + Refiner.catch_failerror e; aux tacl in aux l (* Ordering of states is lexicographic on depth (greatest first) then diff --git a/tactics/equality.ml b/tactics/equality.ml index a352355b..1c5e4b2f 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -334,7 +334,8 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac try rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl - with e -> (* Try to see if there's an equality hidden *) + with e when Errors.noncritical e -> + (* Try to see if there's an equality hidden *) let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type t' with @@ -1156,7 +1157,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = ] (* not a dep eq or no decidable type found *) ) else (raise Not_dep_pair) - ) with _ -> + ) with e when Errors.noncritical e -> inject_at_positions env sigma u eq_clause posns (fun _ -> intros_pattern no_move ipats) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f5fcb736..f6ecb47c 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -606,7 +606,7 @@ let hResolve_auto id c t gl = hResolve id c n t gl with | UserError _ as e -> raise e - | _ -> resolve_auto (n+1) + | e when Errors.noncritical e -> resolve_auto (n+1) in resolve_auto 1 diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 47e3b7ca..c6f32ce2 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -64,9 +64,12 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) (* Test dependencies *) +(* NB: we consider also the let-in case in the following function, + since they may appear in types of inductive constructors (see #2629) *) + let rec has_nodep_prod_after n c = match kind_of_term c with - | Prod (_,_,b) -> + | Prod (_,_,b) | LetIn (_,_,_,b) -> ( n>0 || not (dependent (mkRel 1) b)) && (has_nodep_prod_after (n-1) b) | _ -> true @@ -355,7 +358,10 @@ let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ] let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ] let match_eq eqn eq_pat = - let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in + let pat = + try Lazy.force eq_pat + with e when Errors.noncritical e -> raise PatternMatchingFailure + in match matches pat eqn with | [(m1,t);(m2,x);(m3,y)] -> assert (m1 = meta1 & m2 = meta2 & m3 = meta3); diff --git a/tactics/inv.ml b/tactics/inv.ml index b7f6addc..e4b3bdb1 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -497,7 +497,7 @@ let wrap_inv_error id = function (* The most general inversion tactic *) let inversion inv_kind status names id gls = try (raw_inversion inv_kind id status names) gls - with e -> wrap_inv_error id e + with e when Errors.noncritical e -> wrap_inv_error id e (* Specializing it... *) @@ -540,7 +540,7 @@ let invIn k names ids id gls = inversion (false,k) NoDep names id; intros_replace_ids]) gls - with e -> wrap_inv_error id e + with e when Errors.noncritical e -> wrap_inv_error id e let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index b90a911a..98885af8 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -121,7 +121,7 @@ let is_applied_rewrite_relation env sigma rels t = let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in let _ = Typeclasses.resolve_one_typeclass env' evd inst in Some (it_mkProd_or_LetIn t rels) - with _ -> None) + with e when Errors.noncritical e -> None) | _ -> None let _ = @@ -145,11 +145,14 @@ let build_signature evars env m (cstrs : (types * types option) option list) new_cstr_evar evars env (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t in - let mk_relty evars env ty obj = + let mk_relty evars newenv ty obj = match obj with | None | Some (_, None) -> let relty = mk_relation ty in - new_evar evars env relty + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_evar evars env' relty + else new_evar evars newenv relty | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = @@ -227,7 +230,7 @@ let cstrevars evars = snd evars let evd_convertible env evd x y = try ignore(Evarconv.the_conv_x env x y evd); true - with _ -> false + with e when Errors.noncritical e -> false let rec decompose_app_rel env evd t = match kind_of_term t with @@ -493,7 +496,7 @@ let rec apply_pointwise rel = function | [] -> rel let pointwise_or_dep_relation n t car rel = - if noccurn 1 car then + if noccurn 1 car && noccurn 1 rel then mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) else mkApp (Lazy.force forall_relation, @@ -1048,7 +1051,8 @@ module Strategies = let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c - with _ -> error "fold: the term is not unfoldable !" + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in @@ -1056,7 +1060,7 @@ module Strategies = Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) - with _ -> None + with e when Errors.noncritical e -> None let fold_glob c : strategy = fun env avoid t ty cstr evars -> @@ -1064,7 +1068,8 @@ module Strategies = let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c - with _ -> error "fold: the term is not unfoldable !" + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in @@ -1072,7 +1077,7 @@ module Strategies = Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) - with _ -> None + with e when Errors.noncritical e -> None end @@ -1977,7 +1982,7 @@ let setoid_proof gl ty fn fallback = let evm = project gl in let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in fn env evm car rel gl - with e -> + with e when Errors.noncritical e -> try fallback gl with Hipattern.NoEquationFound -> match e with diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3ff0cf93..7479ee9a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -50,7 +50,7 @@ open Compat open Evd let safe_msgnl s = - try msgnl s with e -> + try msgnl s with e when Errors.noncritical e -> msgnl (str "bug in the debugger: " ++ str "an exception is raised while printing debug information") @@ -92,7 +92,7 @@ let catch_error call_trace tac g = if call_trace = [] then tac g else try tac g with | LtacLocated _ as e -> raise e | Loc.Exc_located (_,LtacLocated _) as e -> raise e - | e -> + | e when Errors.noncritical e -> let (nrep,loc',c),tail = list_sep_last call_trace in let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then @@ -569,13 +569,13 @@ let dump_glob_red_expr = function try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) - with _ -> ()) occs + with e when Errors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) - with _ -> ()) grf.rConst + with e when Errors.noncritical e -> ()) grf.rConst | _ -> () let intern_red_expr ist = function @@ -1412,19 +1412,20 @@ let interp_may_eval f ist gl = function | ConstrTerm c -> try f ist gl c - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c)); - raise e + raise reraise (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist gl c = let (sigma,csr) = try interp_may_eval pf_interp_constr ist gl c - with e -> - debugging_exception_step ist false e (fun () -> str"evaluation of term"); - raise e + with reraise -> + debugging_exception_step ist false reraise (fun () -> + str"evaluation of term"); + raise reraise in begin db_constr ist.debug (pf_env gl) csr; @@ -1762,10 +1763,7 @@ let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) let pack_sigma (sigma,c) = {it=c;sigma=sigma} let extend_gl_hyps { it=gl ; sigma=sigma } sign = - let hyps = Goal.V82.hyps sigma gl in - let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in - (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *) - Goal.V82.new_goal_with sigma gl new_hyps + Goal.V82.new_goal_with sigma gl sign (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = @@ -1925,9 +1923,11 @@ and interp_app loc ist gl fv largs = try catch_error trace (val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body - with e -> - debugging_exception_step ist false e (fun () -> str "evaluation"); - raise e in + with reraise -> + debugging_exception_step ist false reraise + (fun () -> str "evaluation"); + raise reraise + in let gl = { gl with sigma=sigma } in debugging_step ist (fun () -> @@ -2212,19 +2212,20 @@ and interp_match ist g lz constr lmr = (try let lmatch = try extended_matches c csr - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str "matching with pattern" ++ fnl () ++ pr_constr_pattern_env (pf_env g) c); - raise e in + raise reraise + in try let lfun = extend_values_with_bindings lmatch ist.lfun in eval_with_fail { ist with lfun=lfun } lz g mt - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str "rule body for pattern" ++ pr_constr_pattern_env (pf_env g) c); - raise e + raise reraise with e when is_match_catchable e -> debugging_step ist (fun () -> str "switching to the next rule"); apply_match ist sigma csr tl) @@ -2236,15 +2237,16 @@ and interp_match ist g lz constr lmr = errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match.") in let (sigma,csr) = - try interp_ltac_constr ist g constr with e -> - debugging_exception_step ist true e + try interp_ltac_constr ist g constr with reraise -> + debugging_exception_step ist true reraise (fun () -> str "evaluation of the matched expression"); - raise e in + raise reraise in let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in let res = - try apply_match ist sigma csr ilr with e -> - debugging_exception_step ist true e (fun () -> str "match expression"); - raise e in + try apply_match ist sigma csr ilr with reraise -> + debugging_exception_step ist true reraise + (fun () -> str "match expression"); + raise reraise in debugging_step ist (fun () -> str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res)); res @@ -2404,6 +2406,7 @@ and interp_atomic ist gl tac = (h_generalize_dep c_interp) | TacLetTac (na,c,clp,b,eqpat) -> let clp = interp_clause ist gl clp in + let eqpat = Option.map (interp_intro_pattern ist gl) eqpat in if clp = nowhere then (* We try to fully-typecheck the term *) let (sigma,c_interp) = pf_interp_constr ist gl c in @@ -3180,7 +3183,8 @@ let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) let tacticIn t = globTacticIn (fun ist -> try glob_tactic (t ist) - with e -> anomalylabstrm "tacticIn" + with e when Errors.noncritical e -> + anomalylabstrm "tacticIn" (str "Incorrect tactic expression. Received exception is:" ++ Errors.print e)) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 12292196..ac00a73d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1018,7 +1018,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl = let thm = nf_betaiota gl.sigma (pf_type_of gl d) in let rec aux clause = try progress_with_clause flags innerclause clause - with err -> + with err when Errors.noncritical err -> try aux (clenv_push_prod clause) with NotExtensibleClause -> raise err in aux (make_clenv_binding gl (d,thm) lbind) @@ -1708,7 +1708,7 @@ let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in let matching_fun t = try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) - with _ -> raise NotUnifiable in + with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> @@ -2554,7 +2554,10 @@ let specialize_eqs id gl = let specialize_eqs id gl = - if try ignore(clear [id] gl); false with _ -> true then + if + (try ignore(clear [id] gl); false + with e when Errors.noncritical e -> true) + then tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl else specialize_eqs id gl @@ -2716,7 +2719,8 @@ let compute_elim_sig ?elimc elimt = | Some ( _,None,ind) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } - with _ -> error "Cannot find the inductive type of the inductive scheme.";; + with e when Errors.noncritical e -> + error "Cannot find the inductive type of the inductive scheme.";; let compute_scheme_signature scheme names_info ind_type_guess = let f,l = decompose_app scheme.concl in @@ -3551,4 +3555,5 @@ let unify ?(state=full_transparent_state) x y gl = in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl - with _ -> tclFAIL 0 (str"Not unifiable") gl + with e when Errors.noncritical e -> + tclFAIL 0 (str"Not unifiable") gl diff --git a/test-suite/bugs/closed/2955.v b/test-suite/bugs/closed/2955.v new file mode 100644 index 00000000..45e24b5f --- /dev/null +++ b/test-suite/bugs/closed/2955.v @@ -0,0 +1,52 @@ +Require Import Coq.Arith.Arith. + +Module A. + + Fixpoint foo (n:nat) := + match n with + | 0 => 0 + | S n => bar n + end + + with bar (n:nat) := + match n with + | 0 => 0 + | S n => foo n + end. + + Lemma using_foo: + forall (n:nat), foo n = 0 /\ bar n = 0. + Proof. + induction n ; split ; auto ; + destruct IHn ; auto. + Qed. + +End A. + + +Module B. + + Module A := A. + Import A. + +End B. + +Module E. + + Module B := B. + Import B.A. + + (* Bug 1 *) + Lemma test_1: + forall (n:nat), foo n = 0. + Proof. + intros ; destruct n. + reflexivity. + specialize (A.using_foo (S n)) ; intros. + simpl in H. + simpl. + destruct H. + assumption. + Qed. + +End E. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2629.v b/test-suite/bugs/closed/shouldsucceed/2629.v new file mode 100644 index 00000000..759cd3dd --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2629.v @@ -0,0 +1,22 @@ +Class Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}. + +Class sepalg (t: Type) {JOIN: Join t} : Type := + SepAlg { + join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z'; + join_assoc: forall {a b c d e}, join a b d -> join d c e -> + {f : t & join b c f /\ join a f e}; + join_com: forall {a b c}, join a b c -> join b a c; + join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2; + + unit_for : t -> t -> Prop := fun e a => join e a a; + join_ex_units: forall a, {e : t & unit_for e a} +}. + +Definition joins {A} `{Join A} (a b : A) : Prop := + exists c, join a b c. + +Lemma join_joins {A} `{sepalg A}: forall {a b c}, + join a b c -> joins a b. +Proof. + firstorder. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/shouldsucceed/2668.v new file mode 100644 index 00000000..74c8fa34 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2668.v @@ -0,0 +1,6 @@ +Require Import MSetPositive. +Require Import MSetProperties. + +Module Pos := MSetPositive.PositiveSet. +Module PPPP := MSetProperties.WPropertiesOn(Pos). +Print Module PPPP. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/shouldsucceed/2734.v new file mode 100644 index 00000000..826361be --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2734.v @@ -0,0 +1,15 @@ +Require Import Arith List. +Require Import OrderedTypeEx. + +Module Adr. + Include Nat_as_OT. + Definition nat2t (i: nat) : t := i. +End Adr. + +Inductive expr := Const: Adr.t -> expr. + +Inductive control := Go: expr -> control. + +Definition program := (Adr.t * (control))%type. + +Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/shouldsucceed/2750.v new file mode 100644 index 00000000..fc580f10 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2750.v @@ -0,0 +1,23 @@ + +Module Type ModWithRecord. + + Record foo : Type := + { A : nat + ; B : nat + }. +End ModWithRecord. + +Module Test_ModWithRecord (M : ModWithRecord). + + Definition test1 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. + + Module B := M. + + Definition test2 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. +End Test_ModWithRecord. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/shouldsucceed/2928.v new file mode 100644 index 00000000..21e92ae2 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2928.v @@ -0,0 +1,11 @@ +Class Equiv A := equiv: A -> A -> Prop. +Infix "=" := equiv : type_scope. + +Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. + +Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. + +Class SemiLattice A op `{Equiv A} := + { semilattice_sg :>> SemiGroup A op + ; redundant : Associative op + }. diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/shouldsucceed/2983.v new file mode 100644 index 00000000..15598352 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2983.v @@ -0,0 +1,8 @@ +Module Type ModA. +End ModA. +Module Type ModB(A : ModA). +End ModB. +Module Foo(A : ModA)(B : ModB A). +End Foo. + +Print Module Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/shouldsucceed/2995.v new file mode 100644 index 00000000..ba3acd08 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2995.v @@ -0,0 +1,9 @@ +Module Type Interface. + Parameter error: nat. +End Interface. + +Module Implementation <: Interface. + Definition t := bool. + Definition error: t := false. +Fail End Implementation. +(* A UserError here is expected, not an uncaught Not_found *) \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/shouldsucceed/3000.v new file mode 100644 index 00000000..27de34ed --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3000.v @@ -0,0 +1,2 @@ +Inductive t (t':Type) : Type := A | B. +Definition d := match t with _ => 1 end. (* used to fail on list_chop *) diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/shouldsucceed/3004.v new file mode 100644 index 00000000..896b1958 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3004.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Unset Strict Implicit. +Parameter (M : nat -> Type). +Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2). + +Definition foo (s : list {n : nat & M n}) := + let exT := existT in mp (fun x => projT1 x) s. diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/shouldsucceed/3008.v new file mode 100644 index 00000000..3f3a979a --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3008.v @@ -0,0 +1,29 @@ +Module Type Intf1. +Parameter T : Type. +Inductive a := A. +End Intf1. + +Module Impl1 <: Intf1. +Definition T := unit. +Inductive a := A. +End Impl1. + +Module Type Intf2 + (Impl1 : Intf1). +Parameter x : Impl1.A=Impl1.A -> Impl1.T. +End Intf2. + +Module Type Intf3 + (Impl1 : Intf1) + (Impl2 : Intf2(Impl1)). +End Intf3. + +Fail Module Toto + (Impl1' : Intf1) + (Impl2 : Intf2(Impl1')) + (Impl3 : Intf3(Impl1)(Impl2)). +(* A UserError is expected here, not an uncaught Not_found *) + +(* NB : the Inductive above and the A=A weren't in the initial test, + they are here only to force an access to the environment + (cf [Printer.qualid_of_global]) and check that this env is ok. *) \ No newline at end of file diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index bca3b361..4f8de1dc 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -4,3 +4,7 @@ fun e : option L => match e with | None => None end : option L -> option L +fun n : nat => let x := A n in ?12 ?15:T n + : forall n : nat, T n +fun n : nat => ?20 ?23:T n + : forall n : nat, T n diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 968ea71a..2b564f48 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -12,3 +12,15 @@ Definition P (e:option L) := end. Print P. + +(* Check that the heuristic to solve constraints is not artificially + dependent on the presence of a let-in, and in particular that the + second [_] below is not inferred to be n, as if obtained by + first-order unification with [T n] of the conclusion [T _] of the + type of the first [_]. *) + +(* Note: exact numbers of evars are not important... *) + +Inductive T (n:nat) : Type := A : T n. +Check fun n (x:=A n:T n) => _ _ : T n. +Check fun n => _ _ : T n. diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v index 5f8ed03d..0befe054 100644 --- a/test-suite/success/remember.v +++ b/test-suite/success/remember.v @@ -6,3 +6,11 @@ Fail remember nat as X. Fail remember nat as X in H. (* This line used to succeed in 8.3 *) Fail remember nat as X. Abort. + +(* Testing Ltac interpretation of remember (was not working up to r16181) *) + +Goal (1 + 2 + 3 = 6). +let name := fresh "fresh" in +remember (1 + 2) as x eqn:name. +rewrite fresh. +Abort. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 5582438b..3dae9c70 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -646,4 +646,4 @@ End NZOrderProp. Module NZOrderedType (NZ : NZDecOrdSig') <: DecidableTypeFull <: OrderedTypeFull - := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec. + := NZ <+ NZBaseProp <+ NZOrderProp NZ <+ Compare2EqBool <+ HasEqBool2Dec. diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 3690b924..b9ab68ec 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -111,7 +111,7 @@ let mkFullInd ind n = let check_bool_is_defined () = try let _ = Global.type_of_global Coqlib.glob_bool in () - with _ -> raise (UndefinedCst "bool") + with e when Errors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -304,8 +304,9 @@ let destruct_ind c = try let u,v = destApp c in let indc = destInd u in indc,v - with _-> let indc = destInd c in - indc,[||] + with e when Errors.noncritical e -> + let indc = destInd c in + indc,[||] (* In the following, avoid is the list of names to avoid. @@ -329,8 +330,9 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q = else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) - with _ -> (* if this happen then the args have to be already declared as a - Parameter*) + with e when Errors.noncritical e -> + (* if this happen then the args have to be already declared as a + Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( @@ -376,8 +378,9 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) - with _ -> (* if this happen then the args have to be already declared as a - Parameter*) + with e when Errors.noncritical e -> + (* if this happen then the args have to be already declared as a + Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( @@ -394,7 +397,7 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) - with _ -> ind,[||] + with e when Errors.noncritical e -> ind,[||] in if u = ind then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2) else ( @@ -427,17 +430,19 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = | ([],[]) -> [] | _ -> error "Both side of the equality must have the same arity." in - let (ind1,ca1) = try destApp lft with - _ -> error "replace failed." - and (ind2,ca2) = try destApp rgt with - _ -> error "replace failed." + let (ind1,ca1) = + try destApp lft with e when Errors.noncritical e -> error "replace failed." + and (ind2,ca2) = + try destApp rgt with e when Errors.noncritical e -> error "replace failed." in - let (sp1,i1) = try destInd ind1 with - _ -> (try fst (destConstruct ind1) with _ -> - error "The expected type is an inductive one.") - and (sp2,i2) = try destInd ind2 with - _ -> (try fst (destConstruct ind2) with _ -> - error "The expected type is an inductive one.") + let (sp1,i1) = + try destInd ind1 with e when Errors.noncritical e -> + try fst (destConstruct ind1) with e when Errors.noncritical e -> + error "The expected type is an inductive one." + and (sp2,i2) = + try destInd ind2 with e when Errors.noncritical e -> + try fst (destConstruct ind2) with e when Errors.noncritical e -> + error "The expected type is an inductive one." in if (sp1 <> sp2) || (i1 <> i2) then (error "Eq should be on the same type") @@ -714,7 +719,8 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (* Decidable equality *) let check_not_is_defined () = - try ignore (Coqlib.build_coq_not ()) with _ -> raise (UndefinedCst "not") + try ignore (Coqlib.build_coq_not ()) + with e when Errors.noncritical e -> raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml index 10709abc..f43fc505 100644 --- a/toplevel/autoinstance.ml +++ b/toplevel/autoinstance.ml @@ -204,7 +204,8 @@ let declare_class_instance gr ctx params = (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst)); new_instance_message ident typ def - with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) + with e when Errors.noncritical e -> + msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t; match kind_of_term t with diff --git a/toplevel/backtrack.ml b/toplevel/backtrack.ml index 912d694e..f444fc2d 100644 --- a/toplevel/backtrack.ml +++ b/toplevel/backtrack.ml @@ -96,7 +96,9 @@ let mark_command ast = Stack.push { label = Lib.current_command_label (); nproofs = List.length (Pfedit.get_all_proof_names ()); - prfname = (try Some (Pfedit.get_current_proof_name ()) with _ -> None); + prfname = + (try Some (Pfedit.get_current_proof_name ()) + with Proof_global.NoCurrentProof -> None); prfdepth = max 0 (Pfedit.current_proof_depth ()); reachable = true; ngoals = get_ngoals (); diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 6914b8f0..de4d1ab1 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -37,7 +37,10 @@ let set_typeclass_transparency c local b = let _ = Typeclasses.register_add_instance_hint (fun inst local pri -> - let path = try Auto.PathHints [global_of_constr inst] with _ -> Auto.PathAny in + let path = + try Auto.PathHints [global_of_constr inst] + with e when Errors.noncritical e -> Auto.PathAny + in Flags.silently (fun () -> Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry @@ -300,8 +303,10 @@ let context l = let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; - let ctx = try named_of_rel_context fullctx with _ -> - error "Anonymous variables not allowed in contexts." + let ctx = + try named_of_rel_context fullctx + with e when Errors.noncritical e -> + error "Anonymous variables not allowed in contexts." in let fn (id, _, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 66a9516a..8f954573 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -46,9 +46,9 @@ let load_rcfile() = mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ " found. Skipping rcfile loading.")) *) - with e -> + with reraise -> (msgnl (str"Load of rcfile failed."); - raise e) + raise reraise) else Flags.if_verbose msgnl (str"Skipping rcfile loading.") diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index df388d1d..adbdb31b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -24,7 +24,8 @@ let get_version_date () = let ver = input_line ch in let rev = input_line ch in (ver,rev) - with _ -> (Coq_config.version,Coq_config.date) + with e when Errors.noncritical e -> + (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in @@ -310,7 +311,7 @@ let parse_args arglist = with Stream.Failure -> msgnl (Errors.print e); exit 1 end - | e -> begin msgnl (Errors.print e); exit 1 end + | any -> begin msgnl (Errors.print any); exit 1 end let init arglist = Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) @@ -344,10 +345,10 @@ let init arglist = load_vernacular (); compile_files (); outputstate () - with e -> + with any -> flush_all(); if not !batch_mode then message "Error during initialization:"; - msgnl (Toplevel.print_toplevel_error e); + msgnl (Toplevel.print_toplevel_error any); exit 1 end; if !batch_mode then diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index e7b5a0f2..f550df16 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -28,6 +28,8 @@ open Logic open Printer open Glob_term open Evd +open Libnames +open Declarations let pr_lconstr c = quote (pr_lconstr c) let pr_lconstr_env e c = quote (pr_lconstr_env e c) @@ -307,7 +309,7 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = let fixenv = make_all_name_different fixenv in let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in str"Recursive definition is:" ++ spc () ++ pvd ++ str "." - with _ -> mt ()) + with e when Errors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = let vdefj = jv_nf_evar sigma vdefj in @@ -542,8 +544,11 @@ let explain_not_match_error = function str "types given to " ++ str (string_of_id id) ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" - | NotConvertibleTypeField -> - str "types differ" + | NotConvertibleTypeField (env, typ1, typ2) -> + str "expected type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env typ2) ++ spc () ++ + str "but found type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env typ1) | NotSameConstructorNamesField -> str "constructor names differ" | NotSameInductiveNameInBlockField -> diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml index 28f97dc8..6937eeb8 100644 --- a/toplevel/ide_intf.ml +++ b/toplevel/ide_intf.ml @@ -89,8 +89,8 @@ let abstract_eval_call handler c = | Quit -> Obj.magic (handler.quit () : unit) | About -> Obj.magic (handler.about () : coq_info) in Good res - with e -> - let (l, str) = handler.handle_exn e in + with any -> + let (l, str) = handler.handle_exn any in Fail (l,str) (** * XML data marshalling *) @@ -275,7 +275,7 @@ let to_value f = function let loc_s = int_of_string (List.assoc "loc_s" attrs) in let loc_e = int_of_string (List.assoc "loc_e" attrs) in Some (loc_s, loc_e) - with _ -> None + with e when e <> Sys.Break -> None in let msg = raw_string l in Fail (loc, msg) diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index d67b272e..6e9a0ee0 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -237,7 +237,7 @@ let status () = in let proof = try Some (Names.string_of_id (Proof_global.get_current_proof_name ())) - with _ -> None + with Proof_global.NoCurrentProof -> None in let allproofs = let l = Proof_global.get_all_proof_names () in @@ -259,7 +259,8 @@ let search flags = | (Interface.Name_Pattern s, b) :: l -> let regexp = try Str.regexp s - with _ -> Util.error ("Invalid regexp: " ^ s) + with e when Errors.noncritical e -> + Util.error ("Invalid regexp: " ^ s) in extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l | (Interface.Type_Pattern s, b) :: l -> @@ -454,12 +455,12 @@ let loop () = Xml_utils.print_xml !orig_stdout xml_answer; flush !orig_stdout done - with e -> - let msg = Printexc.to_string e in + with any -> + let msg = Printexc.to_string any in let r = "Fatal exception in coqtop:\n" ^ msg in pr_debug ("==> " ^ r); (try Xml_utils.print_xml !orig_stdout (fail r); flush !orig_stdout - with _ -> ()); + with any -> ()); exit 1 diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 9f1a0218..77cfa6fa 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -86,8 +86,9 @@ let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) let declare_scheme_object s aux f = - (try check_ident ("ind"^s) with _ -> - error ("Illegal induction scheme suffix: "^s)); + (try check_ident ("ind"^s) + with e when Errors.noncritical e -> + error ("Illegal induction scheme suffix: "^s)); let key = if aux = "" then s else aux in try let _ = Hashtbl.find scheme_object_table key in diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index fa6885af..e30404e1 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -159,7 +159,7 @@ let try_declare_scheme what f internal names kn = (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared msg -> alarm what internal (msg ++ str ".") - | _ -> + | e when Errors.noncritical e -> alarm what internal (str "Unknown exception during scheme creation.") @@ -245,7 +245,8 @@ let try_declare_eq_decidability kn = let declare_eq_decidability = declare_eq_decidability_scheme_with [] -let ignore_error f x = try ignore (f x) with _ -> () +let ignore_error f x = + try ignore (f x) with e when Errors.noncritical e -> () let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin @@ -266,7 +267,7 @@ let declare_congr_scheme ind = if Hipattern.is_equality_type (mkInd ind) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true - with _ -> false + with e when Errors.noncritical e -> false then ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind) else diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml index d6ab44c6..30f07fed 100644 --- a/toplevel/lemmas.ml +++ b/toplevel/lemmas.ml @@ -229,23 +229,32 @@ let get_proof opacity = id,{const with const_entry_opaque = opacity},do_guard,persistence,hook let save_named opacity = - let id,const,do_guard,persistence,hook = get_proof opacity in - save id const do_guard persistence hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,persistence,hook = get_proof opacity in + save id const do_guard persistence hook + end let check_anonymity id save_ident = if atompart_of_id id <> string_of_id (default_thm_id) then error "This command can only be used for unnamed theorem." let save_anonymous opacity save_ident = - let id,const,do_guard,persistence,hook = get_proof opacity in - check_anonymity id save_ident; - save save_ident const do_guard persistence hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,persistence,hook = get_proof opacity in + check_anonymity id save_ident; + save save_ident const do_guard persistence hook + end let save_anonymous_with_strength kind opacity save_ident = - let id,const,do_guard,_,hook = get_proof opacity in - check_anonymity id save_ident; - (* we consider that non opaque behaves as local for discharge *) - save save_ident const do_guard (Global, Proof kind) hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,_,hook = get_proof opacity in + check_anonymity id save_ident; + (* we consider that non opaque behaves as local for discharge *) + save save_ident const do_guard (Global, Proof kind) hook + end (* Starting a goal *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 775a3af4..006dc5ec 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -237,7 +237,7 @@ let parse_format (loc,str) = | _ -> error "Box closed without being opened in format." else error "Empty format." - with e -> + with e when Errors.noncritical e -> Loc.raise loc e (***********************) @@ -277,6 +277,9 @@ let split_notation_string str = let out_nt = function NonTerminal x -> x | _ -> assert false +let msg_expected_form_of_recursive_notation = + "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." + let rec find_pattern nt xl = function | Break n as x :: l, Break n' :: l' when n=n' -> find_pattern nt (x::xl) (l,l') @@ -289,13 +292,14 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, [] -> - error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") + error msg_expected_form_of_recursive_notation | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> anomaly "Only Terminal or Break expected on left, non-SProdList on right" let rec interp_list_parser hd = function | [] -> [], List.rev hd | NonTerminal id :: tl when id = ldots_var -> + if hd = [] then error msg_expected_form_of_recursive_notation; let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in let xyl,tl'' = interp_list_parser [] tl' in @@ -337,7 +341,8 @@ let rec raw_analyze_notation_tokens = function let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> - (try let _ = Bigint.of_string x in true with _ -> false) + (try let _ = Bigint.of_string x in true + with e when Errors.noncritical e -> false) | _ -> false @@ -995,7 +1000,7 @@ let inNotation : notation_obj -> obj = let with_lib_stk_protection f x = let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a - with e -> Lib.unfreeze fs; raise e + with reraise -> Lib.unfreeze fs; raise reraise let with_syntax_protection f x = with_lib_stk_protection diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 2059ca60..f08308d3 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -92,8 +92,9 @@ let dir_ml_load s = (try t.load_obj s with | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u - | _ -> errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ - str s ++ str" to Coq code.")) + | e when Errors.noncritical e -> + errorlabstrm "Mltop.load_object" + (str"Cannot link ml-object " ++ str s ++ str" to Coq code.")) (* TO DO: .cma loading without toplevel *) | WithoutTop -> IFDEF HasDynlink THEN @@ -142,7 +143,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Names.id_of_string d - with _ -> + with e when Errors.noncritical e -> if_warn msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); flush_all (); @@ -269,9 +270,9 @@ let if_verbose_load verb f name fname = try f name fname; msgnl (str (info^" done]")); - with e -> + with reraise -> msgnl (str (info^" failed]")); - raise e + raise reraise (** Load a module for the first time (i.e. dynlink it) or simulate its reload (i.e. doing nothing except maybe diff --git a/toplevel/search.ml b/toplevel/search.ml index 3e182689..19d696a1 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -137,7 +137,7 @@ let pattern_filter pat _ a c = try try is_matching pat (head c) - with _ -> + with e when Errors.noncritical e -> is_matching pat (head (Typing.type_of (Global.env()) Evd.empty c)) with UserError _ -> diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index d5321623..cc659e36 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -180,7 +180,7 @@ let print_location_in_file s inlibrary fname loc = str", line " ++ int line ++ str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++ fnl () - with e -> + with e when Errors.noncritical e -> (close_in ic; hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) @@ -208,7 +208,7 @@ let valid_buffer_loc ib dloc loc = let make_prompt () = try (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " - with _ -> + with Proof_global.NoCurrentProof -> "Coq < " (*let build_pending_list l = @@ -340,7 +340,7 @@ let process_error = function discard_to_dot (); e with | End_of_input -> End_of_input - | de -> if is_pervasive_exn de then de else e + | any -> if is_pervasive_exn any then any else e (* do_vernac reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: @@ -354,8 +354,8 @@ let do_vernac () = begin try raw_do_vernac top_buffer.tokens - with e -> - msgnl (print_toplevel_error (process_error e)) + with any -> + msgnl (print_toplevel_error (process_error any)) end; flush_all() @@ -374,6 +374,6 @@ let rec loop () = | Vernacexpr.Drop -> () | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Quit -> exit 0 - | e -> + | any -> msgerrnl (str"Anomaly. Please report."); loop () diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 3314e82c..ed8e215f 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -156,7 +156,7 @@ let close_input in_chan (_,verb) = match verb with | Some verb_ch -> close_in verb_ch | _ -> () - with _ -> () + with e when Errors.noncritical e -> () let verbose_phrase verbch loc = let loc = unloc loc in @@ -232,13 +232,13 @@ let rec vernac_com interpfun checknav (loc,com) = Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds - with e -> + with reraise -> if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds; - raise e + raise reraise end | VernacList l -> List.iter (fun (_,v) -> interp v) l @@ -250,7 +250,7 @@ let rec vernac_com interpfun checknav (loc,com) = (* If the command actually works, ignore its effects on the state *) States.with_state_protection (fun v -> interp v; raise HasNotFailed) v - with e -> match real_error e with + with e when Errors.noncritical e -> match real_error e with | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed !") | e -> @@ -278,16 +278,16 @@ let rec vernac_com interpfun checknav (loc,com) = States.with_heavy_rollback interpfun Cerrors.process_vernac_interp_error v; restore_timeout psh - with e -> restore_timeout psh; raise e + with reraise -> restore_timeout psh; raise reraise in try checknav loc com; current_timeout := !default_timeout; if do_beautify () then pr_new_syntax loc (Some com); interp com - with e -> + with any -> Format.set_formatter_out_channel stdout; - raise (DuringCommandInterp (loc, e)) + raise (DuringCommandInterp (loc, any)) and read_vernac_file verbosely s = Flags.make_warn verbosely; @@ -316,13 +316,13 @@ and read_vernac_file verbosely s = end_inner_command (snd loc_ast); pp_flush () done - with e -> (* whatever the exception *) + with reraise -> (* whatever the exception *) Format.set_formatter_out_channel stdout; close_input in_chan input; (* we must close the file first *) - match real_error e with + match real_error reraise with | End_of_input -> if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None - | _ -> raise_with_file fname e + | _ -> raise_with_file fname reraise (** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit] It executes one vernacular command. By default the command is @@ -359,9 +359,9 @@ let load_vernac verb file = Lib.mark_end_of_command (); (* in case we're still in coqtop init *) read_vernac_file verb file; if !Flags.beautify_file then close_out !chan_beautify; - with e -> + with reraise -> if !Flags.beautify_file then close_out !chan_beautify; - raise_with_file file e + raise_with_file file reraise (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 6618b695..75efe139 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -295,7 +295,7 @@ let dump_universes_gen g s = close (); msgnl (str ("Universes written to file \""^s^"\".")) with - e -> close (); raise e + reraise -> close (); raise reraise let dump_universes sorted s = let g = Global.universes () in @@ -331,7 +331,7 @@ let msg_notfound_library loc qid = function let print_located_library r = let (loc,qid) = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library false qid) - with e -> msg_notfound_library loc qid e + with e when Errors.noncritical e -> msg_notfound_library loc qid e let print_located_module r = let (loc,qid) = qualid_of_reference r in @@ -364,7 +364,7 @@ let dump_global r = try let gr = Smartlocate.smart_global r in Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr - with _ -> () + with e when Errors.noncritical e -> () (**********) (* Syntax *) @@ -388,6 +388,7 @@ let vernac_notation = Metasyntax.add_notation (* Gallina *) let start_proof_and_print k l hook = + check_locality (); (* early check, cf #2975 *) start_proof_com k l hook; print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () @@ -910,7 +911,9 @@ let vernac_declare_arguments local r l nargs flags = | None -> None | Some (o, k) -> try Some(ignore(Notation.find_scope k); k) - with _ -> Some (Notation.find_delimiters_scope o k)) scopes in + with e when Errors.noncritical e -> + Some (Notation.find_delimiters_scope o k)) scopes + in let some_scopes_specified = List.exists ((<>) None) scopes in let rargs = Util.list_map_filter (function (n, true) -> Some n | _ -> None) @@ -1417,7 +1420,7 @@ let vernac_reset_name id = let gr = Smartlocate.global_with_alias (Ident id) in Dumpglob.add_glob (fst id) gr; true - with _ -> false in + with e when Errors.noncritical e -> false in if not globalized then begin try begin match Lib.find_opening_node (snd id) with diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index c4cc4ae5..a1b76d3d 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -60,7 +60,7 @@ let call (opn,converted_args) = hunk() with | Drop -> raise Drop - | e -> + | reraise -> if !Flags.debug then msgnl (str"Vernac Interpreter " ++ str !loc); - raise e + raise reraise -- cgit v1.2.3