diff options
| author |  Stephane Glondu <steph@glondu.net> | 2010-08-06 16:15:08 -0400 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2010-08-06 16:17:55 -0400 |
| commit | f18e6146f4fd6ed5b8ded10a3e602f5f64f919f4 (patch) | |
| tree | c413c5bb42d20daf5307634ae6402526bb994fd6 | |
| parent | b9f47391f7f259c24119d1de0a87839e2cc5e80c (diff) | |
Imported Upstream version 8.3~rc1+dfsgupstream/8.3.rc1.dfsg
866 files changed, 4085 insertions, 3665 deletions
@@ -11,7 +11,8 @@ Rewriting tactics proofs that are dependent (use "simple subst" for preserving compatibility). - Added support for Leibniz-rewriting of dependent hypotheses. - Renamed "Morphism" into "Proper" and "respect" into "proper_prf" - (possible source of incompatibility). + (possible source of incompatibility). A partial fix is to define + "Notation Morphism R f := (Proper (R%signature) f)." - New tactic variants "rewrite* by" and "autorewrite*" that rewrite respectively the first and all matches whose side-conditions are solved. @@ -126,7 +127,8 @@ Module system - A functor application can be prefixed by a "!" to make it ignore any "Inline" annotation in the type of its argument(s) (for examples of use of the new features, see libraries Structures and Numbers). -- Coercions are now active only when modules are imported. +- Coercions are now active only when modules are imported (use "Set Automatic + Coercions Import" to get the behavior of the previous versions of Coq). Extraction @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id$ +# $Id: Makefile 13184 2010-06-23 09:19:15Z notin $ # Makefile for Coq diff --git a/Makefile.build b/Makefile.build index a7ae1e22..4a7354e4 100644 --- a/Makefile.build +++ b/Makefile.build @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id$ +# $Id: Makefile.build 13324 2010-07-24 19:21:23Z glondu $ # Makefile for Coq @@ -623,7 +623,7 @@ install-coq-manpages: install-emacs: $(MKDIR) $(FULLEMACSLIB) - $(INSTALLLIB) tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB) + $(INSTALLLIB) tools/coq-db.el tools/coq-font-lock.el tools/coq-syntax.el tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB) # command to update TeX' kpathsea database #UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /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 <opaque>) - -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/inductive.ml b/checker/inductive.ml index a300af79..fcd69f26 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -429,7 +429,7 @@ type guard_env = (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) - genv : subterm_spec list; + genv : subterm_spec Lazy.t list; } let make_renv env minds recarg (kn,tyi) = @@ -440,7 +440,7 @@ let make_renv env minds recarg (kn,tyi) = rel_min = recarg+2; inds = minds; recvec = mind_recvec; - genv = [Subterm(Large,mind_recvec.(tyi))] } + genv = [Lazy.lazy_from_val (Subterm(Large,mind_recvec.(tyi)))] } let push_var renv (x,ty,spec) = { renv with @@ -452,30 +452,30 @@ let assign_var_spec renv (i,spec) = { renv with genv = list_assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = - push_var renv (x,ty,Not_subterm) + push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = - try List.nth renv.genv (p-1) + try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm (* Add a variable and mark it as strictly smaller with information [spec]. *) let add_subterm renv (x,a,spec) = - push_var renv (x,a,spec_of_tree spec) + push_var renv (x,a,lazy (spec_of_tree (Lazy.force spec))) let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { renv with env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } (******************************) @@ -499,12 +499,44 @@ let lookup_subterms env ind = (*********************************) +let match_trees t1 t2 = + let v1 = dest_subterms t1 in + let v2 = dest_subterms t2 in + array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2 + +(* In {match c as z in ind y_s return P with |C_i x_s => t end} + [branches_specif renv c_spec ind] returns an array of x_s specs given + c_spec the spec of c. *) +let branches_specif renv c_spec ind = + let (_,mip) = lookup_mind_specif renv.env ind in + let car = + (* We fetch the regular tree associated to the inductive of the match. + This is just to get the number of constructors (and constructor + arities) that fit the match branches without forcing c_spec. + Note that c_spec might be more precise than [v] below, because of + nested inductive types. *) + let v = dest_subterms mip.mind_recargs in + Array.map List.length v in + Array.mapi + (fun i nca -> (* i+1-th cstructor has arity nca *) + let lvra = lazy + (match Lazy.force c_spec with + Subterm (_,t) when match_trees mip.mind_recargs t -> + let vra = Array.of_list (dest_subterms t).(i) in + assert (nca = Array.length vra); + Array.map spec_of_tree vra + | Dead_code -> Array.create nca Dead_code + | _ -> Array.create nca Not_subterm) in + list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) + car + (* Propagation of size information through Cases: if the matched object is a recursive subterm then compute the information associated to its own subterms. Rq: if branch is not eta-long, then the recursive information is not propagated to the missing abstractions *) let case_branches_specif renv c_spec ind lbr = + let vlrec = branches_specif renv c_spec ind in let rec push_branch_args renv lrec c = match lrec with ra::lr -> @@ -516,17 +548,9 @@ let case_branches_specif renv c_spec ind lbr = | _ -> (* branch not in eta-long form: cannot perform rec. calls *) (renv,c')) | [] -> (renv, c) in - match c_spec with - Subterm (_,t) -> - let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in - assert (Array.length sub_spec = Array.length lbr); - array_map2 (push_branch_args renv) sub_spec lbr - | Dead_code -> - let t = dest_subterms (lookup_subterms renv.env ind) in - let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in - assert (Array.length sub_spec = Array.length lbr); - array_map2 (push_branch_args renv) sub_spec lbr - | Not_subterm -> Array.map (fun c -> (renv,c)) lbr + assert (Array.length vlrec = Array.length lbr); + array_map2 (push_branch_args renv) vlrec lbr + (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of @@ -541,14 +565,11 @@ let rec subterm_specif renv t = | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> - if Array.length lbr = 0 then Dead_code - else - let c_spec = subterm_specif renv c in - let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in - let stl = - Array.map (fun (renv',br') -> subterm_specif renv' br') - lbr_spec in - subterm_spec_glb stl + let lbr_spec = case_subterm_specif renv ci c lbr in + let stl = + Array.map (fun (renv',br') -> subterm_specif renv' br') + lbr_spec in + subterm_spec_glb stl | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough @@ -571,7 +592,8 @@ let rec subterm_specif renv t = let renv' = (* Why Strict here ? To be general, it could also be Large... *) - assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in + assign_var_spec renv' + (nbfix-i, Lazy.lazy_from_val (Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in @@ -582,7 +604,7 @@ let rec subterm_specif renv t = if List.length l < nbOfAbst then renv'' else let theDecrArg = List.nth l decrArg in - let arg_spec = subterm_specif renv theDecrArg in + let arg_spec = lazy_subterm_specif renv theDecrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' strippedBody) @@ -596,7 +618,15 @@ let rec subterm_specif renv t = (* Other terms are not subterms *) | _ -> Not_subterm +and lazy_subterm_specif renv t = + lazy (subterm_specif renv t) +and case_subterm_specif renv ci c lbr = + if Array.length lbr = 0 then [||] + else + let c_spec = lazy_subterm_specif renv c in + case_branches_specif renv c_spec ci.ci_ind lbr + (* Check term c can be applied to one of the mutual fixpoints. *) let check_is_subterm renv c = match subterm_specif renv c with @@ -611,7 +641,7 @@ let error_illegal_rec_call renv fx arg = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> - match sbt with + match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) @@ -665,8 +695,7 @@ let check_one_fix renv recpos def = List.iter (check_rec_call renv) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) - let c_spec = subterm_specif renv c_0 in - let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in + let lbr = case_subterm_specif renv ci c_0 lrest in Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr (* Enables to traverse Fixpoint definitions in a more intelligent @@ -694,7 +723,7 @@ let check_one_fix renv recpos def = (fun j body -> if i=j then let theDecrArg = List.nth l decrArg in - let arg_spec = subterm_specif renv theDecrArg in + let arg_spec = lazy_subterm_specif renv theDecrArg in check_nested_fix_body renv' (decrArg+1) arg_spec body else check_rec_call renv' body) bodies diff --git a/checker/inductive.mli b/checker/inductive.mli index 2708c2d8..d44d1556 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -77,9 +77,9 @@ type guard_env = (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) - genv : subterm_spec list; + genv : subterm_spec Lazy.t list; } val subterm_specif : guard_env -> constr -> subterm_spec -val case_branches_specif : guard_env -> subterm_spec -> inductive -> +val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive -> constr array -> (guard_env * constr) array diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 9c82285b..07718a09 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -131,7 +131,7 @@ let import file (dp,mb,depends,engmt as vo) digest = full_add_module dp mb digest (* When the module is admitted, digests *must* match *) -let unsafe_import file (dp,mb,depends,engmt as vo) digest = +let unsafe_import file (dp,mb,depends,engmt) digest = (* if !Flags.debug then Validate.apply !Flags.debug val_vo vo;*) let env = !genv in check_imports (errorlabstrm"unsafe_import") dp env depends; diff --git a/config/coq_config.mli b/config/coq_config.mli index 6a99d017..10c298b5 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coq_config.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val local : bool (* local use (no installation) *) @@ -6,7 +6,7 @@ # ################################## -VERSION=8.3-bugfix +VERSION=8.3-rc1 VOMAGIC=08300 STATEMAGIC=58300 DATE=`LANG=C date +"%B %Y"` @@ -1114,4 +1114,4 @@ echo echo "*Warning* To compile the system for a new architecture" echo " don't forget to do a 'make archclean' before './configure'." -# $Id: configure 12689 2010-01-26 13:41:56Z glondu $ +# $Id: configure 13372 2010-08-06 08:36:16Z notin $ diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 91255202..069f7d42 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -7,6 +7,13 @@ whd_castappevar is now whd_head_evar obsolete whd_ise disappears +** Restructuration of the syntax of binders ** + +binders_let -> binders +binders_let_fixannot -> binders_fixannot +binder_let -> closed_binder (and now covers only bracketed binders) +binder was already obsolete and has been removed + ** Semantical change of h_induction_destruct ** Warning, the order of the isrec and evar_flag was inconsistent and has diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex index f5509c3a..bfd7f3f2 100755 --- a/doc/stdlib/Library.tex +++ b/doc/stdlib/Library.tex @@ -61,4 +61,4 @@ you can access from the \Coq\ home page at \end{document} -% $Id$ +% $Id: Library.tex 12363 2009-09-28 15:04:07Z letouzey $ diff --git a/ide/command_windows.ml b/ide/command_windows.ml index 44ede5ac..4510189b 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: command_windows.ml 13323 2010-07-24 15:57:30Z herbelin $ *) class command_window () = (* let window = GWindow.window diff --git a/ide/command_windows.mli b/ide/command_windows.mli index 821d4ef2..eb0aa568 100644 --- a/ide/command_windows.mli +++ b/ide/command_windows.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: command_windows.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) class command_window : unit -> diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 05a7d443..4e3ffd89 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: config_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ *) { diff --git a/ide/config_parser.mly b/ide/config_parser.mly index a412391e..0859cbe0 100644 --- a/ide/config_parser.mly +++ b/ide/config_parser.mly @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************/ -/* $Id$ */ +/* $Id: config_parser.mly 13323 2010-07-24 15:57:30Z herbelin $ */ %{ @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coq.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Vernac open Vernacexpr diff --git a/ide/coq.mli b/ide/coq.mli index c81439f5..af17c0e9 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coq.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 0fee399e..c8a5c940 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coq_commands.ml 13323 2010-07-24 15:57:30Z herbelin $ *) let commands = [ [(* "Abort"; *) diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml index 1ad05785..e3d8131e 100644 --- a/ide/coq_tactics.ml +++ b/ide/coq_tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coq_tactics.ml 13323 2010-07-24 15:57:30Z herbelin $ *) let tactics = [ "Abstract"; diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli index c5e4ca62..e33c73ab 100644 --- a/ide/coq_tactics.mli +++ b/ide/coq_tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coq_tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val tactics : string list diff --git a/ide/coqide.ml b/ide/coqide.ml index 96ef695b..08452fe2 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqide.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Preferences open Vernacexpr diff --git a/ide/coqide.mli b/ide/coqide.mli index b79b2389..b70a9b4b 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coqide.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* The CoqIde main module. The following function [start] will parse the command line, initialize the load path, load the input diff --git a/ide/highlight.mll b/ide/highlight.mll index 3a6a6192..dfcc4354 100644 --- a/ide/highlight.mll +++ b/ide/highlight.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: highlight.mll 13323 2010-07-24 15:57:30Z herbelin $ *) { diff --git a/ide/ideutils.ml b/ide/ideutils.ml index adeabf5d..138bf5f6 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ideutils.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Preferences diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 28199207..9af4fb43 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ideutils.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val async : ('a -> unit) -> 'a -> unit val sync : ('a -> 'b) -> 'a -> 'b diff --git a/ide/preferences.ml b/ide/preferences.ml index d5ed7934..31d03ab9 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: preferences.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Configwin open Printf diff --git a/ide/preferences.mli b/ide/preferences.mli index cc39dcc3..50659717 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: preferences.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) type pref = { diff --git a/ide/undo.ml b/ide/undo.ml index 50e1a515..819b4807 100644 --- a/ide/undo.ml +++ b/ide/undo.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: undo.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open GText open Ideutils diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli index 4d70a3ad..c260f171 100644 --- a/ide/undo_lablgtk_ge26.mli +++ b/ide/undo_lablgtk_ge26.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: undo_lablgtk_ge26.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* An undoable view class *) diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli index f1910148..c9d1bacb 100644 --- a/ide/undo_lablgtk_lt26.mli +++ b/ide/undo_lablgtk_lt26.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: undo_lablgtk_lt26.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* An undoable view class *) diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index 1025e3b4..5034ab3c 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: utf8_convert.mll 13323 2010-07-24 15:57:30Z herbelin $ *) { open Lexing diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml index 37f2e9a4..d972639f 100644 --- a/ide/utils/config_file.ml +++ b/ide/utils/config_file.ml @@ -23,7 +23,7 @@ (* *) (*********************************************************************************) -(* $Id$ *) +(* $Id: config_file.ml 10348 2007-12-06 17:36:14Z aspiwack $ *) (* TODO *) (* section comments *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 77a79883..b2b21925 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: constrextern.ml 13329 2010-07-26 11:05:39Z herbelin $ *) (*i*) open Pp @@ -178,9 +178,10 @@ let rec check_same_type ty1 ty2 = check_same_type b1 b2 | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> check_same_type a1 a2 - | CNotation(_,n1,(e1,el1)), CNotation(_,n2,(e2,el2)) when n1=n2 -> + | CNotation(_,n1,(e1,el1,bl1)), CNotation(_,n2,(e2,el2,bl2)) when n1=n2 -> List.iter2 check_same_type e1 e2; - List.iter2 (List.iter2 check_same_type) el1 el2 + List.iter2 (List.iter2 check_same_type) el1 el2; + List.iter2 check_same_fix_binder bl1 bl2 | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> () | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 -> check_same_type e1 e2 @@ -287,7 +288,7 @@ and spaces ntn n = if n = String.length ntn then [] else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1) -let expand_curly_brackets loc mknot ntn (l,ll) = +let expand_curly_brackets loc mknot ntn l = let ntn' = ref ntn in let rec expand_ntn i = function @@ -300,12 +301,12 @@ let expand_curly_brackets loc mknot ntn (l,ll) = ntn' := String.sub !ntn' 0 p ^ "_" ^ String.sub !ntn' (p+5) (String.length !ntn' -p-5); - mknot (loc,"{ _ }",([a],[])) end + mknot (loc,"{ _ }",[a]) end else a in a' :: expand_ntn (i+1) l in let l = expand_ntn 0 l in (* side effect *) - mknot (loc,!ntn',(l,ll)) + mknot (loc,!ntn',l) let destPrim = function CPrim(_,t) -> Some t | _ -> None let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None @@ -313,32 +314,34 @@ let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l = if has_curly_brackets ntn then expand_curly_brackets loc mknot ntn l - else match ntn,List.map destprim (fst l),(snd l) with + else match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *) - | "- _", [Some (Numeral p)],[] when Bigint.is_strictly_pos p -> - mknot (loc,ntn,([mknot (loc,"( _ )",l)],[])) + | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p -> + mknot (loc,ntn,([mknot (loc,"( _ )",l)])) | _ -> match decompose_notation_key ntn, l with - | [Terminal "-"; Terminal x], ([],[]) -> + | [Terminal "-"; Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with _ -> mknot (loc,ntn,([],[]))) - | [Terminal x], ([],[]) -> + with _ -> mknot (loc,ntn,[])) + | [Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.of_string x)) - with _ -> mknot (loc,ntn,([],[]))) + with _ -> mknot (loc,ntn,[])) | _ -> mknot (loc,ntn,l) -let make_notation loc ntn l = +let make_notation loc ntn (terms,termlists,binders as subst) = + if termlists <> [] or binders <> [] then CNotation (loc,ntn,subst) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CNotation (loc,ntn,l)) + (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[]))) (fun (loc,p) -> CPrim (loc,p)) - destPrim l + destPrim terms -let make_pat_notation loc ntn l = +let make_pat_notation loc ntn (terms,termlists as subst) = + if termlists <> [] then CPatNotation (loc,ntn,subst) else make_notation_gen loc ntn - (fun (loc,ntn,l) -> CPatNotation (loc,ntn,l)) + (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]))) (fun (loc,p) -> CPatPrim (loc,p)) - destPatPrim l + destPatPrim terms (* Better to use extern_rawconstr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = @@ -686,10 +689,10 @@ let rec extern inctx scopes vars r = let na' = match na,tm with Anonymous, RVar (_,id) when rtntypopt<>None & occur_rawconstr id (Option.get rtntypopt) - -> Some Anonymous + -> Some (dummy_loc,Anonymous) | Anonymous, _ -> None | Name id, RVar (_,id') when id=id' -> None - | Name _, _ -> Some na in + | Name _, _ -> Some (dummy_loc,na) in (sub_extern false scopes vars tm, (na',Option.map (fun (loc,ind,n,nal) -> let params = list_tabulate @@ -703,15 +706,15 @@ let rec extern inctx scopes vars r = CCases (loc,sty,rtntypopt',tml,eqns) | RLetTuple (loc,nal,(na,typopt),tm,b) -> - CLetTuple (loc,nal, - (Option.map (fun _ -> na) typopt, + CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal, + (Option.map (fun _ -> (dummy_loc,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern false scopes vars tm, extern inctx scopes (List.fold_left add_vname vars nal) b) | RIf (loc,c,(na,typopt),b1,b2) -> CIf (loc,sub_extern false scopes vars c, - (Option.map (fun _ -> na) typopt, + (Option.map (fun _ -> (dummy_loc,na)) typopt, Option.map (extern_typ scopes (add_vname vars na)) typopt), sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2) @@ -836,7 +839,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) - let subst,substlist = match_aconstr t pat in + let terms,termlists,binders = match_aconstr t pat in (* Try availability of interpretation ... *) let e = match keyrule with @@ -851,17 +854,21 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern (* assuming no overloading: *) true (scopt,scl@scopes') vars c) - subst in + terms in let ll = List.map (fun (c,(scopt,scl)) -> List.map (extern true (scopt,scl@scopes') vars) c) - substlist in - insert_delimiters (make_notation loc ntn (l,ll)) key) + termlists in + let bll = + List.map (fun (bl,(scopt,scl)) -> + snd (extern_local_binder (scopt,scl@scopes') vars bl)) + binders in + insert_delimiters (make_notation loc ntn (l,ll,bll)) key) | SynDefRule kn -> let l = List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) - subst in + terms in let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in if l = [] then a else CApp (loc,(None,a),l) in if args = [] then e diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 5f170bdc..248abeda 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: constrextern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 0fed211d..3bf556f1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: constrintern.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -28,7 +28,10 @@ open Inductiveops (* To interpret implicits and arg scopes of variables in inductive types and recursive definitions and of projection names in records *) -type var_internalization_type = Inductive | Recursive | Method +type var_internalization_type = + | Inductive of identifier list (* list of params *) + | Recursive + | Method type var_internalization_data = (* type of the "free" variable, for coqdoc, e.g. while typing the @@ -45,19 +48,12 @@ type var_internalization_data = type internalization_env = (identifier * var_internalization_data) list -type full_internalization_env = - (* a superset of the list of variables that may be automatically - inserted and that must not occur as binders *) - identifier list * - (* mapping of the variables to their internalization data *) - internalization_env - type raw_binder = (name * binding_kind * rawconstr option * rawconstr) let interning_grammar = ref false (* Historically for parsing grammar rules, but in fact used only for - translator, v7 parsing, and unstrict tactic internalisation *) + translator, v7 parsing, and unstrict tactic internalization *) let for_grammar f x = interning_grammar := true; let a = f x in @@ -92,9 +88,9 @@ let global_reference_in_absolute_module dir id = constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) (**********************************************************************) -(* Internalisation errors *) +(* Internalization errors *) -type internalisation_error = +type internalization_error = | VariableCapture of identifier | WrongExplicitImplicit | IllegalMetavariable @@ -104,7 +100,7 @@ type internalisation_error = | BadPatternsNumber of int * int | BadExplicitationNumber of explicitation * int option -exception InternalisationError of loc * internalisation_error +exception InternalizationError of loc * internalization_error let explain_variable_capture id = str "The variable " ++ pr_id id ++ str " occurs in its type" @@ -146,7 +142,7 @@ let explain_bad_explicitation_number n po = str "Bad explicitation name: found " ++ pr_id id ++ str" but was expecting " ++ s -let explain_internalisation_error e = +let explain_internalization_error e = let pp = match e with | VariableCapture id -> explain_variable_capture id | WrongExplicitImplicit -> explain_wrong_explicit_implicit @@ -171,30 +167,26 @@ let error_inductive_parameter_not_implicit loc = (* Pre-computing the implicit arguments and arguments scopes needed *) (* for interpretation *) -let empty_internalization_env = ([],[]) +let empty_internalization_env = [] -let set_internalization_env_params ienv params = - let nparams = List.length params in - if nparams = 0 then - ([],ienv) - else - let ienv_with_implicit_params = - List.map (fun (id,(ty,_,impl,scopes)) -> - let sub_impl,_ = list_chop nparams impl in - let sub_impl' = List.filter is_status_implicit sub_impl in - (id,(ty,List.map name_of_implicit sub_impl',impl,scopes))) ienv in - (params, ienv_with_implicit_params) - -let compute_internalization_data env ty typ impls = - let impl = compute_implicits_with_manual env typ (is_implicit_args()) impls in - (ty, [], impl, compute_arguments_scope typ) - -let compute_full_internalization_env env ty params idl typl impll = - set_internalization_env_params - (list_map3 - (fun id typ impl -> (id,compute_internalization_data env ty typ impl)) - idl typl impll) - params +let compute_explicitable_implicit imps = function + | Inductive params -> + (* In inductive types, the parameters are fixed implicit arguments *) + let sub_impl,_ = list_chop (List.length params) imps in + let sub_impl' = List.filter is_status_implicit sub_impl in + List.map name_of_implicit sub_impl' + | Recursive | Method -> + (* Unable to know in advance what the implicit arguments will be *) + [] + +let compute_internalization_data env ty typ impl = + let impl = compute_implicits_with_manual env typ (is_implicit_args()) impl in + let expls_impl = compute_explicitable_implicit impl ty in + (ty, expls_impl, impl, compute_arguments_scope typ) + +let compute_internalization_env env ty = + list_map3 + (fun id typ impl -> (id,compute_internalization_data env ty typ impl)) (**********************************************************************) (* Contracting "{ _ }" in notations *) @@ -216,18 +208,18 @@ let expand_notation_string ntn n = (* This contracts the special case of "{ _ }" for sumbool, sumor notations *) (* Remark: expansion of squash at definition is done in metasyntax.ml *) -let contract_notation ntn (l,ll) = +let contract_notation ntn (l,ll,bll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CNotation (_,"{ _ }",([a],[])) :: l -> + | CNotation (_,"{ _ }",([a],[],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',(l,ll) + !ntn',(l,ll,bll) let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in @@ -250,43 +242,219 @@ let make_current_scope = function | (Some tmp_scope,scopes) -> tmp_scope::scopes | None,scopes -> scopes -let set_var_scope loc id (_,_,scopt,scopes) varscopes = - let idscopes = List.assoc id varscopes in - if !idscopes <> None & - make_current_scope (Option.get !idscopes) - <> make_current_scope (scopt,scopes) then - let pr_scope_stack = function - | [] -> str "the empty scope stack" - | [a] -> str "scope " ++ str a - | l -> str "scope stack " ++ - str "[" ++ prlist_with_sep pr_comma str l ++ str "]" in - user_err_loc (loc,"set_var_scope", - pr_id id ++ str " is used both in " ++ - pr_scope_stack (make_current_scope (Option.get !idscopes)) ++ - strbrk " and in " ++ - pr_scope_stack (make_current_scope (scopt,scopes))) - else - idscopes := Some (scopt,scopes) +let pr_scope_stack = function + | [] -> str "the empty scope stack" + | [a] -> str "scope " ++ str a + | l -> str "scope stack " ++ + str "[" ++ prlist_with_sep pr_comma str l ++ str "]" + +let error_inconsistent_scope loc id scopes1 scopes2 = + user_err_loc (loc,"set_var_scope", + pr_id id ++ str " is used both in " ++ + pr_scope_stack scopes1 ++ strbrk " and in " ++ pr_scope_stack scopes2) + +let error_expect_constr_notation_type loc id = + user_err_loc (loc,"", + pr_id id ++ str " is bound in the notation to a term variable.") + +let error_expect_binder_notation_type loc id = + user_err_loc (loc,"", + pr_id id ++ + str " is expected to occur in binding position in the right-hand side.") + +let set_var_scope loc id istermvar (_,_,scopt,scopes) ntnvars = + try + let idscopes,typ = List.assoc id ntnvars in + if !idscopes <> None & + make_current_scope (Option.get !idscopes) + <> make_current_scope (scopt,scopes) then + error_inconsistent_scope loc id + (make_current_scope (Option.get !idscopes)) + (make_current_scope (scopt,scopes)) + else + idscopes := Some (scopt,scopes); + match typ with + | NtnInternTypeBinder -> + if istermvar then error_expect_binder_notation_type loc id + | NtnInternTypeConstr -> + (* We need sometimes to parse idents at a constr level for + factorization and we cannot enforce this constraint: + if not istermvar then error_expect_constr_notation_type loc id *) + () + | NtnInternTypeIdent -> () + with Not_found -> + (* Not in a notation *) + () + +let set_type_scope (ids,unb,tmp_scope,scopes) = + (ids,unb,Some Notation.type_scope,scopes) + +let reset_tmp_scope (ids,unb,tmp_scope,scopes) = + (ids,unb,None,scopes) + +let rec it_mkRProd env body = + match env with + (na, bk, _, t) :: tl -> it_mkRProd tl (RProd (dummy_loc, na, bk, t, body)) + | [] -> body + +let rec it_mkRLambda env body = + match env with + (na, bk, _, t) :: tl -> it_mkRLambda tl (RLambda (dummy_loc, na, bk, t, body)) + | [] -> body + +(**********************************************************************) +(* Utilities for binders *) + +let check_capture loc ty = function + | Name id when occur_var_constr_expr id ty -> + raise (InternalizationError (loc,VariableCapture id)) + | _ -> + () + +let locate_if_isevar loc na = function + | RHole _ -> + (try match na with + | Name id -> Reserve.find_reserved_type id + | Anonymous -> raise Not_found + with Not_found -> RHole (loc, Evd.BinderType na)) + | x -> x + +let check_hidden_implicit_parameters id (_,_,_,impls) = + if List.exists (function + | (_,(Inductive indparams,_,_,_)) -> List.mem id indparams + | _ -> false) impls + then + errorlabstrm "" (strbrk "A parameter of an inductive type " ++ + pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") + +let push_name_env ?(global_level=false) lvar (ids,unb,tmpsc,scopes as env) = + function + | loc,Anonymous -> + if global_level then + user_err_loc (loc,"", str "Anonymous variables not allowed"); + env + | loc,Name id -> + check_hidden_implicit_parameters id lvar; + set_var_scope loc id false env (let (_,_,ntnvars,_) = lvar in ntnvars); + if global_level then Dumpglob.dump_definition (loc,id) true "var" + else Dumpglob.dump_binding loc id; + (Idset.add id ids,unb,tmpsc,scopes) + +let intern_generalized_binder ?(global_level=false) intern_type lvar + (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty = + let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in + let ty, ids' = + if t then ty, ids else + Implicit_quantifiers.implicit_application ids + Implicit_quantifiers.combine_params_freevar ty + in + let ty' = intern_type (ids,true,tmpsc,sc) ty in + let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in + let env' = List.fold_left (fun env (x, l) -> push_name_env ~global_level lvar env (l, Name x)) env fvs in + let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in + let na = match na with + | Anonymous -> + if global_level then na + else + let name = + let id = + match ty with + | CApp (_, (_, CRef (Ident (loc,id))), _) -> id + | _ -> id_of_string "H" + in Implicit_quantifiers.make_fresh ids' (Global.env ()) id + in Name name + | _ -> na + in (push_name_env ~global_level lvar env' (loc,na)), (na,b',None,ty') :: List.rev bl + +let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function + | LocalRawAssum(nal,bk,ty) -> + (match bk with + | Default k -> + let (loc,na) = List.hd nal in + (* TODO: fail if several names with different implicit types *) + let ty = locate_if_isevar loc na (intern_type env ty) in + List.fold_left + (fun (env,bl) na -> + (push_name_env lvar env na,(snd na,k,None,ty)::bl)) + (env,bl) nal + | Generalized (b,b',t) -> + let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in + env, b @ bl) + | LocalRawDef((loc,na as locna),def) -> + (push_name_env lvar env locna, + (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl) + +let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c = + let c = intern (ids,true,tmp_scope,scopes) c in + let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids c in + let env', c' = + let abs = + let pi = + match ak with + | Some AbsPi -> true + | None when tmp_scope = Some Notation.type_scope + || List.mem Notation.type_scope scopes -> true + | _ -> false + in + if pi then + (fun (id, loc') acc -> + RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) + else + (fun (id, loc') acc -> + RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) + in + List.fold_right (fun (id, loc as lid) (env, acc) -> + let env' = push_name_env lvar env (loc, Name id) in + (env', abs lid acc)) fvs (env,c) + in c' + +let iterate_binder intern lvar (env,bl) = function + | LocalRawAssum(nal,bk,ty) -> + let intern_type env = intern (set_type_scope env) in + (match bk with + | Default k -> + let (loc,na) = List.hd nal in + (* TODO: fail if several names with different implicit types *) + let ty = intern_type env ty in + let ty = locate_if_isevar loc na ty in + List.fold_left + (fun (env,bl) na -> (push_name_env lvar env na,(snd na,k,None,ty)::bl)) + (env,bl) nal + | Generalized (b,b',t) -> + let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in + env, b @ bl) + | LocalRawDef((loc,na as locna),def) -> + (push_name_env lvar env locna, + (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl) (**********************************************************************) (* Syntax extensions *) -let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env))= +let option_mem_assoc id = function + | Some (id',c) -> id = id' + | None -> false + +let find_fresh_name renaming (terms,termlists,binders) id = + let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) terms in + let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in + let fvs3 = List.map snd renaming in + (* TODO binders *) + let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in + next_ident_away id fvs + +let traverse_binder (terms,_,_ as subst) + (renaming,(ids,unb,tmpsc,scopes as env))= function | Anonymous -> (renaming,env),Anonymous | Name id -> try (* Binders bound in the notation are considered first-order objects *) - let _,na = coerce_to_name (fst (List.assoc id subst)) in + let _,na = coerce_to_name (fst (List.assoc id terms)) in (renaming,(name_fold Idset.add na ids,unb,tmpsc,scopes)), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) - let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) subst in - let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) substlist) in - let fvs3 = List.map snd renaming in - let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in - let id' = next_ident_away id fvs in + let id' = find_fresh_name renaming subst id in let renaming' = if id=id' then renaming else (id,id')::renaming in (renaming',env), Name id' @@ -294,17 +462,18 @@ let rec subst_iterator y t = function | RVar (_,id) as x -> if id = y then t else x | x -> map_rawconstr (subst_iterator y t) x -let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c = - let (renaming,(ids,unb,_,scopes)) = infos in - let subinfos = renaming,(ids,unb,None,scopes) in - match c with - | AVar id -> +let subst_aconstr_in_rawconstr loc intern lvar subst infos c = + let (terms,termlists,binders) = subst in + let rec aux (terms,binderopt as subst') (renaming,(ids,unb,_,scopes as env)) c = + let subinfos = renaming,(ids,unb,None,scopes) in + match c with + | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try - let (a,(scopt,subscopes)) = List.assoc id subst in - interp (ids,unb,scopt,subscopes@scopes) a + let (a,(scopt,subscopes)) = List.assoc id terms in + intern (ids,unb,scopt,subscopes@scopes) a with Not_found -> try RVar (loc,List.assoc id renaming) @@ -312,83 +481,96 @@ let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c = (* Happens for local notation joint with inductive/fixpoint defs *) RVar (loc,id) end - | AList (x,_,iter,terminator,lassoc) -> + | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (l,(scopt,subscopes)) = List.assoc x substlist in - let termin = - subst_aconstr_in_rawconstr loc interp sub subinfos terminator in + let (l,(scopt,subscopes)) = List.assoc x termlists in + let termin = aux subst' subinfos terminator in List.fold_right (fun a t -> subst_iterator ldots_var t - (subst_aconstr_in_rawconstr loc interp - ((x,(a,(scopt,subscopes)))::subst,substlist) subinfos iter)) + (aux ((x,(a,(scopt,subscopes)))::terms,binderopt) subinfos iter)) (if lassoc then List.rev l else l) termin with Not_found -> anomaly "Inconsistent substitution of recursive notation") - | AHole (Evd.BinderType (Name id as na)) -> + | AHole (Evd.BinderType (Name id as na)) -> let na = - try snd (coerce_to_name (fst (List.assoc id subst))) + try snd (coerce_to_name (fst (List.assoc id terms))) with Not_found -> na in RHole (loc,Evd.BinderType na) - | t -> - rawconstr_of_aconstr_with_binders loc (traverse_binder sub) - (subst_aconstr_in_rawconstr loc interp sub) subinfos t - -let intern_notation intern (_,_,tmp_scope,scopes as env) loc ntn fullargs = - let ntn,(args,argslist as fullargs) = contract_notation ntn fullargs in - let (((ids,idsl),c),df) = interp_notation loc ntn (tmp_scope,scopes) in + | ABinderList (x,_,iter,terminator) -> + (try + (* All elements of the list are in scopes (scopt,subscopes) *) + let (bl,(scopt,subscopes)) = List.assoc x binders in + let env,bl = List.fold_left (iterate_binder intern lvar) (env,[]) bl in + let termin = aux subst' (renaming,env) terminator in + List.fold_left (fun t binder -> + subst_iterator ldots_var t + (aux (terms,Some(x,binder)) subinfos iter)) + termin bl + with Not_found -> + anomaly "Inconsistent substitution of recursive notation") + | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt -> + let (na,bk,_,t) = snd (Option.get binderopt) in + RProd (loc,na,bk,t,aux subst' infos c') + | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt -> + let (na,bk,_,t) = snd (Option.get binderopt) in + RLambda (loc,na,bk,t,aux subst' infos c') + | t -> + rawconstr_of_aconstr_with_binders loc (traverse_binder subst) + (aux subst') subinfos t + in aux (terms,None) infos c + +let split_by_type ids = + List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> + match typ with + | NtnTypeConstr -> ((x,scl)::l1,l2,l3) + | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) + | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) + +let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l + +let intern_notation intern (_,_,tmp_scope,scopes as env) lvar loc ntn fullargs = + let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in + let ((ids,c),df) = interp_notation loc ntn (tmp_scope,scopes) in Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df; - let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in - let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl argslist in - subst_aconstr_in_rawconstr loc intern (subst,substlist) ([],env) c - -let set_type_scope (ids,unb,tmp_scope,scopes) = - (ids,unb,Some Notation.type_scope,scopes) - -let reset_tmp_scope (ids,unb,tmp_scope,scopes) = - (ids,unb,None,scopes) - -let rec it_mkRProd env body = - match env with - (na, bk, _, t) :: tl -> it_mkRProd tl (RProd (dummy_loc, na, bk, t, body)) - | [] -> body - -let rec it_mkRLambda env body = - match env with - (na, bk, _, t) :: tl -> it_mkRLambda tl (RLambda (dummy_loc, na, bk, t, body)) - | [] -> body + let ids,idsl,idsbl = split_by_type ids in + let terms = make_subst ids args in + let termlists = make_subst idsl argslist in + let binders = make_subst idsbl bll in + subst_aconstr_in_rawconstr loc intern lvar + (terms,termlists,binders) ([],env) c (**********************************************************************) (* Discriminating between bound variables and global references *) -(* [vars1] is a set of name to avoid (used for the tactic language); - [vars2] is the set of global variables, env is the set of variables - abstracted until this point *) - let string_of_ty = function - | Inductive -> "ind" + | Inductive _ -> "ind" | Recursive -> "def" | Method -> "meth" -let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id = - let (vars1,unbndltacvars) = ltacvars in +let intern_var (ids,_,_,_ as genv) (ltacvars,namedctxvars,ntnvars,impls) loc id = + let (ltacvars,unbndltacvars) = ltacvars in (* Is [id] an inductive type potentially with implicit *) try - let ty,l,impl,argsc = List.assoc id impls in - let l = List.map - (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in + let ty,expl_impls,impls,argsc = List.assoc id impls in + let expl_impls = List.map + (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in let tys = string_of_ty ty in - Dumpglob.dump_reference loc "<>" (string_of_id id) tys; - RVar (loc,id), impl, argsc, l + Dumpglob.dump_reference loc "<>" (string_of_id id) tys; + RVar (loc,id), impls, argsc, expl_impls with Not_found -> - (* Is [id] bound in current env or is an ltac var bound to constr *) - if Idset.mem id env or List.mem id vars1 + (* Is [id] bound in current term or is an ltac var bound to constr *) + if Idset.mem id ids or List.mem id ltacvars then RVar (loc,id), [], [], [] (* Is [id] a notation variable *) - else if List.mem_assoc id vars3 + else if List.mem_assoc id ntnvars + then + (set_var_scope loc id true genv ntnvars; RVar (loc,id), [], [], []) + (* Is [id] the special variable for recursive notations *) + else if ntnvars <> [] && id = ldots_var then - (set_var_scope loc id genv vars3; RVar (loc,id), [], [], []) + RVar (loc,id), [], [], [] else (* Is [id] bound to a free name in ltac (this is an ltac error message) *) try @@ -398,7 +580,7 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 with Not_found -> (* Is [id] a goal or section variable *) - let _ = Sign.lookup_named id vars2 in + let _ = Sign.lookup_named id namedctxvars in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) @@ -443,7 +625,7 @@ let intern_reference ref = (intern_extended_global_of_qualid (qualid_of_reference ref)) (* Is it a global reference or a syntactic definition? *) -let intern_qualid loc qid intern env args = +let intern_qualid loc qid intern env lvar args = match intern_extended_global_of_qualid (loc,qid) with | TrueGlobal ref -> RRef (loc, ref), args @@ -453,25 +635,25 @@ let intern_qualid loc qid intern env args = if List.length args < nids then error_not_enough_arguments loc; let args1,args2 = list_chop nids args in check_no_explicitation args1; - let subst = List.map2 (fun (id,scl) a -> (id,(fst a,scl))) ids args1 in - subst_aconstr_in_rawconstr loc intern (subst,[]) ([],env) c, args2 + let subst = make_subst ids (List.map fst args1) in + subst_aconstr_in_rawconstr loc intern lvar (subst,[],[]) ([],env) c, args2 (* Rule out section vars since these should have been found by intern_var *) -let intern_non_secvar_qualid loc qid intern env args = - match intern_qualid loc qid intern env args with +let intern_non_secvar_qualid loc qid intern env lvar args = + match intern_qualid loc qid intern env lvar args with | RRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid | r -> r let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function | Qualid (loc, qid) -> - let r,args2 = intern_qualid loc qid intern env args in + let r,args2 = intern_qualid loc qid intern env lvar args in find_appl_head_data r, args2 | Ident (loc, id) -> try intern_var env lvar loc id, args with Not_found -> let qid = qualid_of_ident id in try - let r,args2 = intern_non_secvar_qualid loc qid intern env args in + let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in find_appl_head_data r, args2 with e -> (* Extra allowance for non globalizing functions *) @@ -482,7 +664,7 @@ let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc) - (Idset.empty,false,None,[]) (vars,[],[],([],[])) [] r + (Idset.empty,false,None,[]) (vars,[],[],[]) [] r in r let apply_scope_env (ids,unb,_,scopes) = function @@ -529,14 +711,14 @@ let loc_of_lhs lhs = let check_linearity lhs ids = match has_duplicate ids with | Some id -> - raise (InternalisationError (loc_of_lhs lhs,NonLinearPattern id)) + raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) | None -> () (* Match the number of pattern against the number of matched args *) let check_number_of_pattern loc n l = let p = List.length l in - if n<>p then raise (InternalisationError (loc,BadPatternsNumber (n,p))) + if n<>p then raise (InternalizationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then @@ -646,7 +828,7 @@ let find_constructor ref f aliases pats scopes = let (loc,qid) = qualid_of_reference ref in let gref = try locate_extended qid - with Not_found -> raise (InternalisationError (loc,NotAConstructor ref)) in + with Not_found -> raise (InternalizationError (loc,NotAConstructor ref)) in match gref with | SynDef sp -> let (vars,a) = Syntax_def.search_syntactic_definition sp in @@ -677,7 +859,7 @@ let find_constructor ref f aliases pats scopes = let find_pattern_variable = function | Ident (loc,id) -> id - | Qualid (loc,_) as x -> raise (InternalisationError(loc,NotAConstructor x)) + | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) let maybe_constructor ref f aliases scopes = try @@ -686,7 +868,7 @@ let maybe_constructor ref f aliases scopes = ConstrPat (c,idspl1) with (* patt var does not exists globally *) - | InternalisationError _ -> VarPat (find_pattern_variable ref) + | InternalizationError _ -> VarPat (find_pattern_variable ref) (* patt var also exists globally but does not satisfy preconditions *) | (Environ.NotEvaluableConst _ | Not_found) -> if_verbose msg_warning (str "pattern " ++ pr_reference ref ++ @@ -696,7 +878,7 @@ let maybe_constructor ref f aliases scopes = let mustbe_constructor loc ref f aliases patl scopes = try find_constructor ref f aliases patl scopes with (Environ.NotEvaluableConst _ | Not_found) -> - raise (InternalisationError (loc,NotAConstructor ref)) + raise (InternalizationError (loc,NotAConstructor ref)) let sort_fields mode loc l completer = (*mode=false if pattern and true if constructor*) @@ -813,7 +995,8 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= intern_pat scopes aliases tmp_scope a | CPatNotation (loc, ntn, fullargs) -> let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in - let (((ids',idsl'),c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in + let ((ids',c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in + let (ids',idsl',_) = split_by_type ids' in Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df; let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in @@ -849,116 +1032,6 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= (ids,List.flatten pl') (**********************************************************************) -(* Fix and CoFix *) - -(**********************************************************************) -(* Utilities for binders *) - -let check_capture loc ty = function - | Name id when occur_var_constr_expr id ty -> - raise (InternalisationError (loc,VariableCapture id)) - | _ -> - () - -let locate_if_isevar loc na = function - | RHole _ -> - (try match na with - | Name id -> Reserve.find_reserved_type id - | Anonymous -> raise Not_found - with Not_found -> RHole (loc, Evd.BinderType na)) - | x -> x - -let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) = - if List.mem id indnames then - errorlabstrm "" (strbrk "A parameter or name of an inductive type " ++ - pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.") - -let push_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) = function - | Anonymous -> - if fail_anonymous then errorlabstrm "" (str "Anonymous variables not allowed"); - env - | Name id -> - check_hidden_implicit_parameters id lvar; - (Idset.add id ids, unb,tmpsc,scopes) - -let push_loc_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) loc = function - | Anonymous -> - if fail_anonymous then user_err_loc (loc,"", str "Anonymous variables not allowed"); - env - | Name id -> - check_hidden_implicit_parameters id lvar; - Dumpglob.dump_binding loc id; - (Idset.add id ids,unb,tmpsc,scopes) - -let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar - (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty = - let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in - let ty, ids' = - if t then ty, ids else - Implicit_quantifiers.implicit_application ids - Implicit_quantifiers.combine_params_freevar ty - in - let ty' = intern_type (ids,true,tmpsc,sc) ty in - let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in - let env' = List.fold_left (fun env (x, l) -> push_loc_name_env ~fail_anonymous lvar env l (Name x)) env fvs in - let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in - let na = match na with - | Anonymous -> - if fail_anonymous then na - else - let name = - let id = - match ty with - | CApp (_, (_, CRef (Ident (loc,id))), _) -> id - | _ -> id_of_string "H" - in Implicit_quantifiers.make_fresh ids' (Global.env ()) id - in Name name - | _ -> na - in (push_loc_name_env ~fail_anonymous lvar env' loc na), (na,b',None,ty') :: List.rev bl - -let intern_local_binder_aux ?(fail_anonymous=false) intern intern_type lvar ((ids,unb,ts,sc as env),bl) = function - | LocalRawAssum(nal,bk,ty) -> - (match bk with - | Default k -> - let (loc,na) = List.hd nal in - (* TODO: fail if several names with different implicit types *) - let ty = locate_if_isevar loc na (intern_type env ty) in - List.fold_left - (fun ((ids,unb,ts,sc),bl) (_,na) -> - ((name_fold Idset.add na ids,unb,ts,sc), (na,k,None,ty)::bl)) - (env,bl) nal - | Generalized (b,b',t) -> - let env, b = intern_generalized_binder ~fail_anonymous intern_type lvar env bl (List.hd nal) b b' t ty in - env, b @ bl) - | LocalRawDef((loc,na),def) -> - ((name_fold Idset.add na ids,unb,ts,sc), - (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl) - -let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c = - let c = intern (ids,true,tmp_scope,scopes) c in - let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids c in - let env', c' = - let abs = - let pi = - match ak with - | Some AbsPi -> true - | None when tmp_scope = Some Notation.type_scope - || List.mem Notation.type_scope scopes -> true - | _ -> false - in - if pi then - (fun (id, loc') acc -> - RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) - else - (fun (id, loc') acc -> - RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) - in - List.fold_right (fun (id, loc as lid) (env, acc) -> - let env' = push_loc_name_env lvar env loc (Name id) in - (env', abs lid acc)) fvs (env,c) - in c' - -(**********************************************************************) (* Utilities for application *) let merge_impargs l args = @@ -1030,7 +1103,7 @@ let extract_explicit_arg imps args = (**********************************************************************) (* Main loop *) -let internalise sigma globalenv env allow_patvar lvar c = +let internalize sigma globalenv env allow_patvar lvar c = let rec intern (ids,unb,tmp_scope,scopes as env) = function | CRef ref as x -> let (c,imp,subscopes,l),_ = @@ -1044,17 +1117,16 @@ let internalise sigma globalenv env allow_patvar lvar c = let n = try list_index0 iddef lf with Not_found -> - raise (InternalisationError (locid,UnboundFixName (false,iddef))) + raise (InternalizationError (locid,UnboundFixName (false,iddef))) in let idl = Array.map (fun (id,(n,order),bl,ty,bd) -> let intern_ro_arg f = - let idx = Option.default 0 (index_of_annot bl n) in - let before, after = list_chop idx bl in + let before, after = split_at_annot bl n in let ((ids',_,_,_) as env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern (ids', unb, tmp_scope, scopes)) in - let n' = Option.map (fun _ -> List.length before) n in + let n' = Option.map (fun _ -> List.length rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, ((ids',_,_,_),rbl) = @@ -1082,7 +1154,7 @@ let internalise sigma globalenv env allow_patvar lvar c = let n = try list_index0 iddef lf with Not_found -> - raise (InternalisationError (locid,UnboundFixName (true,iddef))) + raise (InternalizationError (locid,UnboundFixName (true,iddef))) in let idl = Array.map (fun (id,bl,ty,bd) -> @@ -1107,15 +1179,15 @@ let internalise sigma globalenv env allow_patvar lvar c = intern env c2 | CLambdaN (loc,(nal,bk,ty)::bll,c2) -> iterate_lam loc (reset_tmp_scope env) bk ty (CLambdaN (loc, bll, c2)) nal - | CLetIn (loc,(loc1,na),c1,c2) -> - RLetIn (loc, na, intern (reset_tmp_scope env) c1, - intern (push_loc_name_env lvar env loc1 na) c2) - | CNotation (loc,"- _",([CPrim (_,Numeral p)],[])) + | CLetIn (loc,na,c1,c2) -> + RLetIn (loc, snd na, intern (reset_tmp_scope env) c1, + intern (push_name_env lvar env na) c2) + | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[])) when Bigint.is_strictly_pos p -> intern env (CPrim (loc,Numeral (Bigint.neg p))) - | CNotation (_,"( _ )",([a],[])) -> intern env a + | CNotation (_,"( _ )",([a],[],[])) -> intern env a | CNotation (loc,ntn,args) -> - intern_notation intern env loc ntn args + intern_notation intern env lvar loc ntn args | CGeneralization (loc,b,a,c) -> intern_generalization intern env lvar loc b a c | CPrim (loc, p) -> @@ -1138,8 +1210,8 @@ let internalise sigma globalenv env allow_patvar lvar c = let (c,impargs,args_scopes,l),args = match f with | CRef ref -> intern_applied_reference intern env lvar args ref - | CNotation (loc,ntn,([],[])) -> - let c = intern_notation intern env loc ntn ([],[]) in + | CNotation (loc,ntn,([],[],[])) -> + let c = intern_notation intern env lvar loc ntn ([],[],[]) in find_appl_head_data c, args | x -> (intern env f,[],[],[]), args in let args = @@ -1177,7 +1249,7 @@ let internalise sigma globalenv env allow_patvar lvar c = let p' = Option.map (fun p -> let env'' = List.fold_left (push_name_env lvar) env ids in intern_type env'' p) po in - RLetTuple (loc, nal, (na', p'), b', + RLetTuple (loc, List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env lvar) env nal) c) | CIf (loc, c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in @@ -1191,7 +1263,7 @@ let internalise sigma globalenv env allow_patvar lvar c = | CPatVar (loc, n) when allow_patvar -> RPatVar (loc, n) | CPatVar (loc, _) -> - raise (InternalisationError (loc,IllegalMetavariable)) + raise (InternalizationError (loc,IllegalMetavariable)) | CEvar (loc, n, l) -> REvar (loc, n, Option.map (List.map (intern env)) l) | CSort (loc, s) -> @@ -1252,27 +1324,27 @@ let internalise sigma globalenv env allow_patvar lvar c = if List.length l <> nindargs then error_wrong_numarg_inductive_loc loc globalenv ind nindargs; let nal = List.map (function - | RHole loc -> Anonymous - | RVar (_,id) -> Name id + | RHole (loc,_) -> loc,Anonymous + | RVar (loc,id) -> loc,Name id | c -> user_err_loc (loc_of_rawconstr c,"",str "Not a name.")) l in let parnal,realnal = list_chop nparams nal in - if List.exists ((<>) Anonymous) parnal then + if List.exists (fun (_,na) -> na <> Anonymous) parnal then error_inductive_parameter_not_implicit loc; - realnal, Some (loc,ind,nparams,realnal) + realnal, Some (loc,ind,nparams,List.map snd realnal) | None -> [], None in let na = match tm', na with - | RVar (_,id), None when Idset.mem id vars -> Name id - | RRef (loc, VarRef id), None -> Name id - | _, None -> Anonymous - | _, Some na -> na in - (tm',(na,typ)), na::ids + | RVar (loc,id), None when Idset.mem id vars -> loc,Name id + | RRef (loc, VarRef id), None -> loc,Name id + | _, None -> dummy_loc,Anonymous + | _, Some (loc,na) -> loc,na in + (tm',(snd na,typ)), na::ids and iterate_prod loc2 env bk ty body nal = let rec default env bk = function - | (loc1,na)::nal -> + | (loc1,na as locna)::nal -> if nal <> [] then check_capture loc1 ty na; - let body = default (push_loc_name_env lvar env loc1 na) bk nal in + let body = default (push_name_env lvar env locna) bk nal in let ty = locate_if_isevar loc1 na (intern_type env ty) in RProd (join_loc loc1 loc2, na, bk, ty, body) | [] -> intern_type env body @@ -1280,24 +1352,22 @@ let internalise sigma globalenv env allow_patvar lvar c = match bk with | Default b -> default env b nal | Generalized (b,b',t) -> - let env, ibind = intern_generalized_binder intern_type lvar - env [] (List.hd nal) b b' t ty in + let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern_type env body in it_mkRProd ibind body and iterate_lam loc2 env bk ty body nal = let rec default env bk = function - | (loc1,na)::nal -> + | (loc1,na as locna)::nal -> if nal <> [] then check_capture loc1 ty na; - let body = default (push_loc_name_env lvar env loc1 na) bk nal in + let body = default (push_name_env lvar env locna) bk nal in let ty = locate_if_isevar loc1 na (intern_type env ty) in RLambda (join_loc loc1 loc2, na, bk, ty, body) | [] -> intern env body in match bk with | Default b -> default env b nal | Generalized (b, b', t) -> - let env, ibind = intern_generalized_binder intern_type lvar - env [] (List.hd nal) b b' t ty in + let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern env body in it_mkRLambda ibind body @@ -1345,9 +1415,9 @@ let internalise sigma globalenv env allow_patvar lvar c = try intern env c with - InternalisationError (loc,e) -> + InternalizationError (loc,e) -> user_err_loc (loc,"internalize", - explain_internalisation_error e) + explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into rawconstr *) @@ -1359,11 +1429,11 @@ let extract_ids env = Idset.empty let intern_gen isarity sigma env - ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) + ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let tmp_scope = if isarity then Some Notation.type_scope else None in - internalise sigma env (extract_ids env, false, tmp_scope,[]) + internalize sigma env (extract_ids env, false, tmp_scope,[]) allow_patvar (ltacvars,Environ.named_context env, [], impls) c let intern_constr sigma env c = intern_gen false sigma env c @@ -1374,8 +1444,8 @@ let intern_pattern env patt = try intern_cases_pattern env [] ([],[]) None patt with - InternalisationError (loc,e) -> - user_err_loc (loc,"internalize",explain_internalisation_error e) + InternalizationError (loc,e) -> + user_err_loc (loc,"internalize",explain_internalization_error e) type manual_implicits = (explicitation * (bool * bool * bool)) list @@ -1384,7 +1454,7 @@ type manual_implicits = (explicitation * (bool * bool * bool)) list (* Functions to parse and interpret constructions *) let interp_gen kind sigma env - ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) + ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in Default.understand_gen kind sigma env c @@ -1392,10 +1462,10 @@ let interp_gen kind sigma env let interp_constr sigma env c = interp_gen (OfType None) sigma env c -let interp_type sigma env ?(impls=([],[])) c = +let interp_type sigma env ?(impls=[]) c = interp_gen IsType sigma env ~impls c -let interp_casted_constr sigma env ?(impls=([],[])) c typ = +let interp_casted_constr sigma env ?(impls=[]) c typ = interp_gen (OfType (Some typ)) sigma env ~impls c let interp_open_constr sigma env c = @@ -1423,34 +1493,35 @@ let interp_constr_judgment sigma env c = Default.understand_judgment sigma env (intern_constr sigma env c) let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true) - env ?(impls=([],[])) kind c = + env ?(impls=[]) kind c = let evdref = match evdref with | None -> ref Evd.empty | Some evdref -> evdref in - let c = intern_gen (kind=IsType) ~impls !evdref env c in - let imps = Implicit_quantifiers.implicits_of_rawterm c in + let istype = kind = IsType in + let c = intern_gen istype ~impls !evdref env c in + let imps = Implicit_quantifiers.implicits_of_rawterm ~with_products:istype c in Default.understand_tcc_evars ~fail_evar evdref env kind c, imps let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true) - env ?(impls=([],[])) c typ = + env ?(impls=[]) c typ = interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c -let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c = +let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c = interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c -let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c = +let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c = interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c -let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c = +let interp_constr_evars_gen evdref env ?(impls=[]) kind c = let c = intern_gen (kind=IsType) ~impls ( !evdref) env c in Default.understand_tcc_evars evdref env kind c -let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ = +let interp_casted_constr_evars evdref env ?(impls=[]) c typ = interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c -let interp_type_evars evdref env ?(impls=([],[])) c = +let interp_type_evars evdref env ?(impls=[]) c = interp_constr_evars_gen evdref env IsType ~impls c type ltac_sign = identifier list * unbound_ltac_var_map @@ -1459,19 +1530,20 @@ let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c = let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in pattern_of_rawconstr c -let interp_aconstr ?(impls=([],[])) (vars,varslist) a = +let interp_aconstr ?(impls=[]) vars recvars a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = List.map (fun id -> (id,ref None)) (vars@varslist) in - let c = internalise Evd.empty (Global.env()) (extract_ids env, false, None, []) + let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in + let c = internalize Evd.empty (Global.env()) (extract_ids env, false, None, []) false (([],[]),Environ.named_context env,vl,impls) a in (* Translate and check that [c] has all its free variables bound in [vars] *) - let a = aconstr_of_rawconstr vars c in + let a = aconstr_of_rawconstr vars recvars c in + (* Splits variables into those that are binding, bound, or both *) + (* binding and bound *) + let out_scope = function None -> None,[] | Some (a,l) -> a,l in + let vars = List.map (fun (id,(sc,typ)) -> (id,(out_scope !sc,typ))) vl in (* Returns [a] and the ordered list of variables with their scopes *) - (* Variables occurring in binders have no relevant scope since bound *) - let vl = List.map (fun (id,r) -> - (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl in - list_chop (List.length vars) vl, a + vars, a (* Interpret binders and contexts *) @@ -1489,14 +1561,14 @@ open Environ open Term let my_intern_constr sigma env lvar acc c = - internalise sigma env acc false lvar c + internalize sigma env acc false lvar c let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c -let intern_context fail_anonymous sigma env params = - let lvar = (([],[]),Environ.named_context env, [], ([], [])) in +let intern_context global_level sigma env params = + let lvar = (([],[]),Environ.named_context env, [], []) in snd (List.fold_left - (intern_local_binder_aux ~fail_anonymous (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) + (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) ((extract_ids env,false,None,[]), []) params) let interp_rawcontext_gen understand_type understand_judgment env bl = @@ -1522,15 +1594,15 @@ let interp_rawcontext_gen understand_type understand_judgment env bl = (env,[],1,[]) (List.rev bl) in (env, par), impls -let interp_context_gen understand_type understand_judgment ?(fail_anonymous=false) sigma env params = - let bl = intern_context fail_anonymous sigma env params in +let interp_context_gen understand_type understand_judgment ?(global_level=false) sigma env params = + let bl = intern_context global_level sigma env params in interp_rawcontext_gen understand_type understand_judgment env bl -let interp_context ?(fail_anonymous=false) sigma env params = +let interp_context ?(global_level=false) sigma env params = interp_context_gen (Default.understand_type sigma) - (Default.understand_judgment sigma) ~fail_anonymous sigma env params + (Default.understand_judgment sigma) ~global_level sigma env params -let interp_context_evars ?(fail_anonymous=false) evdref env params = +let interp_context_evars ?(global_level=false) evdref env params = interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t) - (Default.understand_judgment_tcc evdref) ~fail_anonymous !evdref env params + (Default.understand_judgment_tcc evdref) ~global_level !evdref env params diff --git a/interp/constrintern.mli b/interp/constrintern.mli index ebee4eda..acb13a8b 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: constrintern.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) (*i*) open Names @@ -30,45 +30,45 @@ open Pretyping - check all variables are bound - make absolute the references to global objets - resolution of symbolic notations using scopes - - insert existential variables for implicit arguments + - insertion of implicit arguments *) -(* To interpret implicits and arg scopes of recursive variables while - internalizing inductive types and recursive definitions, and also +(* To interpret implicit arguments and arg scopes of recursive variables + while internalizing inductive types and recursive definitions, and also projection while typing records. the third and fourth arguments associate a list of implicit positions and scopes to identifiers declared in the [rel_context] of [env] *) -type var_internalization_type = Inductive | Recursive | Method +type var_internalization_type = + | Inductive of identifier list (* list of params *) + | Recursive + | Method type var_internalization_data = var_internalization_type * + (* type of the "free" variable, for coqdoc, e.g. while typing the + constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) identifier list * - Impargs.implicits_list * - scope_name option list + (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" + in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) + Impargs.implicits_list * (* signature of impargs of the variable *) + scope_name option list (* subscopes of the args of the variable *) (* A map of free variables to their implicit arguments and scopes *) type internalization_env = (identifier * var_internalization_data) list (* Contains also a list of identifiers to automatically apply to the variables*) -type full_internalization_env = - identifier list * internalization_env - -val empty_internalization_env : full_internalization_env +val empty_internalization_env : internalization_env val compute_internalization_data : env -> var_internalization_type -> types -> Impargs.manual_explicitation list -> var_internalization_data -val set_internalization_env_params : - internalization_env -> identifier list -> full_internalization_env - -val compute_full_internalization_env : env -> - var_internalization_type -> - identifier list -> identifier list -> types list -> - Impargs.manual_explicitation list list -> full_internalization_env +val compute_internalization_env : env -> var_internalization_type -> + identifier list -> types list -> Impargs.manual_explicitation list list -> + internalization_env type manual_implicits = (explicitation * (bool * bool * bool)) list @@ -83,7 +83,7 @@ val intern_constr : evar_map -> env -> constr_expr -> rawconstr val intern_type : evar_map -> env -> constr_expr -> rawconstr val intern_gen : bool -> evar_map -> env -> - ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> + ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> rawconstr val intern_pattern : env -> cases_pattern_expr -> @@ -97,7 +97,7 @@ val intern_context : bool -> evar_map -> env -> local_binder list -> raw_binder (* Main interpretation function *) val interp_gen : typing_constraint -> evar_map -> env -> - ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> + ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> constr (* Particular instances *) @@ -105,33 +105,33 @@ val interp_gen : typing_constraint -> evar_map -> env -> val interp_constr : evar_map -> env -> constr_expr -> constr -val interp_type : evar_map -> env -> ?impls:full_internalization_env -> - constr_expr -> types +val interp_type : evar_map -> env -> ?impls:internalization_env -> + constr_expr -> types val interp_open_constr : evar_map -> env -> constr_expr -> evar_map * constr val interp_open_constr_patvar : evar_map -> env -> constr_expr -> evar_map * constr -val interp_casted_constr : evar_map -> env -> ?impls:full_internalization_env -> +val interp_casted_constr : evar_map -> env -> ?impls:internalization_env -> constr_expr -> types -> constr (* Accepting evars and giving back the manual implicits in addition. *) val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env -> - ?impls:full_internalization_env -> constr_expr -> types -> constr * manual_implicits + ?impls:internalization_env -> constr_expr -> types -> constr * manual_implicits val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> - env -> ?impls:full_internalization_env -> + env -> ?impls:internalization_env -> constr_expr -> types * manual_implicits val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> - env -> ?impls:full_internalization_env -> + env -> ?impls:internalization_env -> constr_expr -> constr * manual_implicits val interp_casted_constr_evars : evar_map ref -> env -> - ?impls:full_internalization_env -> constr_expr -> types -> constr + ?impls:internalization_env -> constr_expr -> types -> constr -val interp_type_evars : evar_map ref -> env -> ?impls:full_internalization_env -> +val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env -> constr_expr -> types (*s Build a judgment *) @@ -160,13 +160,13 @@ val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types val interp_context_gen : (env -> rawconstr -> types) -> (env -> rawconstr -> unsafe_judgment) -> - ?fail_anonymous:bool -> + ?global_level:bool -> evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits -val interp_context : ?fail_anonymous:bool -> +val interp_context : ?global_level:bool -> evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits -val interp_context_evars : ?fail_anonymous:bool -> +val interp_context_evars : ?global_level:bool -> evar_map ref -> env -> local_binder list -> (env * rel_context) * manual_implicits (* Locating references of constructions, possibly via a syntactic definition *) @@ -177,10 +177,15 @@ val construct_reference : named_context -> identifier -> constr val global_reference : identifier -> constr val global_reference_in_absolute_module : dir_path -> identifier -> constr -(* Interprets into a abbreviatable constr *) +(* Interprets a term as the left-hand side of a notation; the boolean + list is a set and this set is [true] for a variable occurring in + term position, [false] for a variable occurring in binding + position; [true;false] if in both kinds of position *) -val interp_aconstr : ?impls:full_internalization_env -> - identifier list * identifier list -> constr_expr -> interpretation +val interp_aconstr : ?impls:internalization_env -> + (identifier * notation_var_internalization_type) list -> + (identifier * identifier) list -> constr_expr -> + (identifier * (subscopes * notation_var_internalization_type)) list * aconstr (* Globalization leak for Grammar *) val for_grammar : ('a -> 'b) -> 'a -> 'b diff --git a/interp/coqlib.ml b/interp/coqlib.ml index dbec915d..0848ccc7 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqlib.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Util open Pp @@ -182,14 +182,11 @@ type coq_bool_data = { andb_prop : constr; andb_true_intro : constr} -type 'a delayed = unit -> 'a - let build_bool_type () = { andb = init_constant ["Datatypes"] "andb"; andb_prop = init_constant ["Datatypes"] "andb_prop"; andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" } - let build_sigma_set () = anomaly "Use build_sigma_type" let build_sigma_type () = diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 12791139..81cc3baa 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coqlib.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Names @@ -14,6 +14,7 @@ open Libnames open Nametab open Term open Pattern +open Util (*i*) (*s This module collects the global references, constructions and @@ -86,9 +87,8 @@ val glob_jmeq : global_reference at compile time. Therefore, we can only provide methods to build them at runtime. This is the purpose of the [constr delayed] and [constr_pattern delayed] types. Objects of this time needs to be - applied to [()] to get the actual constr or pattern at runtime *) - -type 'a delayed = unit -> 'a + forced with [delayed_force] to get the actual constr or pattern + at runtime. *) type coq_bool_data = { andb : constr; diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index ec02146e..0a42b78b 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: dumpglob.ml 13328 2010-07-26 11:05:30Z herbelin $ *) (* Dump of globalization (to be used by coqdoc) *) @@ -161,13 +161,6 @@ let dump_name (loc, n) sec ty = | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () -let dump_local_binder b sec ty = - if dump () then - match b with - | Topconstr.LocalRawAssum (nl, _, _) -> - List.iter (fun x -> dump_name x sec ty) nl - | Topconstr.LocalRawDef _ -> () - let dump_modref loc mp ty = if dump () then let (dp, l) = Lib.split_modpath mp in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 2d5b1468..049bad5a 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: dumpglob.mli 13328 2010-07-26 11:05:30Z herbelin $ *) val open_glob_file : string -> unit @@ -39,7 +39,6 @@ val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation val dump_binding : Util.loc -> Names.Idset.elt -> unit val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit val dump_constraint : Topconstr.typeclass_constraint -> bool -> string -> unit -val dump_local_binder : Topconstr.local_binder -> bool -> string -> unit val dump_string : string -> unit diff --git a/interp/genarg.ml b/interp/genarg.ml index a6a042d6..310420aa 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: genarg.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/interp/genarg.mli b/interp/genarg.mli index f410e1ed..9c9096bb 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: genarg.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Names diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 73e3910a..22075654 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: implicit_quantifiers.ml 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Names @@ -93,7 +93,7 @@ let is_freevar ids env x = with _ -> not (is_global x) with _ -> true -(* Auxilliary functions for the inference of implicitly quantified variables. *) +(* Auxiliary functions for the inference of implicitly quantified variables. *) let ungeneralizable loc id = user_err_loc (loc, "Generalization", @@ -110,7 +110,7 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l = in let rec aux bdvars l c = match c with | CRef (Ident (loc,id)) -> found loc id bdvars l - | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [])) when not (Idset.mem id bdvars) -> + | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c in aux bound l c @@ -297,19 +297,28 @@ let implicit_application env ?(allow_partial=true) f ty = CAppExpl (loc, (None, id), args), avoid in c, avoid -let implicits_of_rawterm l = +let implicits_of_rawterm ?(with_products=true) l = let rec aux i c = - match c with - RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) -> - let rest = aux (succ i) b in - if bk = Implicit then - let name = - match na with - Name id -> Some id - | Anonymous -> None - in - (ExplByPos (i, name), (true, true, true)) :: rest - else rest + let abs loc na bk t b = + let rest = aux (succ i) b in + if bk = Implicit then + let name = + match na with + | Name id -> Some id + | Anonymous -> None + in + (ExplByPos (i, name), (true, true, true)) :: rest + else rest + in + match c with + | RProd (loc, na, bk, t, b) -> + if with_products then abs loc na bk t b + else + (if bk = Implicit then + msg_warning (str "Ignoring implicit status of product binder " ++ + pr_name na ++ str " and following binders"); + []) + | RLambda (loc, na, bk, t, b) -> abs loc na bk t b | RLetIn (loc, na, t, b) -> aux i b | _ -> [] in aux 1 l diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index 315541e2..b8f6594a 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: implicit_quantifiers.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Names @@ -46,7 +46,7 @@ val generalizable_vars_of_rawconstr : ?bound:Idset.t -> ?allowed:Idset.t -> val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier -val implicits_of_rawterm : Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list +val implicits_of_rawterm : ?with_products:bool -> Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list val combine_params_freevar : Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) -> diff --git a/interp/modintern.ml b/interp/modintern.ml index f414adab..bed5597e 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: modintern.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/interp/modintern.mli b/interp/modintern.mli index 304db5be..1cf8a5bd 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: modintern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Declarations diff --git a/interp/notation.ml b/interp/notation.ml index 4a89dbd7..fe9d8b6d 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: notation.ml 13329 2010-07-26 11:05:39Z herbelin $ *) (*i*) open Util @@ -209,7 +209,8 @@ let cases_pattern_key = function let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) | AApp (ARef ref,args) -> RefKey(make_gr ref), Some (List.length args) - | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey (make_gr ref), Some (List.length args) + | AList (_,_,AApp (ARef ref,args),_,_) + | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (make_gr ref), Some (List.length args) | ARef ref -> RefKey(make_gr ref), None | _ -> Oth, None diff --git a/interp/notation.mli b/interp/notation.mli index 533ccb76..72b576eb 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: notation.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 653aefed..618f8320 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ *) +(*i $Id: ppextend.ml 13329 2010-07-26 11:05:39Z herbelin $ *) (*i*) open Pp @@ -53,6 +53,7 @@ let ppcmd_of_cut = function type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list + | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string | UnpBox of ppbox * unparsing list | UnpCut of ppcut diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 7b988786..6c386162 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ppextend.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) (*i*) open Pp @@ -43,6 +43,7 @@ val ppcmd_of_cut : ppcut -> std_ppcmds type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list + | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string | UnpBox of ppbox * unparsing list | UnpCut of ppcut diff --git a/interp/reserve.ml b/interp/reserve.ml index 7f9b35a6..2225bb6e 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: reserve.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Reserved names *) diff --git a/interp/reserve.mli b/interp/reserve.mli index e1853a74..613ba830 100644 --- a/interp/reserve.mli +++ b/interp/reserve.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: reserve.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Names diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index e6bb468e..77b34d4f 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: syntax_def.ml 13329 2010-07-26 11:05:39Z herbelin $ *) open Util open Pp @@ -76,8 +76,8 @@ type syndef_interpretation = (identifier * subscopes) list * aconstr (* Coercions to the general format of notation that also supports variables bound to list of expressions *) -let in_pat (ids,ac) = ((ids,[]),ac) -let out_pat ((ids,idsl),ac) = assert (idsl=[]); (ids,ac) +let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,(sc,NtnTypeConstr))) ids,ac) +let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac) let declare_syntactic_definition local id onlyparse pat = let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 49e74b65..33d4c5d3 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: syntax_def.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 5911f667..b8a90088 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: topconstr.ml 13357 2010-07-29 22:59:55Z herbelin $ *) (*i*) open Pp @@ -36,6 +36,7 @@ type aconstr = (* Part only in rawconstr *) | ALambda of name * aconstr * aconstr | AProd of name * aconstr * aconstr + | ABinderList of identifier * identifier * aconstr * aconstr | ALetIn of name * aconstr * aconstr | ACases of case_style * aconstr option * (aconstr * (name * (inductive * int * name list) option)) list * @@ -50,6 +51,21 @@ type aconstr = | APatVar of patvar | ACast of aconstr * aconstr cast_type +type scope_name = string + +type tmp_scope_name = scope_name + +type subscopes = tmp_scope_name option * scope_name list + +type notation_var_instance_type = + | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList + +type notation_var_internalization_type = + | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent + +type interpretation = + (identifier * (subscopes * notation_var_instance_type)) list * aconstr + (**********************************************************************) (* Re-interpret a notation as a rawconstr, taking care of binders *) @@ -69,6 +85,16 @@ let rec cases_pattern_fold_map loc g e = function let rec subst_rawvars l = function | RVar (_,id) as r -> (try List.assoc id l with Not_found -> r) + | RProd (loc,Name id,bk,t,c) -> + let id = + try match List.assoc id l with RVar(_,id') -> id' | _ -> id + with Not_found -> id in + RProd (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c) + | RLambda (loc,Name id,bk,t,c) -> + let id = + try match List.assoc id l with RVar(_,id') -> id' | _ -> id + with Not_found -> id in + RLambda (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c) | r -> map_rawconstr (subst_rawvars l) r (* assume: id is not binding *) let ldots_var = id_of_string ".." @@ -82,6 +108,12 @@ let rawconstr_of_aconstr_with_binders loc g f e = function let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in let outerl = (ldots_var,inner)::(if swap then [x,RVar(loc,y)] else []) in subst_rawvars outerl it + | ABinderList (x,y,iter,tail) -> + let t = f e tail in let it = f e iter in + let innerl = [(ldots_var,t);(x,RVar(loc,y))] in + let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in + let outerl = [(ldots_var,inner)] in + subst_rawvars outerl it | ALambda (na,ty,c) -> let e,na = g e na in RLambda (loc,na,Explicit,f e ty,f e c) | AProd (na,ty,c) -> @@ -134,72 +166,135 @@ let rec rawconstr_of_aconstr loc x = (****************************************************************************) (* Translating a rawconstr into a notation, interpreting recursive patterns *) -let add_name r = function - | Anonymous -> () - | Name id -> r := id :: !r +let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) +let add_name r = function Anonymous -> () | Name id -> add_id r id -let has_ldots = - List.exists - (function RApp (_,RVar(_,v),_) when v = ldots_var -> true | _ -> false) - -let compare_rawconstr f t1 t2 = match t1,t2 with - | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2 - | RVar (_,v1), RVar (_,v2) -> v1 = v2 - | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & List.for_all2 f l1 l2 - | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> - f ty1 ty2 & f c1 c2 +let split_at_recursive_part c = + let sub = ref None in + let rec aux = function + | RApp (loc0,RVar(loc,v),c::l) when v = ldots_var -> + if !sub <> None then + (* Not narrowed enough to find only one recursive part *) + raise Not_found + else + (sub := Some c; + if l = [] then RVar (loc,ldots_var) + else RApp (loc0,RVar (loc,ldots_var),l)) + | c -> map_rawconstr aux c in + let outer_iterator = aux c in + match !sub with + | None -> (* No recursive pattern found *) raise Not_found + | Some c -> + match outer_iterator with + | RVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found + | _ -> outer_iterator, c + +let on_true_do b f c = if b then (f c; b) else b + +let compare_rawconstr f add t1 t2 = match t1,t2 with + | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2 + | RVar (_,v1), RVar (_,v2) -> on_true_do (v1 = v2) add (Name v1) + | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2 + | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1 | RProd (_,na1,bk1,ty1,c1), RProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> - f ty1 ty2 & f c1 c2 + on_true_do (f ty1 ty2 & f c1 c2) add na1 | RHole _, RHole _ -> true | RSort (_,s1), RSort (_,s2) -> s1 = s2 - | (RLetIn _ | RCases _ | RRec _ | RDynamic _ + | RLetIn (_,na1,b1,c1), RLetIn (_,na2,b2,c2) when na1 = na2 -> + on_true_do (f b1 b2 & f c1 c2) add na1 + | (RCases _ | RRec _ | RDynamic _ | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_ - | _,(RLetIn _ | RCases _ | RRec _ | RDynamic _ + | _,(RCases _ | RRec _ | RDynamic _ | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _) -> error "Unsupported construction in recursive notations." - | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ | RHole _ | RSort _), _ + | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ + | RHole _ | RSort _ | RLetIn _), _ -> false -let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr t1 t2 +let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr (fun _ -> ()) t1 t2 + +let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1) -let discriminate_patterns foundvars nl l1 l2 = +let check_is_hole id = function RHole _ -> () | t -> + user_err_loc (loc_of_rawconstr t,"", + strbrk "In recursive notation with binders, " ++ pr_id id ++ + strbrk " is expected to come without type.") + +let compare_recursive_parts found f (iterator,subc) = let diff = ref None in - let rec aux n c1 c2 = match c1,c2 with - | RVar (_,v1), RVar (_,v2) when v1<>v2 -> - if !diff = None then (diff := Some (v1,v2,(n>=nl)); true) - else - !diff = Some (v1,v2,(n>=nl)) or !diff = Some (v2,v1,(n<nl)) - or (error - "Both ends of the recursive pattern differ in more than one place") - | _ -> compare_rawconstr (aux (n+1)) c1 c2 in - let l = list_map2_i aux 0 l1 l2 in - if not (List.for_all ((=) true) l) then - error "Both ends of the recursive pattern differ."; - match !diff with - | None -> error "Both ends of the recursive pattern are the same." - | Some (x,y,_ as discr) -> - List.iter (fun id -> - if List.mem id !foundvars - then errorlabstrm "" (strbrk "Variables used in the recursive part of a pattern are not allowed to occur outside of the recursive part."); - foundvars := id::!foundvars) [x;y]; - discr + let terminator = ref None in + let rec aux c1 c2 = match c1,c2 with + | RVar(_,v), term when v = ldots_var -> + (* We found the pattern *) + assert (!terminator = None); terminator := Some term; + true + | RApp (_,RVar(_,v),l1), RApp (_,term,l2) when v = ldots_var -> + (* We found the pattern, but there are extra arguments *) + (* (this allows e.g. alternative (recursive) notation of application) *) + assert (!terminator = None); terminator := Some term; + list_for_all2eq aux l1 l2 + | RVar (_,x), RVar (_,y) when x<>y -> + (* We found the position where it differs *) + let lassoc = (!terminator <> None) in + let x,y = if lassoc then y,x else x,y in + !diff = None && (diff := Some (x,y,Some lassoc); true) + | RLambda (_,Name x,_,t_x,c), RLambda (_,Name y,_,t_y,term) + | RProd (_,Name x,_,t_x,c), RProd (_,Name y,_,t_y,term) -> + (* We found a binding position where it differs *) + check_is_hole y t_x; + check_is_hole y t_y; + !diff = None && (diff := Some (x,y,None); aux c term) + | _ -> + compare_rawconstr aux (add_name found) c1 c2 in + if aux iterator subc then + match !diff with + | None -> + let loc1 = loc_of_rawconstr iterator in + let loc2 = loc_of_rawconstr (Option.get !terminator) in + (* Here, we would need a loc made of several parts ... *) + user_err_loc (subtract_loc loc1 loc2,"", + str "Both ends of the recursive pattern are the same.") + | Some (x,y,Some lassoc) -> + let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in + let iterator = + f (if lassoc then subst_rawvars [y,RVar(dummy_loc,x)] iterator + else iterator) in + (* found have been collected by compare_constr *) + found := newfound; + AList (x,y,iterator,f (Option.get !terminator),lassoc) + | Some (x,y,None) -> + let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in + let iterator = f iterator in + (* found have been collected by compare_constr *) + found := newfound; + ABinderList (x,y,iterator,f (Option.get !terminator)) + else + raise Not_found let aconstr_and_vars_of_rawconstr a = - let found = ref [] in - let rec aux = function - | RVar (_,id) -> found := id::!found; AVar id - | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args - | RApp (_,RVar (_,f),[RApp (_,t,[c]);d]) when f = ldots_var -> - (* Special case for alternative (recursive) notation of application *) - let x,y,lassoc = discriminate_patterns found 0 [c] [d] in - found := ldots_var :: !found; assert lassoc; - AList (x,y,AApp (AVar ldots_var,[AVar x]),aux t,lassoc) + let found = ref ([],[],[]) in + let rec aux c = + let keepfound = !found in + (* n^2 complexity but small and done only once per notation *) + try compare_recursive_parts found aux' (split_at_recursive_part c) + with Not_found -> + found := keepfound; + match c with + | RApp (_,RVar (loc,f),[c]) when f = ldots_var -> + (* Fall on the second part of the recursive pattern w/o having + found the first part *) + user_err_loc (loc,"", + str "Cannot find where the recursive pattern starts.") + | c -> + aux' c + and aux' = function + | RVar (_,id) -> add_id found id; AVar id | RApp (_,g,args) -> AApp (aux g, List.map aux args) | RLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c) | RProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c) | RLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c) | RCases (_,sty,rtntypopt,tml,eqnl) -> - let f (_,idl,pat,rhs) = found := idl@(!found); (pat,aux rhs) in + let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in ACases (sty,Option.map aux rtntypopt, List.map (fun (tm,(na,x)) -> add_name found na; @@ -215,7 +310,7 @@ let aconstr_and_vars_of_rawconstr a = add_name found na; AIf (aux c,(na,Option.map aux po),aux b1,aux b2) | RRec (_,fk,idl,dll,tl,bl) -> - Array.iter (fun id -> found := id::!found) idl; + Array.iter (add_id found) idl; let dll = Array.map (List.map (fun (na,bk,oc,b) -> if bk <> Explicit then error "Binders marked as implicit not allowed in notations."; @@ -231,51 +326,61 @@ let aconstr_and_vars_of_rawconstr a = | RDynamic _ | REvar _ -> error "Existential variables not allowed in notations." - (* Recognizing recursive notations *) - and terminator_of_pat f1 ll1 lr1 = function - | RApp (loc,f2,l2) -> - if not (eq_rawconstr f1 f2) then errorlabstrm "" - (strbrk "Cannot recognize the same head to both ends of the recursive pattern."); - let nl = List.length ll1 in - let nr = List.length lr1 in - if List.length l2 <> nl + nr + 1 then - error "Both ends of the recursive pattern have different lengths."; - let ll2,l2' = list_chop nl l2 in - let t = List.hd l2' and lr2 = List.tl l2' in - let x,y,order = discriminate_patterns found nl (ll1@lr1) (ll2@lr2) in - let iter = - if order then RApp (loc,f2,ll2@RVar (loc,ldots_var)::lr2) - else RApp (loc,f1,ll1@RVar (loc,ldots_var)::lr1) in - (if order then y else x),(if order then x else y), aux iter, aux t, order - | _ -> error "One end of the recursive pattern is not an application." - - and make_aconstr_list f args = - let rec find_patterns acc = function - | RApp(_,RVar (_,a),[c]) :: l when a = ldots_var -> - (* We've found the recursive part *) - let x,y,iter,term,lassoc = terminator_of_pat f (List.rev acc) l c in - AList (x,y,iter,term,lassoc) - | a::l -> find_patterns (a::acc) l - | [] -> error "Ill-formed recursive notation." - in find_patterns [] args - in let t = aux a in (* Side effect *) t, !found -let aconstr_of_rawconstr vars a = - let a,foundvars = aconstr_and_vars_of_rawconstr a in - let check_type x = - if not (List.mem x foundvars) then - error ((string_of_id x)^" is unbound in the right-hand-side.") in - List.iter check_type vars; +let rec list_rev_mem_assoc x = function + | [] -> false + | (_,x')::l -> x = x' || list_rev_mem_assoc x l + +let check_variables vars recvars (found,foundrec,foundrecbinding) = + let useless_vars = List.map snd recvars in + let vars = List.filter (fun (y,_) -> not (List.mem y useless_vars)) vars in + let check_recvar x = + if List.mem x found then + errorlabstrm "" (pr_id x ++ + strbrk " should only be used in the recursive part of a pattern.") in + List.iter (fun (x,y) -> check_recvar x; check_recvar y) + (foundrec@foundrecbinding); + let check_bound x = + if not (List.mem x found) then + if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding + or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding + then + error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.") + else + error ((string_of_id x)^" is unbound in the right-hand side.") in + let check_pair s x y where = + if not (List.mem (x,y) where) then + errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++ + str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++ + str " position as part of a recursive pattern.") in + let check_type (x,typ) = + match typ with + | NtnInternTypeConstr -> + begin + try check_pair "term" x (List.assoc x recvars) foundrec + with Not_found -> check_bound x + end + | NtnInternTypeBinder -> + begin + try check_pair "binding" x (List.assoc x recvars) foundrecbinding + with Not_found -> check_bound x + end + | NtnInternTypeIdent -> check_bound x in + List.iter check_type vars + +let aconstr_of_rawconstr vars recvars a = + let a,found = aconstr_and_vars_of_rawconstr a in + check_variables vars recvars found; a (* Substitution of kernel names, avoiding a list of bound identifiers *) let aconstr_of_constr avoiding t = - aconstr_of_rawconstr [] (Detyping.detype false avoiding [] t) + aconstr_of_rawconstr [] [] (Detyping.detype false avoiding [] t) let rec subst_pat subst pat = match pat with @@ -319,6 +424,12 @@ let rec subst_aconstr subst bound raw = if r1' == r1 && r2' == r2 then raw else AProd (n,r1',r2') + | ABinderList (id1,id2,r1,r2) -> + let r1' = subst_aconstr subst bound r1 + and r2' = subst_aconstr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + ABinderList (id1,id2,r1',r2') + | ALetIn (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in @@ -396,7 +507,7 @@ let rec subst_aconstr subst bound raw = ACast (r1',CastCoerce) let subst_interpretation subst (metas,pat) = - let bound = List.map fst (fst metas @ snd metas) in + let bound = List.map fst metas in (metas,subst_aconstr subst bound pat) let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l) @@ -434,7 +545,7 @@ let rec alpha_var id1 id2 = function let alpha_eq_val (x,y) = x = y -let bind_env alp (sigma,sigmalist as fullsigma) var v = +let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = try let vvar = List.assoc var sigma in if alpha_eq_val (v,vvar) then fullsigma @@ -443,7 +554,10 @@ let bind_env alp (sigma,sigmalist as fullsigma) var v = (* Check that no capture of binding variables occur *) if List.exists (fun (id,_) ->occur_rawconstr id v) alp then raise No_match; (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::sigma,sigmalist) + ((var,v)::sigma,sigmalist,sigmabinders) + +let bind_binder (sigma,sigmalist,sigmabinders) x bl = + (sigma,sigmalist,(x,List.rev bl)::sigmabinders) let match_fix_kind fk1 fk2 = match (fk1,fk2) with @@ -458,13 +572,9 @@ let match_opt f sigma t1 t2 = match (t1,t2) with | Some t1, Some t2 -> f sigma t1 t2 | _ -> raise No_match -let rawconstr_of_name = function - | Anonymous -> RHole (dummy_loc,Evd.InternalHole) - | Name id -> RVar (dummy_loc,id) - let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with - | (na,Name id2) when List.mem id2 metas -> - alp, bind_env alp sigma id2 (rawconstr_of_name na) + | (Name id1,Name id2) when List.mem id2 (fst metas) -> + alp, bind_env alp sigma id2 (RVar (dummy_loc,id1)) | (Name id1,Name id2) -> (id1,id2)::alp,sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match @@ -482,33 +592,80 @@ let adjust_application_n n loc f l = let l1,l2 = list_chop (List.length l - n) l in if l1 = [] then f,l else RApp (loc,f,l1), l2 -let match_alist match_fun metas sigma l1 l2 x iter termin lassoc = - (* match the iterator at least once *) - let sigmavar,sigmalist = - List.fold_left2 (match_fun (ldots_var::metas)) sigma l1 l2 in - (* Recover the recursive position *) - let rest = List.assoc ldots_var sigmavar in - (* Recover the first element *) - let t1 = List.assoc x sigmavar in - let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in - (* try to find the remaining elements or the terminator *) - let rec match_alist_tail metas sigma acc rest = +let glue_letin_with_decls = true + +let rec match_iterated_binders islambda decls = function + | RLambda (_,na,bk,t,b) when islambda -> + match_iterated_binders islambda ((na,bk,None,t)::decls) b + | RProd (_,(Name _ as na),bk,t,b) when not islambda -> + match_iterated_binders islambda ((na,bk,None,t)::decls) b + | RLetIn (loc,na,c,b) when glue_letin_with_decls -> + match_iterated_binders islambda + ((na,Explicit (*?*), Some c,RHole(loc,Evd.BinderType na))::decls) b + | b -> (decls,b) + +let remove_sigma x (sigmavar,sigmalist,sigmabinders) = + (List.remove_assoc x sigmavar,sigmalist,sigmabinders) + +let rec match_abinderlist_with_app match_fun metas sigma rest x iter termin = + let rec aux sigma acc rest = try - let sigmavar,sigmalist = match_fun (ldots_var::metas) sigma rest iter in - let rest = List.assoc ldots_var sigmavar in - let t = List.assoc x sigmavar in - let sigmavar = - List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in - match_alist_tail metas (sigmavar,sigmalist) (t::acc) rest - with No_match -> - List.rev acc, match_fun metas (sigmavar,sigmalist) rest termin in - let tl,(sigmavar,sigmalist) = match_alist_tail metas sigma [t1] rest in - (sigmavar, (x,if lassoc then List.rev tl else tl)::sigmalist) - -let rec match_ alp metas sigma a1 a2 = match (a1,a2) with - | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1 + let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in + let rest = List.assoc ldots_var (pi1 sigma) in + let b = match List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false in + let sigma = remove_sigma x (remove_sigma ldots_var sigma) in + aux sigma (b::acc) rest + with No_match when acc <> [] -> + acc, match_fun metas sigma rest termin in + let bl,sigma = aux sigma [] rest in + bind_binder sigma x bl + +let match_alist match_fun metas sigma rest x iter termin lassoc = + let rec aux sigma acc rest = + try + let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in + let rest = List.assoc ldots_var (pi1 sigma) in + let t = List.assoc x (pi1 sigma) in + let sigma = remove_sigma x (remove_sigma ldots_var sigma) in + aux sigma (t::acc) rest + with No_match when acc <> [] -> + acc, match_fun metas sigma rest termin in + let l,sigma = aux sigma [] rest in + (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) + +let rec match_ alp (tmetas,blmetas as metas) sigma a1 a2 = match (a1,a2) with + + (* Matching notation variable *) + | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1 + + (* Matching recursive notations for terms *) + | r1, AList (x,_,iter,termin,lassoc) -> + match_alist (match_ alp) metas sigma r1 x iter termin lassoc + + (* Matching recursive notations for binders: ad hoc cases supporting let-in *) + | RLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)-> + let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in + (* TODO: address the possibility that termin is a Lambda itself *) + match_ alp metas (bind_binder sigma x decls) b termin + | RProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin) + when na1 <> Anonymous -> + let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in + (* TODO: address the possibility that termin is a Prod itself *) + match_ alp metas (bind_binder sigma x decls) b termin + (* Matching recursive notations for binders: general case *) + | r, ABinderList (x,_,iter,termin) -> + match_abinderlist_with_app (match_ alp) metas sigma r x iter termin + + (* Matching individual binders as part of a recursive pattern *) + | RLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas -> + match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + | RProd (_,na,bk,t,b1), AProd (Name id,_,b2) + when List.mem id blmetas & na <> Anonymous -> + match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + + (* Matching compositionally *) | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma - | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma + | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma | RPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma | RApp (loc,f1,l1), AApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in @@ -519,11 +676,6 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2 else f1,l1, f2, l2 in List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2 - | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) - when List.length l1 >= List.length l2 -> - let f1,l1 = adjust_application_n (List.length l2) loc f1 l1 in - match_alist (match_ alp) - metas sigma (f1::l1) (f2::l2) x iter termin lassoc | RLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) -> match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 | RProd (_,na1,_,t1,b1), AProd (na2,t2,b2) -> @@ -588,38 +740,36 @@ and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_ alp metas sigma rhs1 rhs2 -type scope_name = string - -type tmp_scope_name = scope_name - -type subscopes = tmp_scope_name option * scope_name list - -type interpretation = - (* regular vars of notation / recursive parts of notation / body *) - ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr - -let match_aconstr c ((metas_scl,metaslist_scl),pat) = - let vars = List.map fst metas_scl @ List.map fst metaslist_scl in - let subst,substlist = match_ [] vars ([],[]) c pat in +let match_aconstr c (metas,pat) = + let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in + let vars = (List.map fst (fst vars), List.map fst (snd vars)) in + let terms,termlists,binders = match_ [] vars ([],[],[]) c pat in (* Reorder canonically the substitution *) let find x = - try List.assoc x subst + try List.assoc x terms with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) RVar (dummy_loc,x) in - List.map (fun (x,scl) -> (find x,scl)) metas_scl, - List.map (fun (x,scl) -> (List.assoc x substlist,scl)) metaslist_scl + List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> + match typ with + | NtnTypeConstr -> + ((find x, scl)::terms',termlists',binders') + | NtnTypeConstrList -> + (terms',(List.assoc x termlists,scl)::termlists',binders') + | NtnTypeBinderList -> + (terms',termlists',(List.assoc x binders,scl)::binders')) + metas ([],[],[]) (* Matching cases pattern *) -let bind_env_cases_pattern (sigma,sigmalist as fullsigma) var v = +let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = try let vvar = List.assoc var sigma in if v=vvar then fullsigma else raise No_match with Not_found -> (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma,sigmalist + (var,v)::sigma,sigmalist,x let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with | r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1 @@ -639,26 +789,21 @@ let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with (* All parameters must be _ *) List.iter (function AHole _ -> () | _ -> raise No_match) p2; List.fold_left2 (match_cases_pattern metas) sigma args1 args2 - | PatCstr (loc,(ind,_ as r1),args1,_), - AList (x,_,(AApp (ARef (ConstructRef r2),l2) as iter),termin,lassoc) - when r1 = r2 -> - let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in - assert (List.length args1 + nparams = List.length l2); - let (p2,args2) = list_chop nparams l2 in - List.iter (function AHole _ -> () | _ -> raise No_match) p2; - match_alist match_cases_pattern - metas sigma args1 args2 x iter termin lassoc + | r1, AList (x,_,iter,termin,lassoc) -> + match_alist (fun (metas,_) -> match_cases_pattern metas) + (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc | _ -> raise No_match -let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) = - let vars = List.map fst metas_scl @ List.map fst metaslist_scl in - let subst,substlist = match_cases_pattern vars ([],[]) c pat in +let match_aconstr_cases_pattern c (metas,pat) = + let vars = List.map fst metas in + let terms,termlists,() = match_cases_pattern vars ([],[],()) c pat in (* Reorder canonically the substitution *) - let find x subst = - try List.assoc x subst - with Not_found -> anomaly "match_aconstr_cases_pattern" in - List.map (fun (x,scl) -> (find x subst,scl)) metas_scl, - List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl + List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> + match typ with + | NtnTypeConstr -> ((List.assoc x terms, scl)::terms',termlists') + | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists') + | NtnTypeBinderList -> assert false) + metas ([],[]) (**********************************************************************) (*s Concrete syntax for terms *) @@ -675,19 +820,20 @@ type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string -type 'a notation_substitution = - 'a list * (* for recursive notations: *) 'a list list - type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_expr notation_substitution + | CPatNotation of loc * notation * cases_pattern_notation_substitution | CPatPrim of loc * prim_token - | CPatRecord of loc * (reference * cases_pattern_expr) list + | CPatRecord of Util.loc * (reference * cases_pattern_expr) list | CPatDelimiters of loc * string * cases_pattern_expr +and cases_pattern_notation_substitution = + cases_pattern_expr list * (** for constr subterms *) + cases_pattern_expr list list (** for recursive notations *) + type constr_expr = | CRef of reference | CFix of loc * identifier located * fix_expr list @@ -701,18 +847,18 @@ type constr_expr = (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (reference * constr_expr) list | CCases of loc * case_style * constr_expr option * - (constr_expr * (name option * constr_expr option)) list * + (constr_expr * (name located option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list - | CLetTuple of loc * name list * (name option * constr_expr option) * + | CLetTuple of loc * name located list * (name located option * constr_expr option) * constr_expr * constr_expr - | CIf of loc * constr_expr * (name option * constr_expr option) + | CIf of loc * constr_expr * (name located option * constr_expr option) * constr_expr * constr_expr | CHole of loc * Evd.hole_kind option | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key * constr_expr list option | CSort of loc * rawsort | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_expr notation_substitution + | CNotation of loc * notation * constr_notation_substitution | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr @@ -721,14 +867,6 @@ type constr_expr = and fix_expr = identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr -and local_binder = - | LocalRawDef of name located * constr_expr - | LocalRawAssum of name located list * binder_kind * constr_expr - -and typeclass_constraint = name located * binding_kind * constr_expr - -and typeclass_context = typeclass_constraint list - and cofix_expr = identifier located * local_binder list * constr_expr * constr_expr @@ -737,6 +875,19 @@ and recursion_order_expr = | CWfRec of constr_expr | CMeasureRec of constr_expr * constr_expr option (* measure, relation *) +and local_binder = + | LocalRawDef of name located * constr_expr + | LocalRawAssum of name located list * binder_kind * constr_expr + +and constr_notation_substitution = + constr_expr list * (* for constr subterms *) + constr_expr list list * (* for recursive notations *) + local_binder list list (* for binders subexpressions *) + +type typeclass_constraint = name located * binding_kind * constr_expr + +and typeclass_context = typeclass_constraint list + type constr_pattern_expr = constr_expr (***********************) @@ -789,6 +940,15 @@ let cases_pattern_expr_loc = function | CPatPrim (loc,_) -> loc | CPatDelimiters (loc,_,_) -> loc +let local_binder_loc = function + | LocalRawAssum ((loc,_)::_,_,t) + | LocalRawDef ((loc,_),t) -> join_loc loc (constr_loc t) + | LocalRawAssum ([],_,_) -> assert false + +let local_binders_loc bll = + if bll = [] then dummy_loc else + join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll)) + let occur_var_constr_ref id = function | Ident (loc,id') -> id = id' | Qualid _ -> false @@ -798,7 +958,7 @@ let ids_of_cases_indtype = let rec vars_of = function (* We deal only with the regular cases *) | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l) - | CNotation (_,_,(l,[])) + | CNotation (_,_,(l,[],[])) (* assume the ntn is applicative and does not instantiate the head !! *) | CAppExpl (_,_,l) -> List.fold_left add_var [] l | CDelimiters(_,_,c) -> vars_of c @@ -809,7 +969,7 @@ let ids_of_cases_tomatch tms = List.fold_right (fun (_,(ona,indnal)) l -> Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) - indnal (Option.fold_right name_cons ona l)) + indnal (Option.fold_right (down_located name_cons) ona l)) tms [] let is_constructor id = @@ -849,7 +1009,7 @@ let rec fold_local_binders g f n acc b = function f n (fold_local_binders g f n' acc b l) t | LocalRawDef ((_,na),t)::l -> f n (fold_local_binders g f (name_fold g na n) acc b l) t - | _ -> + | [] -> f n acc b let fold_constr_expr_with_binders g f n acc = function @@ -860,7 +1020,11 @@ let fold_constr_expr_with_binders g f n acc = function | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a] | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b | CCast (loc,a,CastCoerce) -> f n acc a - | CNotation (_,_,(l,ll)) -> List.fold_left (f n) acc (l@List.flatten ll) + | CNotation (_,_,(l,ll,bll)) -> + (* The following is an approximation: we don't know exactly if + an ident is binding nor to which subterms bindings apply *) + let acc = List.fold_left (f n) acc (l@List.flatten ll) in + List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll | CGeneralization (_,_,_,c) -> f n acc c | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ -> @@ -874,11 +1038,12 @@ let fold_constr_expr_with_binders g f n acc = function let ids = ids_of_pattern_list patl in f (Idset.fold g ids n) acc rhs) bl acc | CLetTuple (loc,nal,(ona,po),b,c) -> - let n' = List.fold_right (name_fold g) nal n in - f (Option.fold_right (name_fold g) ona n') (f n acc b) c + let n' = List.fold_right (down_located (name_fold g)) nal n in + f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c | CIf (_,c,(ona,po),b1,b2) -> let acc = f n (f n (f n acc b1) b2) c in - Option.fold_left (f (Option.fold_right (name_fold g) ona n)) acc po + Option.fold_left + (f (Option.fold_right (down_located (name_fold g)) ona n)) acc po | CFix (loc,_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> @@ -961,21 +1126,29 @@ let coerce_to_name = function (* Interpret the index of a recursion order annotation *) -let index_of_annot bl na = +let split_at_annot bl na = let names = List.map snd (names_of_local_assums bl) in match na with | None -> - if names = [] then error "A fixpoint needs at least one parameter." - else None + if names = [] then error "A fixpoint needs at least one parameter." + else [], bl | Some (loc, id) -> - try Some (list_index0 (Name id) names) - with Not_found -> - user_err_loc(loc,"", - str "No parameter named " ++ Nameops.pr_id id ++ str".") + let rec aux acc = function + | LocalRawAssum (bls, k, t) as x :: rest -> + let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in + if r = [] then aux (x :: acc) rest + else + (List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc), + LocalRawAssum (r, k, t) :: rest) + | LocalRawDef _ as x :: rest -> aux (x :: acc) rest + | [] -> + user_err_loc(loc,"", + str "No parameter named " ++ Nameops.pr_id id ++ str".") + in aux [] bl (* Used in correctness and interface *) -let map_binder g e nal = List.fold_right (fun (_,na) -> name_fold g na) nal e +let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e let map_binders f g e bl = (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) @@ -1005,8 +1178,10 @@ let map_constr_expr_with_binders g f e = function | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b)) | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce) - | CNotation (loc,n,(l,ll)) -> - CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll)) + | CNotation (loc,n,(l,ll,bll)) -> + (* This is an approximation because we don't know what binds what *) + CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll, + List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c) | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ @@ -1019,11 +1194,11 @@ let map_constr_expr_with_binders g f e = function let po = Option.map (f (List.fold_right g ids e)) rtnpo in CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> - let e' = List.fold_right (name_fold g) nal e in - let e'' = Option.fold_right (name_fold g) ona e in + let e' = List.fold_right (down_located (name_fold g)) nal e in + let e'' = Option.fold_right (down_located (name_fold g)) ona e in CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c) | CIf (loc,c,(ona,po),b1,b2) -> - let e' = Option.fold_right (name_fold g) ona e in + let e' = Option.fold_right (down_located (name_fold g)) ona e in CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (loc,id,dl) -> CFix (loc,id,List.map (fun (id,n,bl,t,d) -> @@ -1067,16 +1242,21 @@ type 'a module_signature = | Check of 'a list (* ... <: T1 <: T2, possibly empty *) (* Returns the ranges of locs of the notation that are not occupied by args *) -(* and which are them occupied by proper symbols of the notation (or spaces) *) +(* and which are then occupied by proper symbols of the notation (or spaces) *) -let locs_of_notation f loc (args,argslist) ntn = +let locs_of_notation loc locs ntn = let (bl,el) = Util.unloc loc in + let locs = List.map Util.unloc locs in let rec aux pos = function | [] -> if pos = el then [] else [(pos,el-1)] - | a::l -> - let ba,ea = Util.unloc (f a) in - if pos = ba then aux ea l else (pos,ba-1)::aux ea l - in aux bl (args@List.flatten argslist) + | (ba,ea)::l ->if pos = ba then aux ea l else (pos,ba-1)::aux ea l + in aux bl (Sort.list (fun l1 l2 -> fst l1 < fst l2) locs) + +let ntn_loc loc (args,argslist,binderslist) = + locs_of_notation loc + (List.map constr_loc (args@List.flatten argslist)@ + List.map local_binders_loc binderslist) -let ntn_loc = locs_of_notation constr_loc -let patntn_loc = locs_of_notation cases_pattern_expr_loc +let patntn_loc loc (args,argslist) = + locs_of_notation loc + (List.map cases_pattern_expr_loc (args@List.flatten argslist)) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 0918a4de..5e49d2ea 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: topconstr.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Pp @@ -32,6 +32,7 @@ type aconstr = (* Part only in [rawconstr] *) | ALambda of name * aconstr * aconstr | AProd of name * aconstr * aconstr + | ABinderList of identifier * identifier * aconstr * aconstr | ALetIn of name * aconstr * aconstr | ACases of case_style * aconstr option * (aconstr * (name * (inductive * int * name list) option)) list * @@ -46,11 +47,34 @@ type aconstr = | APatVar of patvar | ACast of aconstr * aconstr cast_type +type scope_name = string + +type tmp_scope_name = scope_name + +type subscopes = tmp_scope_name option * scope_name list + +(** Type of the meta-variables of an aconstr: in a recursive pattern x..y, + x carries the sequence of objects bound to the list x..y *) +type notation_var_instance_type = + | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList + +(** Type of variables when interpreting a constr_expr as an aconstr: + in a recursive pattern x..y, both x and y carry the individual type + of each element of the list x..y *) +type notation_var_internalization_type = + | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent + +(** This characterizes to what a notation is interpreted to *) +type interpretation = + (identifier * (subscopes * notation_var_instance_type)) list * aconstr + (**********************************************************************) (* Translate a rawconstr into a notation given the list of variables *) (* bound by the notation; also interpret recursive patterns *) -val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr +val aconstr_of_rawconstr : + (identifier * notation_var_internalization_type) list -> + (identifier * identifier) list -> rawconstr -> aconstr (* Name of the special identifier used to encode recursive notations *) val ldots_var : identifier @@ -68,23 +92,14 @@ val rawconstr_of_aconstr_with_binders : loc -> val rawconstr_of_aconstr : loc -> aconstr -> rawconstr (**********************************************************************) -(* [match_aconstr metas] matches a rawconstr against an aconstr with *) -(* metavariables in [metas]; raise [No_match] if the matching fails *) +(* [match_aconstr] matches a rawconstr against a notation *) +(* interpretation raise [No_match] if the matching fails *) exception No_match -type scope_name = string - -type tmp_scope_name = scope_name - -type subscopes = tmp_scope_name option * scope_name list - -type interpretation = - (* regular vars of notation / recursive parts of notation / body *) - ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr - val match_aconstr : rawconstr -> interpretation -> - (rawconstr * subscopes) list * (rawconstr list * subscopes) list + (rawconstr * subscopes) list * (rawconstr list * subscopes) list * + (rawdecl list * subscopes) list val match_aconstr_cases_pattern : cases_pattern -> interpretation -> (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list @@ -113,19 +128,20 @@ type proj_flag = int option (* [Some n] = proj of the n-th visible argument *) type prim_token = Numeral of Bigint.bigint | String of string -type 'a notation_substitution = - 'a list * (* for recursive notations: *) 'a list list - type cases_pattern_expr = | CPatAlias of loc * cases_pattern_expr * identifier | CPatCstr of loc * reference * cases_pattern_expr list | CPatAtom of loc * reference option | CPatOr of loc * cases_pattern_expr list - | CPatNotation of loc * notation * cases_pattern_expr notation_substitution + | CPatNotation of loc * notation * cases_pattern_notation_substitution | CPatPrim of loc * prim_token | CPatRecord of Util.loc * (reference * cases_pattern_expr) list | CPatDelimiters of loc * string * cases_pattern_expr +and cases_pattern_notation_substitution = + cases_pattern_expr list * (** for constr subterms *) + cases_pattern_expr list list (** for recursive notations *) + type constr_expr = | CRef of reference | CFix of loc * identifier located * fix_expr list @@ -139,18 +155,18 @@ type constr_expr = (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (reference * constr_expr) list | CCases of loc * case_style * constr_expr option * - (constr_expr * (name option * constr_expr option)) list * + (constr_expr * (name located option * constr_expr option)) list * (loc * cases_pattern_expr list located list * constr_expr) list - | CLetTuple of loc * name list * (name option * constr_expr option) * + | CLetTuple of loc * name located list * (name located option * constr_expr option) * constr_expr * constr_expr - | CIf of loc * constr_expr * (name option * constr_expr option) + | CIf of loc * constr_expr * (name located option * constr_expr option) * constr_expr * constr_expr | CHole of loc * Evd.hole_kind option | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key * constr_expr list option | CSort of loc * rawsort | CCast of loc * constr_expr * constr_expr cast_type - | CNotation of loc * notation * constr_expr notation_substitution + | CNotation of loc * notation * constr_notation_substitution | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr @@ -172,6 +188,11 @@ and local_binder = | LocalRawDef of name located * constr_expr | LocalRawAssum of name located list * binder_kind * constr_expr +and constr_notation_substitution = + constr_expr list * (** for constr subterms *) + constr_expr list list * (** for recursive notations *) + local_binder list list (** for binders subexpressions *) + type typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list @@ -185,6 +206,8 @@ val constr_loc : constr_expr -> loc val cases_pattern_expr_loc : cases_pattern_expr -> loc +val local_binders_loc : local_binder list -> loc + val replace_vars_constr_expr : (identifier * identifier) list -> constr_expr -> constr_expr @@ -208,7 +231,7 @@ val coerce_reference_to_id : reference -> identifier val coerce_to_id : constr_expr -> identifier located val coerce_to_name : constr_expr -> name located -val index_of_annot : local_binder list -> identifier located option -> int option +val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr val prod_constr_expr : constr_expr -> local_binder list -> constr_expr @@ -256,7 +279,6 @@ type 'a module_signature = | Check of 'a list (* ... <: T1 <: T2, possibly empty *) val ntn_loc : - Util.loc -> constr_expr notation_substitution -> string -> (int * int) list + Util.loc -> constr_notation_substitution -> string -> (int * int) list val patntn_loc : - Util.loc -> cases_pattern_expr notation_substitution -> string -> - (int * int) list + Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h index 04e38656..0a61ad79 100644 --- a/kernel/byterun/int64_emul.h +++ b/kernel/byterun/int64_emul.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id$ */ +/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */ /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h index f5bef4a6..4fc3c220 100644 --- a/kernel/byterun/int64_native.h +++ b/kernel/byterun/int64_native.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id$ */ +/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */ /* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index e7859962..0578c7b4 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -7,49 +7,46 @@ open Declarations open Pre_env -(* Compilation des variables + calcul des variables libres *) +(* Compilation of variables + computing free variables *) -(* Dans la machine virtuel il n'y a pas de difference entre les *) -(* fonctions et leur environnement *) +(* The virtual machine doesn't distinguish closures and their environment *) -(* Representation de l'environnements des fonctions : *) +(* Representation of function environments : *) (* [clos_t | code | fv1 | fv2 | ... | fvn ] *) (* ^ *) -(* l'offset pour l'acces au variable libre est 1 (il faut passer le *) -(* pointeur de code). *) -(* Lors de la compilation, les variables libres sont stock'ees dans *) -(* [in_env] dans l'ordre inverse de la representation machine, ceci *) -(* permet de rajouter des nouvelles variables dans l'environnememt *) -(* facilement. *) -(* Les arguments de la fonction arrive sur la pile dans l'ordre de *) -(* l'application : f arg1 ... argn *) -(* - la pile est alors : *) +(* The offset for accessing free variables is 1 (we must skip the code *) +(* pointer). *) +(* While compiling, free variables are stored in [in_env] in order *) +(* opposite to machine representation, so we can add new free variables *) +(* easily (i.e. without changing the position of previous variables) *) +(* Function arguments are on the stack in the same order as the *) +(* application : f arg1 ... argn *) +(* - the stack is then : *) (* arg1 : ... argn : extra args : return addr : ... *) -(* Dans le corps de la fonction [arg1] est repr'esent'e par le de Bruijn *) -(* [n], [argn] par le de Bruijn [1] *) +(* In the function body [arg1] is represented by de Bruijn [n], and *) +(* [argn] by de Bruijn [1] *) -(* Representation des environnements des points fix mutuels : *) +(* Representation of environements of mutual fixpoints : *) (* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) (* ^<----------offset---------> *) (* type = [Ct1 | .... | Ctn] *) -(* Ci est le code correspondant au corps du ieme point fix *) -(* Lors de l'evaluation d'un point fix l'environnement est un pointeur *) -(* sur la position correspondante a son code. *) -(* Dans le corps de chaque point fix le de Bruijn [nbr] represente, *) -(* le 1er point fix de la declaration mutuelle, le de Bruijn [1] le *) -(* nbr-ieme. *) -(* L'acces a ces variables se fait par l'instruction [Koffsetclosure] *) -(* (decalage de l'environnement) *) - -(* Ceci permet de representer tout les point fix mutuels en un seul bloc *) -(* [Ct1 | ... | Ctn] est un tableau contant le code d'evaluation des *) -(* types des points fixes, ils sont utilises pour tester la conversion *) -(* Leur environnement d'execution est celui du dernier point fix : *) +(* Ci is the code pointer of the i-th body *) +(* At runtime, a fixpoint environment (which is the same as the fixpoint *) +(* itself) is a pointer to the field holding its code pointer. *) +(* In each fixpoint body, de Bruijn [nbr] represents the first fixpoint *) +(* and de Bruijn [1] the last one. *) +(* Access to these variables is performed by the [Koffsetclosure n] *) +(* instruction that shifts the environment pointer of [n] fields. *) + +(* This allows to represent mutual fixpoints in just one block. *) +(* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint *) +(* types. They are used in conversion tests (which requires that *) +(* fixpoint types must be convertible). Their environment is the one of *) +(* the last fixpoint : *) (* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) (* ^ *) - -(* Representation des cofix mutuels : *) +(* Representation of mutual cofix : *) (* a1 = [A_t | accumulate | [Cfx_t | fcofix1 ] ] *) (* ... *) (* anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ] *) @@ -59,29 +56,28 @@ open Pre_env (* ... *) (* fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) -(* Les block [ai] sont des fonctions qui accumulent leurs arguments : *) +(* The [ai] blocks are functions that accumulate their arguments: *) (* ai arg1 argp ---> *) (* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) -(* Si un tel bloc arrive sur un [match] il faut forcer l'evaluation, *) -(* la fonction [fcofixi] est alors appliqu'ee a [ai'] [arg1] ... [argp] *) -(* A la fin de l'evaluation [ai'] est mis a jour avec le resultat de *) -(* l'evaluation : *) +(* If such a block is matched against, we have to force evaluation, *) +(* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) +(* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) (* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) -(* L'avantage de cette representation est qu'elle permet d'evaluer qu'une *) -(* fois l'application d'un cofix (evaluation lazy) *) -(* De plus elle permet de creer facilement des cycles quand les cofix ne *) -(* n'ont pas d'aruments, ex: *) +(* This representation is nice because the application of the cofix is *) +(* evaluated only once (it simulates a lazy evaluation) *) +(* Moreover, when cofix don't have arguments, it is possible to create *) +(* a cycle, e.g.: *) (* cofix one := cons 1 one *) (* a1 = [A_t | accumulate | [Cfx_t|fcofix1] ] *) (* fcofix1 = [clos_t | code | a1] *) -(* Quand on force l'evaluation de [a1] le resultat est *) -(* [cons_t | 1 | a1] *) -(* [a1] est mis a jour : *) +(* The result of evaluating [a1] is [cons_t | 1 | a1]. *) +(* When [a1] is updated : *) (* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) -(* Le cycle est cree ... *) - -(* On conserve la fct de cofix pour la conversion *) +(* The cycle is created ... *) +(* *) +(* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) +(* conversion of cofixpoints (which is intentional). *) let empty_fv = { size= 0; fv_rev = [] } @@ -112,7 +108,7 @@ let comp_env_fun arity = } -let comp_env_type rfv = +let comp_env_fix_type rfv = { nb_stack = 0; in_stack = []; nb_rec = 0; @@ -134,6 +130,15 @@ let comp_env_fix ndef curr_pos arity rfv = in_env = rfv } +let comp_env_cofix_type ndef rfv = + { nb_stack = 0; + in_stack = []; + nb_rec = 0; + pos_rec = []; + offset = 1+ndef; + in_env = rfv + } + let comp_env_cofix ndef arity rfv = let prec = ref [] in for i = 1 to ndef do @@ -147,14 +152,13 @@ let comp_env_cofix ndef arity rfv = in_env = rfv } -(* [push_param ] ajoute les parametres de fonction dans la pile *) +(* [push_param ] add function parameters on the stack *) let push_param n sz r = { r with nb_stack = r.nb_stack + n; in_stack = add_param n sz r.in_stack } -(* [push_local e sz] ajoute une nouvelle variable dans la pile a la *) -(* position [sz] *) +(* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = { r with nb_stack = r.nb_stack + 1; @@ -185,7 +189,7 @@ let pos_rel i r sz = let i = i - r.nb_stack in if i <= r.nb_rec then try List.nth r.pos_rec (i-1) - with _ -> assert false + with (Failure _|Invalid_argument _) -> assert false else let i = i - r.nb_rec in let db = FVrel(i) in @@ -297,19 +301,19 @@ let cont_cofix arity = Kreturn (arity+2) ] -(*i Global environment global *) +(*i Global environment *) let global_env = ref empty_env let set_global_env env = global_env := env -(* Code des fermetures *) +(* Code of closures *) let fun_code = ref [] let init_fun_code () = fun_code := [] -(* Compilation des constructeurs et des inductifs *) +(* Compilation of constructors and inductive types *) (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = @@ -424,7 +428,7 @@ let rec str_const c = end | _ -> Bconstr c -(* compilation des applications *) +(* compiling application *) let comp_args comp_expr reloc args sz cont = let nargs_m_1 = Array.length args - 1 in let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in @@ -451,7 +455,7 @@ let comp_app comp_fun comp_arg reloc f args sz cont = (comp_args comp_arg reloc args (sz + 3) (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) -(* Compilation des variables libres *) +(* Compiling free variables *) let compile_fv_elem reloc fv sz cont = match fv with @@ -466,7 +470,7 @@ let rec compile_fv reloc l sz cont = compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) -(* compilation des constantes *) +(* Compiling constants *) let rec get_allias env kn = let tps = (lookup_constant kn env).const_body_code in @@ -475,7 +479,7 @@ let rec get_allias env kn = | _ -> kn -(* compilation des expressions *) +(* Compiling expressions *) let rec compile_constr reloc c sz cont = match kind_of_term c with @@ -522,7 +526,7 @@ let rec compile_constr reloc c sz cont = let lbl_types = Array.create ndef Label.no in let lbl_bodies = Array.create ndef Label.no in (* Compilation des types *) - let env_type = comp_env_type rfv in + let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do let lbl,fcode = label_code @@ -530,7 +534,7 @@ let rec compile_constr reloc c sz cont = lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; - (* Compilation des corps *) + (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in @@ -550,9 +554,9 @@ let rec compile_constr reloc c sz cont = let ndef = Array.length type_bodies in let lbl_types = Array.create ndef Label.no in let lbl_bodies = Array.create ndef Label.no in - (* Compilation des types *) + (* Compiling types *) let rfv = ref empty_fv in - let env_type = comp_env_type rfv in + let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do let lbl,fcode = label_code @@ -560,7 +564,7 @@ let rec compile_constr reloc c sz cont = lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; - (* Compilation des corps *) + (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in @@ -585,11 +589,11 @@ let rec compile_constr reloc c sz cont = let lbl_consts = Array.create oib.mind_nb_constant Label.no in let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in let branch1,cont = make_branch cont in - (* Compilation du type *) + (* Compiling return type *) let lbl_typ,fcode = label_code (compile_constr reloc t sz [Kpop sz; Kstop]) in fun_code := [Ksequence(fcode,!fun_code)]; - (* Compilation des branches *) + (* Compiling branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = match branch1 with @@ -597,13 +601,13 @@ let rec compile_constr reloc c sz cont = | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in - (* Compilation de la branche accumulate *) + (* Compiling branch for accumulators *) let lbl_accu, code_accu = label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) in lbl_blocks.(0) <- lbl_accu; let c = ref code_accu in - (* Compilation des branches constructeurs *) + (* Compiling regular constructor branches *) for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in if arity = 0 then diff --git a/kernel/closure.ml b/kernel/closure.ml index 82bd017a..3f4c1059 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: closure.ml 13340 2010-07-28 12:22:04Z barras $ *) open Util open Pp @@ -524,6 +524,7 @@ let destFLambda clos_fun t = | FLambda(n,(na,ty)::tys,b,e) -> (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false + (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) @@ -758,8 +759,8 @@ let rec reloc_rargs_rec depth stk = let reloc_rargs depth stk = if depth = 0 then stk else reloc_rargs_rec depth stk -let rec drop_parameters depth n stk = - match stk with +let rec drop_parameters depth n argstk = + match argstk with Zapp args::s -> let q = Array.length args in if n > q then drop_parameters depth (n-q) s @@ -768,9 +769,12 @@ let rec drop_parameters depth n stk = let aft = Array.sub args n (q-n) in reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> drop_parameters (depth-k) n s - | [] -> assert (n=0); [] - | _ -> assert false (* we know that n < stack_args_size(stk) *) - + | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) + if n=0 then [] + else anomaly + "ill-typed term: found a match on a partially applied constructor" + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding diff --git a/kernel/closure.mli b/kernel/closure.mli index 7d212f53..0af30bed 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: closure.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index ca9482d0..935f6fe7 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: conv_oracle.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Names diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 1de1ddbf..94911edd 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: conv_oracle.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names diff --git a/kernel/cooking.ml b/kernel/cooking.ml index e6bc0684..ad5e725b 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cooking.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/kernel/cooking.mli b/kernel/cooking.mli index a471dbc9..bd1f4aec 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cooking.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 145ca27d..8eeb1ce6 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -146,7 +146,7 @@ and slot_for_fv env fv = let (_, b, _) = lookup_rel i env.env_rel_context in let (v, d) = match b with - | None -> (val_of_rel i, Idset.empty) + | None -> (val_of_rel (nb_rel env - i), Idset.empty) | Some c -> let renv = env_of_rel i env in (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c) in diff --git a/kernel/declarations.ml b/kernel/declarations.ml index d3866b42..42055a23 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: declarations.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 56075869..ee1242bb 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: declarations.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/entries.ml b/kernel/entries.ml index d3dcc5e7..cec46423 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: entries.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/entries.mli b/kernel/entries.mli index 2b3e2c49..ecc50213 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: entries.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/environ.ml b/kernel/environ.ml index 41805241..935faae6 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: environ.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/environ.mli b/kernel/environ.mli index ef912e6f..7485ca37 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: environ.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 2ba2670a..2d3956a1 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: esubst.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 2cad93f5..96da8dda 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: esubst.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Explicit substitutions of type ['a]. *) (* - ESID(n) = %n END bounded identity diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index df3670d5..91aec40c 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: indtypes.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index b9f39cef..8384a63a 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: indtypes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ca7d0614..ba5e5252 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: inductive.ml 13368 2010-08-03 13:22:49Z barras $ *) open Util open Names @@ -418,8 +418,10 @@ type subterm_spec = | Dead_code | Not_subterm -let spec_of_tree t = - if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t) +let spec_of_tree t = lazy + (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec + then Not_subterm + else Subterm(Strict,Lazy.force t)) let subterm_spec_glb = let glb2 s1 s2 = @@ -443,7 +445,7 @@ type guard_env = (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) - genv : subterm_spec list; + genv : subterm_spec Lazy.t list; } let make_renv env minds recarg (kn,tyi) = @@ -454,7 +456,7 @@ let make_renv env minds recarg (kn,tyi) = rel_min = recarg+2; inds = minds; recvec = mind_recvec; - genv = [Subterm(Large,mind_recvec.(tyi))] } + genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] } let push_var renv (x,ty,spec) = { renv with @@ -466,11 +468,11 @@ let assign_var_spec renv (i,spec) = { renv with genv = list_assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = - push_var renv (x,ty,Not_subterm) + push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = - try List.nth renv.genv (p-1) + try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm (* Add a variable and mark it as strictly smaller with information [spec]. *) @@ -482,14 +484,14 @@ let push_ctxt_renv renv ctxt = { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { renv with env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } (******************************) @@ -513,12 +515,47 @@ let lookup_subterms env ind = (*********************************) +let match_trees t1 t2 = + let v1 = dest_subterms t1 in + let v2 = dest_subterms t2 in + array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2 + +(* In {match c as z in ind y_s return P with |C_i x_s => t end} + [branches_specif renv c_spec ind] returns an array of x_s specs given + c_spec the spec of c. *) +let branches_specif renv c_spec ind = + let (_,mip) = lookup_mind_specif renv.env ind in + let car = + (* We fetch the regular tree associated to the inductive of the match. + This is just to get the number of constructors (and constructor + arities) that fit the match branches without forcing c_spec. + Note that c_spec might be more precise than [v] below, because of + nested inductive types. *) + let v = dest_subterms mip.mind_recargs in + Array.map List.length v in + Array.mapi + (fun i nca -> (* i+1-th cstructor has arity nca *) + let lvra = lazy + (match Lazy.force c_spec with + Subterm (_,t) when match_trees mip.mind_recargs t -> + let vra = Array.of_list (dest_subterms t).(i) in + assert (nca = Array.length vra); + Array.map + (fun t -> Lazy.force (spec_of_tree (lazy t))) + vra + | Dead_code -> Array.create nca Dead_code + | _ -> Array.create nca Not_subterm) in + list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) + car + + (* Propagation of size information through Cases: if the matched object is a recursive subterm then compute the information associated to its own subterms. Rq: if branch is not eta-long, then the recursive information is not propagated to the missing abstractions *) let case_branches_specif renv c_spec ind lbr = + let vlrec = branches_specif renv c_spec ind in let rec push_branch_args renv lrec c = match lrec with ra::lr -> @@ -530,17 +567,8 @@ let case_branches_specif renv c_spec ind lbr = | _ -> (* branch not in eta-long form: cannot perform rec. calls *) (renv,c')) | [] -> (renv, c) in - match c_spec with - Subterm (_,t) -> - let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in - assert (Array.length sub_spec = Array.length lbr); - array_map2 (push_branch_args renv) sub_spec lbr - | Dead_code -> - let t = dest_subterms (lookup_subterms renv.env ind) in - let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in - assert (Array.length sub_spec = Array.length lbr); - array_map2 (push_branch_args renv) sub_spec lbr - | Not_subterm -> Array.map (fun c -> (renv,c)) lbr + assert (Array.length vlrec = Array.length lbr); + array_map2 (push_branch_args renv) vlrec lbr (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of @@ -582,7 +610,8 @@ let rec subterm_specif renv t = let renv' = (* Why Strict here ? To be general, it could also be Large... *) - assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in + assign_var_spec renv' + (nbfix-i, Lazy.lazy_from_val(Subterm(Strict,recargs))) in let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in @@ -593,7 +622,7 @@ let rec subterm_specif renv t = if List.length l < nbOfAbst then renv'' else let theDecrArg = List.nth l decrArg in - let arg_spec = subterm_specif renv theDecrArg in + let arg_spec = lazy_subterm_specif renv theDecrArg in assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' strippedBody) @@ -607,10 +636,13 @@ let rec subterm_specif renv t = (* Other terms are not subterms *) | _ -> Not_subterm +and lazy_subterm_specif renv t = + lazy (subterm_specif renv t) + and case_subterm_specif renv ci c lbr = if Array.length lbr = 0 then [||] else - let c_spec = subterm_specif renv c in + let c_spec = lazy_subterm_specif renv c in case_branches_specif renv c_spec ci.ci_ind lbr (* Check term c can be applied to one of the mutual fixpoints. *) @@ -627,7 +659,7 @@ let error_illegal_rec_call renv fx arg = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> - match sbt with + match Lazy.force sbt with (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) | (Subterm(Large,_)) -> (i+1, i::le, lt) | _ -> (i+1, le ,lt)) @@ -709,7 +741,7 @@ let check_one_fix renv recpos def = (fun j body -> if i=j then let theDecrArg = List.nth l decrArg in - let arg_spec = subterm_specif renv theDecrArg in + let arg_spec = lazy_subterm_specif renv theDecrArg in check_nested_fix_body renv' (decrArg+1) arg_spec body else check_rec_call renv' body) bodies diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 59eaf77f..a2bd674f 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: inductive.mli 13368 2010-08-03 13:22:49Z barras $ i*) (*i*) open Names @@ -110,9 +110,9 @@ type guard_env = (* the recarg information of inductive family *) recvec : wf_paths array; (* dB of variables denoting subterms *) - genv : subterm_spec list; + genv : subterm_spec Lazy.t list; } val subterm_specif : guard_env -> constr -> subterm_spec -val case_branches_specif : guard_env -> subterm_spec -> inductive -> +val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive -> constr array -> (guard_env * constr) array diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index d27fad95..53d26ec6 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: mod_subst.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index f137c7c0..a16ee99e 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mod_subst.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s [Mod_subst] *) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d0e567a8..c2a2ffee 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mod_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Names diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index 7f35530f..58a80869 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mod_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Declarations diff --git a/kernel/modops.ml b/kernel/modops.ml index 2cac5334..02662adf 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: modops.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/kernel/modops.mli b/kernel/modops.mli index c1c262cc..9b12fea6 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: modops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/kernel/names.ml b/kernel/names.ml index 54304376..550c70b4 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: names.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/kernel/names.mli b/kernel/names.mli index 8209119c..f54df6ec 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: names.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Identifiers *) diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index f35da2d2..bad04af5 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pre_env.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index ac51e49d..80f382c6 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pre_env.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/reduction.ml b/kernel/reduction.ml index cd4902c5..00e8014f 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: reduction.ml 13354 2010-07-29 16:44:45Z barras $ *) open Util open Names @@ -253,7 +253,8 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with | (Sort s1, Sort s2) -> - assert (is_empty_stack v1 && is_empty_stack v2); + if not (is_empty_stack v1 && is_empty_stack v2) then + anomaly "conversion was given ill-typed terms (Sort)"; sort_cmp cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if n=m @@ -313,14 +314,16 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* other constructors *) | (FLambda _, FLambda _) -> - assert (is_empty_stack v1 && is_empty_stack v2); + if not (is_empty_stack v1 && is_empty_stack v2) then + anomaly "conversion was given ill-typed terms (FLambda)"; let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1 | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> - assert (is_empty_stack v1 && is_empty_stack v2); + if not (is_empty_stack v1 && is_empty_stack v2) then + anomaly "conversion was given ill-typed terms (FProd)"; (* Luo's system *) let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1 diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 28691fa1..83a858cf 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: reduction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 69c830e7..799bce47 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: retroknowledge.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Names diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index c0854361..2a4878e9 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: retroknowledge.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f8154f19..dee2f5e8 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: safe_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 0443dcf2..446ee75b 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: safe_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/sign.ml b/kernel/sign.ml index 44b35970..0d4887ec 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: sign.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Util diff --git a/kernel/sign.mli b/kernel/sign.mli index f470377b..313118e4 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: sign.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index f8cbd840..cbff43ad 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: subtyping.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 32bca5df..d3736fd9 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: subtyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Univ diff --git a/kernel/term.ml b/kernel/term.ml index 4c0a8890..b031f750 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: term.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This module instantiates the structure of generic deBruijn terms to Coq *) diff --git a/kernel/term.mli b/kernel/term.mli index f1e78246..f9e11df5 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: term.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 8054eff7..8cd9b909 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: term_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index b731f813..4d32be1e 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: term_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 65a9d76a..033dde90 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: type_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Term diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index f93ddb6c..38ee5058 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: type_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/typeops.ml b/kernel/typeops.ml index ee29da42..7527e3e7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: typeops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/kernel/typeops.mli b/kernel/typeops.mli index a3ec5a64..aaacf3c5 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typeops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/kernel/univ.ml b/kernel/univ.ml index 03550cbd..77c14b10 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: univ.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Initial Caml version originates from CoC 4.8 [Dec 1988] *) (* Extension with algebraic universes by HH [Sep 2001] *) diff --git a/kernel/univ.mli b/kernel/univ.mli index d71c4832..da01879c 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: univ.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Universes. *) diff --git a/kernel/vm.ml b/kernel/vm.ml index 35032c6b..ceb8ea9c 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: vm.ml 13363 2010-07-30 16:17:24Z barras $ *) open Names open Term @@ -16,7 +16,7 @@ open Cbytecodes external set_drawinstr : unit -> unit = "coq_set_drawinstr" (******************************************) -(* Fonctions en plus du module Obj ********) +(* Utility Functions about Obj ************) (******************************************) external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" @@ -25,7 +25,7 @@ external offset : Obj.t -> int = "coq_offset" let accu_tag = 0 (*******************************************) -(* Initalisation de la machine abstraite ***) +(* Initalization of the abstract machine ***) (*******************************************) external init_vm : unit -> unit = "init_coq_vm" @@ -36,15 +36,13 @@ external transp_values : unit -> bool = "get_coq_transp_value" external set_transp_values : bool -> unit = "coq_set_transp_value" (*******************************************) -(* Le code machine ************************) +(* Machine code *** ************************) (*******************************************) type tcode let tcode_of_obj v = ((Obj.obj v):tcode) let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) - - external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" external mkAccuCond : int -> tcode = "coq_accucond" @@ -73,12 +71,12 @@ let popstop_code i = let stop = popstop_code 0 (******************************************************) -(* Types de donnees abstraites et fonctions associees *) +(* Abstract data types and utility functions **********) (******************************************************) (* Values of the abstract machine *) let val_of_obj v = ((Obj.obj v):values) -let crasy_val = (val_of_obj (Obj.repr 0)) +let crazy_val = (val_of_obj (Obj.repr 0)) (* Abstract data *) type vprod @@ -99,63 +97,60 @@ type vswitch = { sw_env : vm_env } -(* Representation des types abstraits: *) -(* + Les produits : *) +(* Representation of values *) +(* + Products : *) (* - vprod = 0_[ dom | codom] *) (* dom : values, codom : vfun *) (* *) -(* + Les fonctions ont deux representations possibles : *) -(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *) +(* + Functions have two representations : *) +(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) -(* Remarque : il n'y a pas de difference entre la fct et son *) -(* environnement. *) -(* - Application partielle : Ct_[Restart:C| vf | arg1 | ... argn] *) +(* Remark : a function and its environment is the same value. *) +(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) (* *) -(* + Les points fixes : *) +(* + Fixpoints : *) (* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) -(* Remarque il n'y a qu'un seul block pour representer tout les *) -(* points fixes d'une declaration mutuelle, chaque point fixe *) -(* pointe sur la position de son code dans le block. *) -(* - L'application partielle d'un point fixe suit le meme schema *) -(* que celui des fonctions *) -(* Remarque seul les points fixes qui n'ont pas encore recu leur *) -(* argument recursif sont encode de cette maniere (si l'argument *) -(* recursif etait un constructeur le point fixe se serait reduit *) -(* sinon il est represente par un accumulateur) *) +(* One single block to represent all of the fixpoints, each fixpoint *) +(* is the pointer to the field holding the pointer to its code, and *) +(* the infix tag is used to know where the block starts. *) +(* - Partial application follows the scheme of partially applied *) +(* functions. Note: only fixpoints not having been applied to its *) +(* recursive argument are coded this way. When the rec. arg. is *) +(* applied, either it's a constructor and the fix reduces, or it's *) +(* and the fix is coded as an accumulator. *) (* *) -(* + Les cofix sont expliques dans cbytegen.ml *) +(* + Cofixpoints : see cbytegen.ml *) (* *) -(* + Les vblock encodent les constructeurs (non constant) de caml, *) -(* la difference est que leur tag commence a 1 (0 est reserve pour les *) -(* accumulateurs : accu_tag) *) +(* + vblock's encode (non constant) constructors as in Ocaml, but *) +(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) +(* accumulators. *) (* *) -(* + vm_env est le type des environnement machine (une fct ou un pt fixe) *) +(* + vm_env is the type of the machine environments (i.e. a function or *) +(* a fixpoint) *) (* *) -(* + Les accumulateurs : At_[accumulate| accu | arg1 | ... | argn ] *) -(* - representation des [accu] : tag_[....] *) -(* -- tag <= 2 : encodage du type atom *) -(* -- 3_[accu|fix_app] : un point fixe bloque par un accu *) -(* -- 4_[accu|vswitch] : un case bloque par un accu *) -(* -- 5_[fcofix] : une fonction de cofix *) -(* -- 6_[fcofix|val] : une fonction de cofix, val represente *) -(* la valeur de la reduction de la fct applique a arg1 ... argn *) -(* Le type [arguments] est utiliser de maniere abstraite comme un *) -(* tableau, il represente la structure de donnee suivante : *) +(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) +(* - representation of [accu] : tag_[....] *) +(* -- tag <= 2 : encoding atom type (sorts, free vars, etc.) *) +(* -- 3_[accu|fix_app] : a fixpoint blocked by an accu *) +(* -- 4_[accu|vswitch] : a match blocked by an accu *) +(* -- 5_[fcofix] : a cofix function *) +(* -- 6_[fcofix|val] : a cofix function, val represent the value *) +(* of the function applied to arg1 ... argn *) +(* The [arguments] type, which is abstracted as an array, represents : *) (* tag[ _ | _ |v1|... | vn] *) -(* Generalement le 1er champs est un pointeur de code *) +(* Generally the first field is a code pointer. *) -(* Ne pas changer ce type sans modifier le code C, *) -(* en particulier le fichier "coq_values.h" *) +(* Do not edit this type without editing C code, especially "coq_values.h" *) type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive -(* Les zippers *) +(* Zippers *) type zipper = | Zapp of arguments - | Zfix of vfix*arguments (* Peut-etre vide *) + | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch type stack = zipper list @@ -193,28 +188,20 @@ let rec whd_accu a stk = let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in whd_accu (Obj.field at 0) (zswitch :: stk) | 5 (* cofix_tag *) -> + let vcfx = Obj.obj (Obj.field at 0) in + let to_up = Obj.obj a in begin match stk with - | [] -> - let vcfx = Obj.obj (Obj.field at 0) in - let to_up = Obj.obj a in - Vcofix(vcfx, to_up, None) - | [Zapp args] -> - let vcfx = Obj.obj (Obj.field at 0) in - let to_up = Obj.obj a in - Vcofix(vcfx, to_up, Some args) + | [] -> Vcofix(vcfx, to_up, None) + | [Zapp args] -> Vcofix(vcfx, to_up, Some args) | _ -> assert false end | 6 (* cofix_evaluated_tag *) -> + let vcofix = Obj.obj (Obj.field at 0) in + let res = Obj.obj a in begin match stk with - | [] -> - let vcofix = Obj.obj (Obj.field at 0) in - let res = Obj.obj a in - Vcofix(vcofix, res, None) - | [Zapp args] -> - let vcofix = Obj.obj (Obj.field at 0) in - let res = Obj.obj a in - Vcofix(vcofix, res, Some args) - | _ -> assert false + | [] -> Vcofix(vcofix, res, None) + | [Zapp args] -> Vcofix(vcofix, res, Some args) + | _ -> assert false end | _ -> assert false @@ -245,7 +232,7 @@ let whd_val : values -> whd = (************************************************) -(* La machine abstraite *************************) +(* Abstrct machine ******************************) (************************************************) (* gestion de la pile *) @@ -291,7 +278,7 @@ let apply_vstack vf vstk = end (**********************************************) -(* Constructeurs ******************************) +(* Constructors *******************************) (**********************************************) let obj_of_atom : atom -> Obj.t = @@ -349,11 +336,11 @@ let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) + (*************************************************) -(** Operations pour la manipulation des donnees **) +(** Operations manipulating data types ***********) (*************************************************) - (* Functions over products *) let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) @@ -395,13 +382,13 @@ exception FALSE let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in - (* Verification du point de depart *) + (* Checking starting point *) if i1 = i2 then let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in let n = Obj.size (last fb1) in - (* Verification du nombre de definition *) + (* Checking number of definitions *) if n = Obj.size (last fb2) then - (* Verification des arguments recursifs *) + (* Checking recursive arguments *) try for i = 0 to n - 1 do if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i @@ -439,14 +426,14 @@ let relaccu_code i = let reduce_fix k vf = let fb = first (Obj.repr vf) in - (* calcul des types *) + (* computing types *) let fc_typ = ((Obj.obj (last fb)) : tcode array) in let ndef = Array.length fc_typ in let et = offset_closure fb (2*(ndef - 1)) in let ftyp = Array.map - (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in - (* Construction de l' environnement des corps des points fixes *) + (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in + (* Construction of the environment of fix bodies *) let e = Obj.dup fb in for i = 0 to ndef - 1 do Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) @@ -485,9 +472,10 @@ let reduce_cofix k vcf = let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in let ndef = Array.length fc_typ in let ftyp = - Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in - (* Construction de l'environnement des corps des cofix *) + (* Evaluate types *) + Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in + (* Construction of the environment of cofix bodies *) let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) @@ -522,7 +510,7 @@ let case_info sw = sw.sw_annot.ci let type_of_switch sw = push_vstack sw.sw_stk; - interprete sw.sw_type_code crasy_val sw.sw_env 0 + interprete sw.sw_type_code crazy_val sw.sw_env 0 let branch_arg k (tag,arity) = if arity = 0 then ((Obj.magic tag):values) diff --git a/lib/bigint.ml b/lib/bigint.ml index 084189a8..b33baa83 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: bigint.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (*i*) open Pp diff --git a/lib/bigint.mli b/lib/bigint.mli index 01bfedac..48e36875 100644 --- a/lib/bigint.mli +++ b/lib/bigint.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: bigint.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/lib/bstack.ml b/lib/bstack.ml index 6330afec..4afbe41e 100644 --- a/lib/bstack.ml +++ b/lib/bstack.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: bstack.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Queues of a given length *) diff --git a/lib/bstack.mli b/lib/bstack.mli index 057bace3..b34d18d7 100644 --- a/lib/bstack.mli +++ b/lib/bstack.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: bstack.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Bounded stacks. If the depth is [None], then there is no depth limit. *) @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: dyn.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util diff --git a/lib/dyn.mli b/lib/dyn.mli index 290907b1..512baf7f 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: dyn.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Dynamics. Use with extreme care. Not for kids. *) diff --git a/lib/edit.ml b/lib/edit.ml index 18d8d8dc..edfde186 100644 --- a/lib/edit.ml +++ b/lib/edit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: edit.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/lib/edit.mli b/lib/edit.mli index 4274846e..3d6f98ab 100644 --- a/lib/edit.mli +++ b/lib/edit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: edit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* The type of editors. * An editor is a finite map, ['a -> 'b], which knows how to apply diff --git a/lib/explore.ml b/lib/explore.ml index c20726aa..c6a40e04 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: explore.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Format diff --git a/lib/explore.mli b/lib/explore.mli index b7fe7a5a..f8180577 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: explore.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Search strategies. *) diff --git a/lib/flags.ml b/lib/flags.ml index 2961d83f..de70b6a6 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: flags.ml 13358 2010-07-29 23:10:17Z herbelin $ i*) let with_option o f x = let old = !o in o:=true; @@ -35,8 +35,6 @@ let dont_load_proofs = ref false let raw_print = ref false -let unicode_syntax = ref false - (* Compatibility mode *) type compat_version = V8_2 diff --git a/lib/flags.mli b/lib/flags.mli index 87c8e792..75cfc96d 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: flags.mli 13358 2010-07-29 23:10:17Z herbelin $ i*) (* Global options of the system. *) @@ -27,8 +27,6 @@ val dont_load_proofs : bool ref val raw_print : bool ref -val unicode_syntax : bool ref - type compat_version = V8_2 val compat_version : compat_version option ref val version_strictly_greater : compat_version -> bool diff --git a/lib/gmap.ml b/lib/gmap.ml index 41a57276..1544dacc 100644 --- a/lib/gmap.ml +++ b/lib/gmap.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: gmap.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Maps using the generic comparison function of ocaml. Code borrowed from the ocaml standard library (Copyright 1996, INRIA). *) diff --git a/lib/gmap.mli b/lib/gmap.mli index 3e125a60..379aa63f 100644 --- a/lib/gmap.mli +++ b/lib/gmap.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: gmap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Maps using the generic comparison function of ocaml. Same interface as the module [Map] from the ocaml standard library. *) diff --git a/lib/gmapl.ml b/lib/gmapl.ml index 87804bb5..5f539971 100644 --- a/lib/gmapl.ml +++ b/lib/gmapl.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: gmapl.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util diff --git a/lib/gmapl.mli b/lib/gmapl.mli index 95a80a29..7c5d0ceb 100644 --- a/lib/gmapl.mli +++ b/lib/gmapl.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: gmapl.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Maps from ['a] to lists of ['b]. *) diff --git a/lib/gset.ml b/lib/gset.ml index fca46496..dc88127e 100644 --- a/lib/gset.ml +++ b/lib/gset.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: gset.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Sets using the generic comparison function of ocaml. Code borrowed from the ocaml standard library. *) diff --git a/lib/gset.mli b/lib/gset.mli index 570ce5e0..911ff3f0 100644 --- a/lib/gset.mli +++ b/lib/gset.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: gset.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Sets using the generic comparison function of ocaml. Same interface as the module [Set] from the ocaml standard library. *) diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 6841132e..1ebf8773 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: hashcons.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Hash consing of datastructures *) diff --git a/lib/hashcons.mli b/lib/hashcons.mli index 3fbf3c9b..0ce4d3b9 100644 --- a/lib/hashcons.mli +++ b/lib/hashcons.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: hashcons.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Generic hash-consing. *) diff --git a/lib/heap.ml b/lib/heap.ml index 5f70b5f2..47cfb46f 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: heap.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (*s Heaps *) diff --git a/lib/heap.mli b/lib/heap.mli index edafef5d..e46f97ac 100644 --- a/lib/heap.mli +++ b/lib/heap.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: heap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Heaps *) diff --git a/lib/option.ml b/lib/option.ml index e5b9ecd3..850d7306 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: option.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Module implementing basic combinators for OCaml option type. It tries follow closely the style of OCaml standard library. diff --git a/lib/option.mli b/lib/option.mli index 03e989d3..c76deb3c 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: option.mli 13323 2010-07-24 15:57:30Z herbelin $ *) (** Module implementing basic combinators for OCaml option type. It tries follow closely the style of OCaml standard library. @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp_control @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp_control diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 54e8fa0c..507a54a7 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pp_control.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Parameters of pretty-printing *) diff --git a/lib/pp_control.mli b/lib/pp_control.mli index c1540e72..bf95bb5e 100644 --- a/lib/pp_control.mli +++ b/lib/pp_control.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pp_control.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Parameters of pretty-printing. *) diff --git a/lib/predicate.ml b/lib/predicate.ml index af66c0f2..506a87c9 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -10,7 +10,7 @@ (* *) (************************************************************************) -(* $Id$ *) +(* $Id: predicate.ml 12337 2009-09-17 15:58:14Z glondu $ *) (* Sets over ordered types *) diff --git a/lib/predicate.mli b/lib/predicate.mli index 41d5399b..85596fea 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,5 +1,5 @@ -(*i $Id$ i*) +(*i $Id: predicate.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) (* Module [Pred]: sets over infinite ordered types with complement. *) diff --git a/lib/profile.ml b/lib/profile.ml index b612f31d..87bfe624 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: profile.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Gc diff --git a/lib/profile.mli b/lib/profile.mli index bde8587c..e61aba85 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: profile.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s This program is a small time and allocation profiler for Objective Caml *) diff --git a/lib/rtree.ml b/lib/rtree.ml index 55b00a93..a7428e12 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: rtree.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util diff --git a/lib/rtree.mli b/lib/rtree.mli index 3013199a..17cccfc8 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: rtree.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Type of regular tree with nodes labelled by values of type 'a *) (* The implementation uses de Bruijn indices, so binding capture diff --git a/lib/system.ml b/lib/system.ml index 7e7dfbcb..17d211f8 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: system.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/lib/system.mli b/lib/system.mli index 44314c23..971a5c86 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: system.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Files and load paths. Load path entries remember the original root given by the user. For efficiency, we keep the full path (field @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tlm.ml 13323 2010-07-24 15:57:30Z herbelin $ *) type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t diff --git a/lib/tlm.mli b/lib/tlm.mli index 95a788ff..db3d7dd3 100644 --- a/lib/tlm.mli +++ b/lib/tlm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tlm.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Tries. This module implements a data structure [('a,'b) t] mapping lists of values of type ['a] to sets (as lists) of values of type ['b]. *) diff --git a/lib/util.ml b/lib/util.ml index 6d04c3c2..851afc60 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: util.ml 13357 2010-07-29 22:59:55Z herbelin $ *) open Pp @@ -43,6 +43,7 @@ let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s) let located_fold_left f x (_,a) = f x a let located_iter2 f (_,a) (_,b) = f a b +let down_located f (_,a) = f a (* Like Exc_located, but specifies the outermost file read, the filename associated to the location of the error, and the error itself. *) @@ -66,6 +67,11 @@ let pi1 (a,_,_) = a let pi2 (_,a,_) = a let pi3 (_,_,a) = a +(* Projection operator *) + +let down_fst f x = f (fst x) +let down_snd f x = f (snd x) + (* Characters *) let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z') @@ -700,6 +706,16 @@ let list_split_when p = in split_when_loop [] +(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of + [l1] satisfy [p] and elements of [l2] do not *) +let list_split_by p = + let rec split_by_loop = function + | [] -> ([],[]) + | a::l -> + let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2) + in + split_by_loop + let rec list_split3 = function | [] -> ([], [], []) | (x,y,z)::l -> @@ -828,6 +844,13 @@ let list_cartesians op init ll = let list_combinations l = list_cartesians (fun x l -> x::l) [] l +let rec list_combine3 x y z = + match x, y, z with + | [], [], [] -> [] + | (x :: xs), (y :: ys), (z :: zs) -> + (x, y, z) :: list_combine3 xs ys zs + | _, _, _ -> raise (Invalid_argument "list_combine3") + (* Keep only those products that do not return None *) let rec list_cartesian_filter op l1 l2 = @@ -1171,6 +1194,12 @@ let iterate_for a b f x = let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in iterate a x +(* Delayed computations *) + +type 'a delayed = unit -> 'a + +let delayed_force f = f () + (* Misc *) type ('a,'b) union = Inl of 'a | Inr of 'b diff --git a/lib/util.mli b/lib/util.mli index cd8e3135..00c73a1f 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id$ i*) +(*i $Id: util.mli 13357 2010-07-29 22:59:55Z herbelin $ i*) (*i*) open Pp @@ -52,6 +52,7 @@ val invalid_arg_loc : loc * string -> 'a val join_loc : loc -> loc -> loc val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit +val down_located : ('a -> 'b) -> 'a located -> 'b (* Like [Exc_located], but specifies the outermost file read, the input buffer associated to the location of the error (or the module name @@ -64,6 +65,11 @@ exception Error_in_file of string * (bool * string * loc) * exn val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b +(* Going down pairs *) + +val down_fst : ('a -> 'b) -> 'a * 'c -> 'b +val down_snd : ('a -> 'b) -> 'c * 'a -> 'b + (* Mapping under triple *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd @@ -170,6 +176,7 @@ val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list val list_subset : 'a list -> 'a list -> bool val list_split_at : int -> 'a list -> 'a list*'a list val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list +val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list val list_firstn : int -> 'a list -> 'a list @@ -202,7 +209,9 @@ val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list (* list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) val list_combinations : 'a list list -> 'a list list -(* Keep only those products that do not return None *) +val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list + +(** Keep only those products that do not return None *) val list_cartesian_filter : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list val list_cartesians_filter : @@ -272,7 +281,13 @@ val iterate : ('a -> 'a) -> int -> 'a -> 'a val repeat : int -> ('a -> unit) -> 'a -> unit val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a -(*s Misc. *) +(** {6 Delayed computations. } *) + +type 'a delayed = unit -> 'a + +val delayed_force : 'a delayed -> 'a + +(** {6 Misc. } *) type ('a,'b) union = Inl of 'a | Inr of 'b diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 583ecd6f..0bb052be 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_kinds.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Libnames diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli index 99c07227..2d31932f 100644 --- a/library/decl_kinds.mli +++ b/library/decl_kinds.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_kinds.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Libnames diff --git a/library/declare.ml b/library/declare.ml index 630f28ed..4f5bf2bb 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: declare.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (** This module is about the low-level declaration of logical objects *) diff --git a/library/declare.mli b/library/declare.mli index dc45cf0e..f2a61180 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: declare.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/library/declaremods.ml b/library/declaremods.ml index 6a002081..ef8f2ddd 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: declaremods.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/library/declaremods.mli b/library/declaremods.mli index 5045d110..51455ff6 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: declaremods.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/library/decls.ml b/library/decls.ml index db292a7e..83d5ea08 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decls.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (** This module registers tables for some non-logical informations associated declarations *) diff --git a/library/decls.mli b/library/decls.mli index 93979882..0bb66fe5 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: decls.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Sign diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml index 1fd4d9c3..a8ee5e96 100644 --- a/library/dischargedhypsmap.ml +++ b/library/dischargedhypsmap.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: dischargedhypsmap.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Libnames diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli index a0198f3e..77bcf2df 100644 --- a/library/dischargedhypsmap.mli +++ b/library/dischargedhypsmap.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: dischargedhypsmap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Libnames diff --git a/library/global.ml b/library/global.ml index c17e3011..5139c252 100644 --- a/library/global.ml +++ b/library/global.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: global.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/library/global.mli b/library/global.mli index 5675cf68..4290aaa0 100644 --- a/library/global.mli +++ b/library/global.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: global.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/library/goptions.ml b/library/goptions.ml index f35588b5..bfd3b272 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: goptions.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This module manages customization parameters at the vernacular level *) diff --git a/library/goptions.mli b/library/goptions.mli index 69b09d48..d2f98cd2 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: goptions.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* This module manages customization parameters at the vernacular level *) diff --git a/library/heads.ml b/library/heads.ml index a8011206..52f98e6d 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: heads.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/library/heads.mli b/library/heads.mli index 6f3117ad..156b1307 100644 --- a/library/heads.mli +++ b/library/heads.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: heads.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Term diff --git a/library/impargs.ml b/library/impargs.ml index 431e694d..2aff1dec 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: impargs.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/library/impargs.mli b/library/impargs.mli index 219c75c5..1c27d9f5 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: impargs.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/library/lib.ml b/library/lib.ml index efdd0d84..fde67940 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: lib.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/library/lib.mli b/library/lib.mli index 15357708..3abe22ec 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: lib.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s This module provides a general mechanism to keep a trace of all operations diff --git a/library/libnames.ml b/library/libnames.ml index b544c8f5..d81dc60f 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: libnames.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/library/libnames.mli b/library/libnames.mli index 97a49601..5dcb61ea 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: libnames.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/library/libobject.ml b/library/libobject.ml index 55a9aa08..5c7d27c6 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: libobject.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/library/libobject.mli b/library/libobject.mli index 212118a8..130708aa 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: libobject.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/library/library.ml b/library/library.ml index c183e86b..c8fd89bf 100644 --- a/library/library.ml +++ b/library/library.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: library.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/library/library.mli b/library/library.mli index 201e5c3a..e835843d 100644 --- a/library/library.mli +++ b/library/library.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: library.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/library/nameops.ml b/library/nameops.ml index 5649fd2c..fad4f44c 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: nameops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/library/nameops.mli b/library/nameops.mli index a3fc8bdc..91434361 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: nameops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names diff --git a/library/nametab.ml b/library/nametab.ml index 495c0062..c8d6967c 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: nametab.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/library/nametab.mli b/library/nametab.mli index bb0a3323..386f3d55 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: nametab.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/library/states.ml b/library/states.ml index 972d562a..3af2bcd7 100644 --- a/library/states.ml +++ b/library/states.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: states.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open System diff --git a/library/states.mli b/library/states.mli index 35a05e9e..198e1632 100644 --- a/library/states.mli +++ b/library/states.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: states.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s States of the system. In that module, we provide functions to get and set the state of the whole system. Internally, it is done by diff --git a/library/summary.ml b/library/summary.ml index 63ce4c27..376f41d7 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: summary.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/library/summary.mli b/library/summary.mli index 8a7f5ed1..00301613 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: summary.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* This module registers the declaration of global tables, which will be kept in synchronization during the various backtracks of the system. *) diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 6baff5da..8bc7ad02 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: argextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Genarg open Q_util diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 67492e3e..943a9487 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: egrammar.ml 13329 2010-07-26 11:05:39Z herbelin $ *) open Pp open Util @@ -66,41 +66,52 @@ type grammar_constr_prod_item = type 'a action_env = 'a list * 'a list list let make_constr_action - (f : loc -> constr_expr action_env -> constr_expr) pil = - let rec make (env,envlist as fullenv : constr_expr action_env) = function + (f : loc -> constr_notation_substitution -> constr_expr) pil = + let rec make (constrs,constrlists,binders as fullsubst) = function | [] -> - Gramext.action (fun loc -> f loc fullenv) + Gramext.action (fun loc -> f loc fullsubst) | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make fullenv tl) + Gramext.action (fun _ -> make fullsubst tl) | GramConstrNonTerminal (typ, Some _) :: tl -> (* parse a binding non-terminal *) - (match typ with - | (ETConstr _| ETOther _) -> - Gramext.action (fun (v:constr_expr) -> make (v :: env, envlist) tl) - | ETReference -> - Gramext.action (fun (v:reference) -> make (CRef v :: env, envlist) tl) - | ETName -> - Gramext.action (fun (na:name located) -> - make (constr_expr_of_name na :: env, envlist) tl) - | ETBigint -> - Gramext.action (fun (v:Bigint.bigint) -> - make (CPrim (dummy_loc,Numeral v) :: env, envlist) tl) - | ETConstrList (_,n) -> - Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl) + (match typ with + | (ETConstr _| ETOther _) -> + Gramext.action (fun (v:constr_expr) -> + make (v :: constrs, constrlists, binders) tl) + | ETReference -> + Gramext.action (fun (v:reference) -> + make (CRef v :: constrs, constrlists, binders) tl) + | ETName -> + Gramext.action (fun (na:name located) -> + make (constr_expr_of_name na :: constrs, constrlists, binders) tl) + | ETBigint -> + Gramext.action (fun (v:Bigint.bigint) -> + make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl) + | ETConstrList (_,n) -> + Gramext.action (fun (v:constr_expr list) -> + make (constrs, v::constrlists, binders) tl) + | ETBinder _ | ETBinderList (true,_) -> + Gramext.action (fun (v:local_binder list) -> + make (constrs, constrlists, v::binders) tl) + | ETBinderList (false,_) -> + Gramext.action (fun (v:local_binder list list) -> + make (constrs, constrlists, List.flatten v::binders) tl) | ETPattern -> failwith "Unexpected entry of type cases pattern") | GramConstrListMark (n,b) :: tl -> (* Rebuild expansions of ConstrList *) - let heads,env = list_chop n env in - if b then make (env,(heads@List.hd envlist)::List.tl envlist) tl - else make (env,heads::envlist) tl + let heads,constrs = list_chop n constrs in + let constrlists = + if b then (heads@List.hd constrlists)::List.tl constrlists + else heads::constrlists + in make (constrs, constrlists, binders) tl in - make ([],[]) (List.rev pil) + make ([],[],[]) (List.rev pil) let make_cases_pattern_action - (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = - let rec make (env,envlist as fullenv : cases_pattern_expr action_env) = function + (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil = + let rec make (env,envlist as fullenv) = function | [] -> Gramext.action (fun loc -> f loc fullenv) | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> @@ -123,7 +134,7 @@ let make_cases_pattern_action | ETConstrList (_,_) -> Gramext.action (fun (vl:cases_pattern_expr list) -> make (env, vl :: envlist) tl) - | (ETPattern | ETOther _) -> + | (ETPattern | ETBinderList _ | ETBinder _ | ETOther _) -> failwith "Unexpected entry of type cases pattern or other") | GramConstrListMark (n,b) :: tl -> (* Rebuild expansions of ConstrList *) @@ -271,7 +282,10 @@ type notation_grammar = int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list type all_grammar_command = - | Notation of (precedence * tolerability list) * notation_grammar + | Notation of + (precedence * tolerability list) * + notation_var_internalization_type list * + notation_grammar | TacticGrammar of (string * int * grammar_prod_item list * (dir_path * Tacexpr.glob_tactic_expr)) @@ -280,14 +294,16 @@ let (grammar_state : all_grammar_command list ref) = ref [] let extend_grammar gram = (match gram with - | Notation (_,a) -> extend_constr_notation a + | Notation (_,_,a) -> extend_constr_notation a | TacticGrammar g -> add_tactic_entry g); grammar_state := gram :: !grammar_state let recover_notation_grammar ntn prec = let l = map_succeed (function - | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x - | _ -> failwith "") !grammar_state in + | Notation (prec',vars,(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> + vars, x + | _ -> + failwith "") !grammar_state in assert (List.length l = 1); List.hd l diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index decc263d..f6b9f6ad 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: egrammar.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) (*i*) open Util @@ -48,7 +48,12 @@ type grammar_prod_item = (* Adding notations *) type all_grammar_command = - | Notation of (precedence * tolerability list) * notation_grammar + | Notation of + (precedence * tolerability list) + * notation_var_internalization_type list + (** not needed for defining grammar, hosted by egrammar for + transmission to interp_aconstr (via recover_notation_grammar) *) + * notation_grammar | TacticGrammar of (string * int * grammar_prod_item list * (dir_path * Tacexpr.glob_tactic_expr)) @@ -64,5 +69,8 @@ val extend_vernac_command_grammar : val get_extend_vernac_grammars : unit -> (string * grammar_prod_item list list) list +(** For a declared grammar, returns the rule + the ordered entry types + of variables in the rule (for use in the interpretation) *) val recover_notation_grammar : - notation -> (precedence * tolerability list) -> notation_grammar + notation -> (precedence * tolerability list) -> + notation_var_internalization_type list * notation_grammar diff --git a/parsing/extend.ml b/parsing/extend.ml index 5e79cbd5..92ca4dd1 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extend.ml 13329 2010-07-26 11:05:39Z herbelin $ i*) open Util @@ -45,16 +45,18 @@ type production_level = type ('lev,'pos) constr_entry_key_gen = | ETName | ETReference | ETBigint + | ETBinder of bool | ETConstr of ('lev * 'pos) | ETPattern | ETOther of string * string | ETConstrList of ('lev * 'pos) * Token.pattern list + | ETBinderList of bool * Token.pattern list (* Entries level (left-hand-side of grammar rules) *) type constr_entry_key = (int,unit) constr_entry_key_gen -(* Entries used in productions (in right-hand-side of grammar rules) *) +(* Entries used in productions (in right-hand side of grammar rules) *) type constr_prod_entry_key = (production_level,production_position) constr_entry_key_gen diff --git a/parsing/extend.mli b/parsing/extend.mli index 5e79cbd5..ad371872 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extend.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) open Util @@ -45,10 +45,12 @@ type production_level = type ('lev,'pos) constr_entry_key_gen = | ETName | ETReference | ETBigint + | ETBinder of bool | ETConstr of ('lev * 'pos) | ETPattern | ETOther of string * string | ETConstrList of ('lev * 'pos) * Token.pattern list + | ETBinderList of bool * Token.pattern list (* Entries level (left-hand-side of grammar rules) *) type constr_entry_key = diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml index e56c2e12..e12e2593 100644 --- a/parsing/extrawit.ml +++ b/parsing/extrawit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extrawit.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Genarg diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli index 02b71ddc..1a1b6fe4 100644 --- a/parsing/extrawit.mli +++ b/parsing/extrawit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extrawit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Genarg diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index bba3d0d6..76b761b1 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_constr.ml4 13359 2010-07-30 08:46:55Z herbelin $ *) open Pp open Pcoq @@ -34,11 +34,6 @@ let mk_cast = function (c,(_,None)) -> c | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty)) -let loc_of_binder_let = function - | LocalRawAssum ((loc,_)::_,_,_)::_ -> loc - | LocalRawDef ((loc,_),_)::_ -> loc - | _ -> dummy_loc - let binders_of_lidents l = List.map (fun (loc, id) -> LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, @@ -88,8 +83,8 @@ let lpar_id_coloneq = | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) -let impl_ident = - Gram.Entry.of_parser "impl_ident" +let impl_ident_head = + Gram.Entry.of_parser "impl_ident_head" (fun strm -> match Stream.npeek 1 strm with | [(_,"{")] -> @@ -126,13 +121,13 @@ let ident_with = | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) -let aliasvar = function CPatAlias (_, _, id) -> Some (Name id) | _ -> None +let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr sort global constr_pattern lconstr_pattern Constr.ident - binder binder_let binders_let record_declaration - binders_let_fixannot typeclass_constraint pattern appl_arg; + closed_binder open_binders binder binders binders_fixannot + record_declaration typeclass_constraint pattern appl_arg; Constr.ident: [ [ id = Prim.ident -> id @@ -204,7 +199,7 @@ GEXTEND Gram | "("; c = operconstr LEVEL "200"; ")" -> (match c with CPrim (_,Numeral z) when Bigint.is_pos_or_zero z -> - CNotation(loc,"( _ )",([c],[])) + CNotation(loc,"( _ )",([c],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c | "`{"; c = operconstr LEVEL "200"; "}" -> @@ -214,14 +209,10 @@ GEXTEND Gram ] ] ; forall: - [ [ "forall" -> () - | IDENT "Î " -> () - ] ] + [ [ "forall" -> () ] ] ; lambda: - [ [ "fun" -> () - | IDENT "λ" -> () - ] ] + [ [ "fun" -> () ] ] ; record_declaration: [ [ fs = LIST1 record_field_declaration SEP ";" -> CRecord (loc, None, fs) @@ -234,13 +225,13 @@ GEXTEND Gram (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ] ; binder_constr: - [ [ forall; bl = binder_list; ","; c = operconstr LEVEL "200" -> + [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" -> mkCProdN loc bl c - | lambda; bl = binder_list; [ "=>" | "," ]; c = operconstr LEVEL "200" -> + | lambda; bl = open_binders; [ "=>" | "," ]; c = operconstr LEVEL "200" -> mkCLambdaN loc bl c - | "let"; id=name; bl = binders_let; ty = type_cstr; ":="; + | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - let loc1 = loc_of_binder_let bl in + let loc1 = join_loc (local_binders_loc bl) (constr_loc c1) in CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2) | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" -> let fixp = mk_single_fix fx in @@ -253,7 +244,7 @@ GEXTEND Gram po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CLetTuple (loc,List.map snd lb,po,c1,c2) + CLetTuple (loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)]) @@ -298,7 +289,7 @@ GEXTEND Gram | "cofix" -> false ] ] ; fix_decl: - [ [ id=identref; bl=binders_let_fixannot; ty=type_cstr; ":="; + [ [ id=identref; bl=binders_fixannot; ty=type_cstr; ":="; c=operconstr LEVEL "200" -> (id,fst bl,snd bl,c,ty) ] ] ; @@ -310,14 +301,14 @@ GEXTEND Gram [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] ; pred_pattern: - [ [ ona = OPT ["as"; id=name -> snd id]; + [ [ ona = OPT ["as"; id=name -> id]; ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] ; return_type: - [ [ a = OPT [ na = OPT["as"; id=name -> snd id]; + [ [ a = OPT [ na = OPT["as"; na=name -> na]; ty = case_type -> (na,ty) ] -> match a with | None -> None, None @@ -365,15 +356,7 @@ GEXTEND Gram | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n)) | s = string -> CPatPrim (loc, String s) ] ] ; - binder_list: - [ [ idl=LIST1 name; bl=binders_let -> - LocalRawAssum (idl,Default Explicit,CHole (loc, Some (Evd.BinderType (snd (List.hd idl)))))::bl - | idl=LIST1 name; ":"; c=lconstr -> - [LocalRawAssum (idl,Default Explicit,c)] - | cl = binders_let -> cl - ] ] - ; - binder_assum: + impl_ident_tail: [ [ "}" -> fun id -> LocalRawAssum([id], Default Implicit, CHole(loc, None)) | idl=LIST1 name; ":"; c=lconstr; "}" -> (fun id -> LocalRawAssum (id::idl,Default Implicit,c)) @@ -390,47 +373,59 @@ GEXTEND Gram rel=OPT constr; "}" -> (id, CMeasureRec (m,rel)) ] ] ; - binders_let_fixannot: - [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot -> - (assum (loc, Name id) :: fst bl), snd bl - | f = fixannot -> [], f - | b = binder_let; bl = binders_let_fixannot -> b @ fst bl, snd bl - | -> [], (None, CStructRec) + binders_fixannot: + [ [ id = impl_ident_head; assum = impl_ident_tail; bl = binders_fixannot -> + (assum (loc, Name id) :: fst bl), snd bl + | f = fixannot -> [], f + | b = binder; bl = binders_fixannot -> b @ fst bl, snd bl + | -> [], (None, CStructRec) ] ] ; - binders_let: - [ [ b = binder_let; bl = binders_let -> b @ bl - | -> [] ] ] - ; - binder_let: - [ [ id=name -> - [LocalRawAssum ([id],Default Explicit,CHole (loc, None))] - | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> - [LocalRawAssum (id::idl,Default Explicit,c)] - | "("; id=name; ":"; c=lconstr; ")" -> - [LocalRawAssum ([id],Default Explicit,c)] - | "("; id=name; ":="; c=lconstr; ")" -> - [LocalRawDef (id,c)] - | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> - [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))] - | "{"; id=name; "}" -> - [LocalRawAssum ([id],Default Implicit,CHole (loc, None))] - | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> - [LocalRawAssum (id::idl,Default Implicit,c)] - | "{"; id=name; ":"; c=lconstr; "}" -> - [LocalRawAssum ([id],Default Implicit,c)] - | "{"; id=name; idl=LIST1 name; "}" -> - List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) - | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> - List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc - | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> - List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc + open_binders: + (* Same as binders but parentheses around a closed binder are optional if + the latter is unique *) + [ [ (* open binder *) + id = name; idl = LIST0 name; ":"; c = lconstr -> + [LocalRawAssum (id::idl,Default Explicit,c)] + (* binders factorized with open binder *) + | id = name; idl = LIST0 name; bl = binders -> + let t = CHole (loc, Some (Evd.BinderType (snd id))) in + LocalRawAssum (id::idl,Default Explicit,t)::bl + | id1 = name; ".."; id2 = name -> + [LocalRawAssum ([id1;(loc,Name ldots_var);id2], + Default Explicit,CHole (loc,None))] + | bl = closed_binder; bl' = binders -> + bl@bl' ] ] ; + binders: + [ [ l = LIST0 binder -> List.flatten l ] ] + ; binder: - [ [ id=name -> ([id],Default Explicit,CHole (loc, None)) - | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c) - | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c) + [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))] + | bl = closed_binder -> bl ] ] + ; + closed_binder: + [ [ "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> + [LocalRawAssum (id::idl,Default Explicit,c)] + | "("; id=name; ":"; c=lconstr; ")" -> + [LocalRawAssum ([id],Default Explicit,c)] + | "("; id=name; ":="; c=lconstr; ")" -> + [LocalRawDef (id,c)] + | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> + [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))] + | "{"; id=name; "}" -> + [LocalRawAssum ([id],Default Implicit,CHole (loc, None))] + | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> + [LocalRawAssum (id::idl,Default Implicit,c)] + | "{"; id=name; ":"; c=lconstr; "}" -> + [LocalRawAssum ([id],Default Implicit,c)] + | "{"; id=name; idl=LIST1 name; "}" -> + List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) + | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> + List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc + | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> + List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc ] ] ; typeclass_constraint: diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4 index c9da8779..0aa8272b 100644 --- a/parsing/g_decl_mode.ml4 +++ b/parsing/g_decl_mode.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: g_decl_mode.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Decl_expr diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index d5c8b78b..e0f31b98 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_ltac.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli index 5ad93c9e..21335332 100644 --- a/parsing/g_natsyntax.mli +++ b/parsing/g_natsyntax.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: g_natsyntax.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Nice syntax for naturals. *) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 5c2fadbb..a7ed810d 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(*i $Id$ i*) +(*i $Id: g_prim.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pcoq open Names diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 779e4b22..df23465e 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_proofs.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pcoq diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 324119ed..4a1b9c63 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_tactic.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Pcoq diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index c3ea4d22..1f5a6cf9 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -9,7 +9,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_vernac.ml4 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp @@ -134,9 +134,9 @@ GEXTEND Gram gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = binders_let; ":"; c = lconstr; + [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = identref; bl = binders_let; ":"; c = lconstr -> + [ "with"; id = identref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c,None)) ] -> VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -170,7 +170,7 @@ GEXTEND Gram ; gallina_ext: [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; - ps = binders_let; + ps = binders; s = OPT [ ":"; s = lconstr -> s ]; cfs = [ ":="; l = constructor_list_or_record_decl -> l | -> RecordDecl (None, []) ] -> @@ -231,13 +231,13 @@ GEXTEND Gram ; (* Simple definitions *) def_body: - [ [ bl = binders_let; ":="; red = reduce; c = lconstr -> + [ [ bl = binders; ":="; red = reduce; c = lconstr -> (match c with CCast(_,c, Rawterm.CastConv (k,t)) -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) - | bl = binders_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> + | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> DefineBody (bl, red, c, Some t) - | bl = binders_let; ":"; t = lconstr -> + | bl = binders; ":"; t = lconstr -> ProveBody (bl, t) ] ] ; reduce: @@ -254,7 +254,7 @@ GEXTEND Gram ; (* Inductives and records *) inductive_definition: - [ [ id = identref; oc = opt_coercion; indpar = binders_let; + [ [ id = identref; oc = opt_coercion; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; ":="; lc = constructor_list_or_record_decl; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -281,13 +281,13 @@ GEXTEND Gram (* (co)-fixpoints *) rec_definition: [ [ id = identref; - bl = binders_let_fixannot; + bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: - [ [ id = identref; bl = binders_let; ty = type_cstr; + [ [ id = identref; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -305,6 +305,10 @@ GEXTEND Gram IDENT "Sort"; s = sort-> InductionScheme(true,ind,s) | IDENT "Minimality"; "for"; ind = smart_global; IDENT "Sort"; s = sort-> InductionScheme(false,ind,s) + | IDENT "Elimination"; "for"; ind = smart_global; + IDENT "Sort"; s = sort-> CaseScheme(true,ind,s) + | IDENT "Case"; "for"; ind = smart_global; + IDENT "Sort"; s = sort-> CaseScheme(false,ind,s) | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ] ; (* Various Binders *) @@ -324,12 +328,12 @@ GEXTEND Gram [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ] ; record_binder_body: - [ [ l = binders_let; oc = of_type_with_opt_coercion; + [ [ l = binders; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t)) - | l = binders_let; oc = of_type_with_opt_coercion; + | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> fun id -> (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) - | l = binders_let; ":="; b = lconstr -> fun id -> + | l = binders; ":="; b = lconstr -> fun id -> match b with | CCast(_,b, Rawterm.CastConv (_, t)) -> (false,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t))) @@ -352,7 +356,7 @@ GEXTEND Gram ; constructor_type: - [[ l = binders_let; + [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> fun l id -> (coe,(id,mkCProdN loc l c)) | -> @@ -527,7 +531,7 @@ GEXTEND Gram t = class_rawexpr -> VernacCoercion (use_locality_exp (), ByNotation ntn, s, t) - | IDENT "Context"; c = binders_let -> + | IDENT "Context"; c = binders -> VernacContext c | IDENT "Instance"; namesup = instance_name; ":"; @@ -577,7 +581,7 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = identref; sup = OPT binders_let -> + [ [ name = identref; sup = OPT binders -> (let (loc,id) = name in (loc, Name id)), (Option.default [] sup) | -> (loc, Anonymous), [] ] ] @@ -922,6 +926,8 @@ GEXTEND Gram syntax_extension_type: [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference | IDENT "bigint" -> ETBigint + | IDENT "binder" -> ETBinder true + | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; opt_scope: diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index b75d55c5..5ad9f664 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo" i*) -(* $Id$ *) +(* $Id: g_xml.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli index 74637969..16b1ba65 100644 --- a/parsing/g_zsyntax.mli +++ b/parsing/g_zsyntax.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: g_zsyntax.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Nice syntax for integers. *) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 59b1a048..cc48c84f 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -10,7 +10,7 @@ (* Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with * ast-based camlp4 *) -(*i $Id$ i*) +(*i $Id: lexer.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 35836f5c..a25774c5 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: lexer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 6a85775d..90a9220f 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*) -(*i $Id$ i*) +(*i $Id: pcoq.ml4 13329 2010-07-26 11:05:39Z herbelin $ i*) open Pp open Util @@ -313,10 +313,11 @@ module Constr = let pattern = Gram.Entry.create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" let lconstr_pattern = gec_constr "lconstr_pattern" + let closed_binder = Gram.Entry.create "constr:closed_binder" let binder = Gram.Entry.create "constr:binder" - let binder_let = Gram.Entry.create "constr:binder_let" - let binders_let = Gram.Entry.create "constr:binders_let" - let binders_let_fixannot = Gram.Entry.create "constr:binders_let_fixannot" + let binders = Gram.Entry.create "constr:binders" + let open_binders = Gram.Entry.create "constr:open_binders" + let binders_fixannot = Gram.Entry.create "constr:binders_fixannot" let typeclass_constraint = Gram.Entry.create "constr:typeclass_constraint" let record_declaration = Gram.Entry.create "constr:record_declaration" let appl_arg = Gram.Entry.create "constr:appl_arg" @@ -563,10 +564,15 @@ let compute_entry allow_create adjust forpat = function else weaken_entry Constr.operconstr), adjust (n,q), false | ETName -> weaken_entry Prim.name, None, false + | ETBinder true -> anomaly "Should occur only as part of BinderList" + | ETBinder false -> weaken_entry Constr.binder, None, false + | ETBinderList (true,tkl) -> + assert (tkl=[]); weaken_entry Constr.open_binders, None, false + | ETBinderList (false,_) -> anomaly "List of entries cannot be registered." | ETBigint -> weaken_entry Prim.bigint, None, false | ETReference -> weaken_entry Constr.global, None, false | ETPattern -> weaken_entry Constr.pattern, None, false - | ETConstrList _ -> error "List of entries cannot be registered." + | ETConstrList _ -> anomaly "List of entries cannot be registered." | ETOther (u,n) -> let u = get_univ u in let e = @@ -606,6 +612,12 @@ let is_binder_level from e = ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true | _ -> false +let make_sep_rules tkl = + Gramext.srules + [List.map (fun x -> Gramext.Stoken x) tkl, + List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl + (Gramext.action (fun loc -> ()))] + let rec symbol_of_constr_prod_entry_key assoc from forpat typ = if is_binder_level from typ then if forpat then @@ -621,10 +633,14 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = | ETConstrList (typ',tkl) -> Gramext.Slist1sep (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), - Gramext.srules - [List.map (fun x -> Gramext.Stoken x) tkl, - List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl - (Gramext.action (fun loc -> ()))]) + make_sep_rules tkl) + | ETBinderList (false,[]) -> + Gramext.Slist1 + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) + | ETBinderList (false,tkl) -> + Gramext.Slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), + make_sep_rules tkl) | _ -> match interp_constr_prod_entry_key assoc from forpat typ with | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 88bf9c1c..e4566e77 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pcoq.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) open Util open Names @@ -203,10 +203,11 @@ module Constr : val pattern : cases_pattern_expr Gram.Entry.e val constr_pattern : constr_expr Gram.Entry.e val lconstr_pattern : constr_expr Gram.Entry.e - val binder : (name located list * binder_kind * constr_expr) Gram.Entry.e - val binder_let : local_binder list Gram.Entry.e - val binders_let : local_binder list Gram.Entry.e - val binders_let_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e + val closed_binder : local_binder list Gram.Entry.e + val binder : local_binder list Gram.Entry.e (* closed_binder or variable *) + val binders : local_binder list Gram.Entry.e + val open_binders : local_binder list Gram.Entry.e + val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e val typeclass_constraint : (name located * bool * constr_expr) Gram.Entry.e val record_declaration : constr_expr Gram.Entry.e val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index fcdc2aee..eef28fcf 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ppconstr.ml 13358 2010-07-29 23:10:17Z herbelin $ *) (*i*) open Util @@ -64,8 +64,8 @@ let prec_of_prim_token = function open Notation -let print_hunks n pr (env,envlist) unp = - let env = ref env and envlist = ref envlist in +let print_hunks n pr pr_binders (terms,termlists,binders) unp = + let env = ref terms and envlist = ref termlists and bll = ref binders in let pop r = let a = List.hd !r in r := List.tl !r; a in let rec aux = function | [] -> mt () @@ -76,6 +76,8 @@ let print_hunks n pr (env,envlist) unp = let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in let pp2 = aux l in pp1 ++ pp2 + | UnpBinderListMetaVar (_,isopen,sl) :: l -> + let cl = pop bll in pr_binders (fun () -> aux sl) isopen cl ++ aux l | UnpTerminal s :: l -> str s ++ aux l | UnpBox (b,sub) :: l -> (* Keep order: side-effects *) @@ -85,9 +87,9 @@ let print_hunks n pr (env,envlist) unp = | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in aux unp -let pr_notation pr s env = +let pr_notation pr pr_binders s env = let unpl, level = find_notation_printing_rule s in - print_hunks level pr env unpl, level + print_hunks level pr pr_binders env unpl, level let pr_delimiters key strm = strm ++ str ("%"^key) @@ -191,7 +193,8 @@ let rec pr_patt sep inh p = hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator | CPatNotation (_,"( _ )",([p],[])) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom - | CPatNotation (_,s,env) -> pr_notation (pr_patt mt) s env + | CPatNotation (_,s,(l,ll)) -> + pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) | CPatPrim (_,p) -> pr_prim_token p, latom | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1 in @@ -254,18 +257,22 @@ let pr_binder_among_many pr_c = function hov 1 (pr_lname na ++ pr_opt_type pr_c topt ++ str":=" ++ cut() ++ pr_c c) -let pr_undelimited_binders pr_c = - prlist_with_sep spc (pr_binder_among_many pr_c) +let pr_undelimited_binders sep pr_c = + prlist_with_sep sep (pr_binder_among_many pr_c) -let pr_delimited_binders kw pr_c bl = +let pr_delimited_binders kw sep pr_c bl = let n = begin_of_binders bl in match bl with | [LocalRawAssum (nal,k,t)] -> pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t) | LocalRawAssum _ :: _ as bdl -> - pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl + pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl | _ -> assert false +let pr_binders_gen pr_c sep is_open = + if is_open then pr_delimited_binders mt sep pr_c + else pr_undelimited_binders sep pr_c + let rec extract_prod_binders = function (* | CLetIn (loc,na,b,c) as x -> let bl,c = extract_prod_binders c in @@ -399,7 +406,7 @@ let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = let pr_body = if dangling_with_for then pr_dangling else pr in pr_id id ++ str" " ++ - hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++ + hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++ pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c @@ -446,7 +453,7 @@ let tm_clash = function let pr_asin pr (na,indnalopt) = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) - | Some na -> spc () ++ str "as " ++ pr_name na + | Some na -> spc () ++ str "as " ++ pr_lname na | None -> mt ()) ++ (match indnalopt with | None -> mt () @@ -465,7 +472,7 @@ let pr_return_type pr po = pr_case_type pr po let pr_simple_return_type pr na po = (match na with - | Some (Name id) -> + | Some (_,Name id) -> spc () ++ str "as " ++ pr_id id | _ -> mt ()) ++ pr_case_type pr po @@ -483,15 +490,11 @@ let pr_app pr a l = pr (lapp,L) a ++ prlist (fun a -> spc () ++ pr_expl_args pr a) l) -let pr_forall () = - if !Flags.unicode_syntax then str"Î " ++ spc () - else str"forall" ++ spc () +let pr_forall () = str"forall" ++ spc () -let pr_fun () = - if !Flags.unicode_syntax then str"λ" ++ spc () - else str"fun" ++ spc () +let pr_fun () = str"fun" ++ spc () -let pr_fun_sep = lazy (if !Flags.unicode_syntax then str "," else str " =>") +let pr_fun_sep = str " =>" let pr_dangling_with_for sep pr inherited a = @@ -519,16 +522,16 @@ let pr pr sep inherited a = | CProdN _ -> let (bl,a) = extract_prod_binders a in hov 0 ( - hov 2 (pr_delimited_binders pr_forall + hov 2 (pr_delimited_binders pr_forall spc (pr mt ltop) bl) ++ str "," ++ pr spc ltop a), lprod | CLambdaN _ -> let (bl,a) = extract_lam_binders a in hov 0 ( - hov 2 (pr_delimited_binders pr_fun + hov 2 (pr_delimited_binders pr_fun spc (pr mt ltop) bl) ++ - Lazy.force pr_fun_sep ++ pr spc ltop a), + pr_fun_sep ++ pr spc ltop a), llambda | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b) when x=x' -> @@ -599,7 +602,7 @@ let pr pr sep inherited a = hv 0 ( str "let " ++ hov 0 (str "(" ++ - prlist_with_sep sep_v pr_name nal ++ + prlist_with_sep sep_v pr_lname nal ++ str ")" ++ pr_simple_return_type (pr mt) na po ++ str " :=" ++ pr spc ltop c ++ str " in") ++ @@ -626,9 +629,10 @@ let pr pr sep inherited a = | CCast (_,a,CastCoerce) -> hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"), lcast - | CNotation (_,"( _ )",([t],[])) -> + | CNotation (_,"( _ )",([t],[],[])) -> pr (fun()->str"(") (max_int,L) t ++ str")", latom - | CNotation (_,s,env) -> pr_notation (pr mt) s env + | CNotation (_,s,env) -> + pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1 @@ -700,7 +704,7 @@ let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c let pr_cases_pattern_expr = pr_patt ltop -let pr_binders = pr_undelimited_binders (pr ltop) +let pr_binders = pr_undelimited_binders spc (pr ltop) let pr_with_occurrences pr occs = match occs with diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 0d566a5d..1ad110cb 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ppconstr.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Environ diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml index b276444f..275b02df 100644 --- a/parsing/ppdecl_proof.ml +++ b/parsing/ppdecl_proof.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ppdecl_proof.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index ba7558f7..f27959c2 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pptactic.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Names diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index 46786997..bb9d8426 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pptactic.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Genarg diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 83fcff7e..ff35be57 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ppvernac.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Names @@ -113,7 +113,9 @@ let pr_set_entry_type = function | ETConstr _ -> str"constr" | ETOther (_,e) -> str e | ETBigint -> str "bigint" - | ETConstrList _ -> failwith "Internal entry type" + | ETBinder true -> str "binder" + | ETBinder false -> str "closed binder" + | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type" let strip_meta id = let s = string_of_id id in @@ -330,6 +332,14 @@ let pr_onescheme (idop,schem) = hov 0 ((if dep then str"Induction for" else str"Minimality for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ hov 0 (str"Sort" ++ spc() ++ pr_rawsort s) + | CaseScheme (dep,ind,s) -> + (match idop with + | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() + | None -> spc () + ) ++ + hov 0 ((if dep then str"Elimination for" else str"Case for") + ++ spc() ++ pr_smart_global ind) ++ spc() ++ + hov 0 (str"Sort" ++ spc() ++ pr_rawsort s) | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli index f1322914..dce1bbd7 100644 --- a/parsing/ppvernac.mli +++ b/parsing/ppvernac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ppvernac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Genarg diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 8f12ec6d..9c39e57e 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -10,7 +10,7 @@ * on May-June 2006 for implementation of abstraction of pretty-printing of objects. *) -(* $Id$ *) +(* $Id: prettyp.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index 9cda516e..d7f83b63 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: prettyp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/parsing/printer.ml b/parsing/printer.ml index 54d7065c..c9f27678 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: printer.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/parsing/printer.mli b/parsing/printer.mli index 63493768..a6f73a40 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: printer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 index 84340cae..fff29083 100644 --- a/parsing/q_constr.ml4 +++ b/parsing/q_constr.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: q_constr.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Rawterm open Term diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 0f2ef78b..d0afcdd4 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*) -(* $Id$ *) +(* $Id: q_coqast.ml4 13329 2010-07-26 11:05:39Z herbelin $ *) open Util open Names @@ -162,11 +162,10 @@ let rec mlexpr_of_constr = function | Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >> | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" - | Topconstr.CNotation(_,ntn,subst) -> + | Topconstr.CNotation(_,ntn,(subst,substl,[])) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ - $mlexpr_of_pair - (mlexpr_of_list mlexpr_of_constr) - (mlexpr_of_list (mlexpr_of_list mlexpr_of_constr)) subst$ >> + ($mlexpr_of_list mlexpr_of_constr subst$, + $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >> | Topconstr.CPatVar (loc,n) -> <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >> | _ -> failwith "mlexpr_of_constr: TODO" diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index a23e4b18..6d6c229c 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: q_util.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) (* This file defines standard combinators to build ml expressions *) diff --git a/parsing/q_util.mli b/parsing/q_util.mli index 7617dc53..c55d8482 100644 --- a/parsing/q_util.mli +++ b/parsing/q_util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: q_util.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val patt_of_expr : MLast.expr -> MLast.patt diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index 465465fa..f067fcf3 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: tacextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Genarg diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml index ff87ac03..3d048c30 100644 --- a/parsing/tactic_printer.ml +++ b/parsing/tactic_printer.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tactic_printer.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli index 3584f626..9233233f 100644 --- a/parsing/tactic_printer.mli +++ b/parsing/tactic_printer.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tactic_printer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 05c5ef86..95eccfda 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -8,7 +8,7 @@ (*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*) -(* $Id$ *) +(* $Id: vernacextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Genarg diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index c2f19c4f..4171aceb 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ccalgo.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This file implements the basic congruence-closure algorithm by *) (* Downey,Sethi and Tarjan. *) diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 02e03a97..2825be1a 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ccalgo.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Term diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index cb1f4725..5ee17b6e 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ccproof.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 141d2e13..4c75f9b0 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ccproof.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Ccalgo open Names diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 2f8a4527..b7358121 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: cctac.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This file is the interface between the c-c algorithm and Coq *) diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 05200a33..1c07cabf 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: cctac.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Proof_type diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 722e7fa4..bed77a7b 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_congruence.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Cctac open Tactics diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v index bc7d73f6..5ddc4452 100644 --- a/plugins/dp/Dp.v +++ b/plugins/dp/Dp.v @@ -6,7 +6,7 @@ Require Export Classical. (* Zenon *) (* Copyright 2004 INRIA *) -(* $Id$ *) +(* $Id: Dp.v 12337 2009-09-17 15:58:14Z glondu $ *) Lemma zenon_nottrue : (~True -> False). diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 index d28873a0..9c61aad5 100644 --- a/plugins/dp/g_dp.ml4 +++ b/plugins/dp/g_dp.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_dp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Dp diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v index 502465c6..f2400a7f 100644 --- a/plugins/dp/zenon.v +++ b/plugins/dp/zenon.v @@ -1,5 +1,5 @@ (* Copyright 2004 INRIA *) -(* $Id$ *) +(* $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $ *) Require Export Classical. diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index c9556972..882bcae9 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -8,6 +8,8 @@ (** Extraction to Ocaml : use of basic Ocaml types *) +Scheme Equality for nat. + Extract Inductive bool => bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive unit => unit [ "()" ]. diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 72429055..ca72f873 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: common.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 0d2258a8..619cddfb 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: common.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Libnames diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 36df8d16..58d8fcb1 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extract_env.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Term open Declarations diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 7520e6c8..b4516898 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extract_env.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s This module declares the extraction commands. *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index f031094a..057057d1 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extraction.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 394e5ab7..0574b009 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extraction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Extraction from Coq terms to Miniml. *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index dd1e7149..57b7c365 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: haskell.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Production of Haskell syntax. *) diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index 915b8a95..0b68e73b 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: haskell.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val haskell_descr : Miniml.language_descr diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index d768ec96..7ff11b90 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: miniml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Target language for extraction: a core ML called MiniML. *) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 2c63e588..745a78fe 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mlutil.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index a692e6d5..d6b85f12 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mlutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Names diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 8369ba91..15145344 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: modutil.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Declarations diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 5a159dc7..bb405d60 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: modutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Declarations diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index ae8ec249..36ca3713 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ocaml.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Production of Ocaml syntax. *) diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index 646b1c8b..477b4351 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ocaml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val ocaml_descr : Miniml.language_descr diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 82fac0b6..fa293ba1 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: scheme.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Production of Scheme syntax. *) diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli index 7bb97cf9..e413d31e 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: scheme.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) val scheme_descr : Miniml.language_descr diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index e33e1e06..fd640388 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: table.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 96592f19..a3199b50 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: table.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Libnames diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v index b0e1bc97..6c825353 100644 --- a/plugins/field/LegacyField.v +++ b/plugins/field/LegacyField.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyField.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export LegacyField_Compl. Require Export LegacyField_Theory. diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v index 6d4e49ab..a3b46900 100644 --- a/plugins/field/LegacyField_Compl.v +++ b/plugins/field/LegacyField_Compl.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyField_Compl.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import List. diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v index 1b04c11a..9c92e38a 100644 --- a/plugins/field/LegacyField_Tactic.v +++ b/plugins/field/LegacyField_Tactic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyField_Tactic.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import List. Require Import LegacyRing. diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v index c7eed29a..2407026f 100644 --- a/plugins/field/LegacyField_Theory.v +++ b/plugins/field/LegacyField_Theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyField_Theory.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import List. Require Import Peano_dec. diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 index 6d3cb25c..47f52370 100644 --- a/plugins/field/field.ml4 +++ b/plugins/field/field.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: field.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Pp diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 93c4504c..d039a930 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: formula.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Hipattern open Names diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 558eb876..fbb103c0 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: formula.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Names diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 7451bcd2..19b63407 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_ground.ml4 13344 2010-07-28 15:04:36Z msozeau $ *) open Formula open Sequent @@ -54,7 +54,21 @@ let _= in declare_int_option gdopt -let default_solver=(Tacinterp.interp <:tactic<auto with *>>) +let (set_default_solver, default_solver, print_default_solver) = + Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver" + +VERNAC COMMAND EXTEND Firstorder_Set_Solver +| [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ + set_default_solver + (Vernacexpr.use_section_locality ()) + (Tacinterp.glob_tactic t) ] +END + +VERNAC COMMAND EXTEND Firstorder_Print_Solver +| [ "Print" "Firstorder" "Solver" ] -> [ + Pp.msgnl + (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] +END let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") @@ -65,7 +79,7 @@ let gen_ground_tac flag taco ids bases gl= let solver= match taco with Some tac-> tac - | None-> default_solver in + | None-> snd (default_solver ()) in let startseq gl= let seq=empty_seq !ground_depth in extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in @@ -137,7 +151,7 @@ let default_declarative_automation gls = (Cctac.congruence_tac !congruence_depth [])) (gen_ground_tac true (Some (tclTHEN - default_solver + (snd (default_solver ())) (Cctac.congruence_tac !congruence_depth []))) [] []) gls diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 766fa0d3..354bcda2 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ground.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Formula open Sequent diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index 3daf66d6..ba8051da 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ground.mli 13323 2010-07-24 15:57:30Z herbelin $ *) val ground_tac: Tacmach.tactic -> (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 7da65f08..714604ae 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: instances.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Formula open Sequent diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 49716cc6..8b913719 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: instances.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Term open Tacmach diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index a35173cd..9cff67dc 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: rules.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 070c1dbe..ec6d2bd0 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: rules.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Tacmach diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 43be5714..1d439693 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: sequent.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Util diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index c310aaff..1232f1e8 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: sequent.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Util diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 27eca654..835b0409 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: unify.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Formula diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 1412a23e..af2ce01d 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: unify.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Term diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 2304ddbe..05e85cde 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Fourier.v 13323 2010-07-24 15:57:30Z herbelin $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v index 152bbc04..3cd26cb8 100644 --- a/plugins/fourier/Fourier_util.v +++ b/plugins/fourier/Fourier_util.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Fourier_util.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Rbase. Comments "Lemmas used by the tactic Fourier". diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index 081246da..16123fd7 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: fourier.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Méthode d'élimination de Fourier *) (* Référence: diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 0af2849e..e9392e78 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: fourierR.ml 13323 2010-07-24 15:57:30Z herbelin $ *) diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index c6976ff7..d3b8228d 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_fourier.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open FourierR diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e2cad944..3590e698 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1345,7 +1345,6 @@ and acc_inv_id = Recdef.acc_inv_id and ltof_ref = Recdef.ltof_ref and acc_rel = Recdef.acc_rel and well_founded = Recdef.well_founded -and delayed_force = Recdef.delayed_force and h_intros = Recdef.h_intros and list_rewrite = Recdef.list_rewrite and evaluable_of_global_reference = Recdef.evaluable_of_global_reference diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 38f42844..f5a5fbd4 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -169,9 +169,8 @@ let build_newrecursive let arityc = Topconstr.prod_constr_expr arityc bl in let arity = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in - (Environ.push_named (recname,None,arity) env, (recname,impl) :: impls)) + (Environ.push_named (recname,None,arity) env, (recname, impl) :: impls)) (env0,[]) lnameargsardef in - let rec_impls = Constrintern.set_internalization_env_params rec_impls [] in let recdef = (* Declare local notations *) let fs = States.freeze() in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 7b592c2a..9c4cc78a 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: recdef.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Term open Termops @@ -281,8 +281,6 @@ let find_reference sl s = (List.map id_of_string (List.rev sl))) (id_of_string s)));; -let delayed_force f = f () - let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm") diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 2296c6e2..3b667bf6 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -14,7 +14,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_micromega.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Quote open Ring diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz.v index 5e0ae4ef..aa32b386 100644 --- a/plugins/nsatz/Nsatz_domain.v +++ b/plugins/nsatz/Nsatz.v @@ -7,13 +7,14 @@ (************************************************************************) (* - Tactic nsatz: proofs of polynomials equalities with variables in R. - Uses Hilbert Nullstellensatz and Buchberger algorithm. - Thanks to B.Gregoire for the verification of the certicate - and L.Thery for help on ring tactic, - and to B.Barras for modularization of the ocaml code. - Example: see test-suite/success/Nsatz.v - L.Pottier, june 2010 + Tactic nsatz: proofs of polynomials equalities in a domain (ring without zero divisor). + Reification is done by type classes, following a technique shown by Mathieu +Sozeau. Verification of certificate is done by a code written by Benjamin +Gregoire, following an idea of Laurent Théry. + +Examples: see test-suite/success/Nsatz.v + +Loïc Pottier, july 2010 *) Require Import List. @@ -22,10 +23,10 @@ Require Import BinPos. Require Import BinList. Require Import Znumtheory. Require Import Ring_polynom Ring_tac InitialRing. +Require Export Morphisms Setoid Bool. Declare ML Module "nsatz_plugin". - Class Zero (A : Type) := {zero : A}. Notation "0" := zero. Class One (A : Type) := {one : A}. @@ -40,25 +41,37 @@ Class Opposite (A : Type) := {opposite : A -> A}. Notation "- x" := (opposite x). Class Ring (R:Type) := { - ring0: R; ring1: R; - ring_plus: R->R->R; ring_mult: R->R->R; - ring_sub: R->R->R; ring_opp: R->R; - ring_ring: - ring_theory ring0 ring1 ring_plus ring_mult ring_sub - ring_opp (@eq R)}. + ring0: R; ring1: R; + ring_plus: R->R->R; ring_mult: R->R->R; + ring_sub: R->R->R; ring_opp: R->R; + ring_eq : R -> R -> Prop; + ring_ring: + ring_theory ring0 ring1 ring_plus ring_mult ring_sub + ring_opp ring_eq; + ring_setoid: Equivalence ring_eq; + ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus; + ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult; + ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub; + ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp +}. Class Domain (R : Type) := { domain_ring:> Ring R; domain_axiom_product: - forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0; - domain_axiom_one_zero: ring1 <> ring0}. - -Ltac ring2 := simpl; ring. + forall x y, ring_eq (ring_mult x y) ring0 -> (ring_eq x ring0) \/ (ring_eq y ring0); + domain_axiom_one_zero: not (ring_eq ring1 ring0)}. Section domain. Variable R: Type. Variable Rd: Domain R. + +Existing Instance ring_setoid. +Existing Instance ring_plus_comp. +Existing Instance ring_mult_comp. +Existing Instance ring_sub_comp. +Existing Instance ring_opp_comp. + Add Ring Rr: (@ring_ring R (@domain_ring R Rd)). Instance zero_ring : Zero R := {zero := ring0}. @@ -68,24 +81,27 @@ Instance multiplication_ring : Multiplication R := {multiplication x y := ring_m Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}. Instance opposite_ring : Opposite R := {opposite x := ring_opp x}. -Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y. -intros x y H; replace x with ((x - y) + y); - [rewrite H | idtac]; ring2. -Qed. +Infix "==" := ring_eq (at level 70, no associativity). -Lemma psos_r1: forall x y, x = y -> x - y = 0. -intros x y H; rewrite H; ring2. +Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. +intros x y H; setoid_replace x with ((x - y) + y); simpl; + [setoid_rewrite H | idtac]; simpl; ring. Qed. +Lemma psos_r1: forall x y, x == y -> x - y == 0. +intros x y H; simpl; setoid_rewrite H; simpl; ring. +Qed. -Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0. +Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). intros. intro; apply H. -replace x with ((x - y) + y) by ring2. -rewrite H0; ring2. +simpl; setoid_replace x with ((x - y) + y). simpl. +setoid_rewrite H0. +simpl; ring. +simpl. simpl; ring. Qed. -(* code de Benjamin *) +(* adpatation du code de Benjamin aux setoides *) Require Import ZArith. Definition PolZ := Pol Z. @@ -129,42 +145,43 @@ Definition PhiR : list R -> PolZ -> R := Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n). Definition PEevalR : list R -> PEZ -> R := - PEeval 0 ring_plus ring_mult ring_sub ring_opp + PEeval 0 ring_plus ring_mult ring_sub ring_opp (gen_phiZ 0 1 ring_plus ring_mult ring_opp) Nnat.nat_of_N pow. Lemma P0Z_correct : forall l, PhiR l P0Z = 0. Proof. trivial. Qed. -Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq. -apply mk_reqe. intros. rewrite H; rewrite H0; trivial. - intros. rewrite H; rewrite H0; trivial. -intros. rewrite H; trivial. Qed. - -Lemma Rset : Setoid_Theory R eq. -apply Eqsth. +Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp ring_eq. +apply mk_reqe. intros. setoid_rewrite H; rewrite H0; ring. + intros. setoid_rewrite H; setoid_rewrite H0; ring. +intros. setoid_rewrite H; ring. Qed. + +Lemma Rset : Setoid_Theory R ring_eq. +apply ring_setoid. Qed. Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')). + PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). Proof. +simpl. refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). Qed. Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') = ((PhiR l P) * (PhiR l P')). + PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). Proof. refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). Qed. Lemma R_power_theory - : power_theory 1 ring_mult eq Nnat.nat_of_N pow. -apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed. + : power_theory 1 ring_mult ring_eq Nnat.nat_of_N pow. +apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. ring. Qed. Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe). + forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). Proof. intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory) @@ -174,7 +191,7 @@ Qed. Lemma PolZeq_correct : forall P P' l, PolZeq P P' = true -> - PhiR l P = PhiR l P'. + PhiR l P == PhiR l P'. Proof. intros;apply (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial. @@ -183,17 +200,19 @@ Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := match l with | List.nil => True - | a::l => Interp a = 0 /\ Cond0 A Interp l + | a::l => Interp a == 0 /\ Cond0 A Interp l end. Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) = 0. + PhiR l (mult_l la lp) == 0. Proof. - induction la;simpl;intros;trivial. - destruct lp;trivial. + induction la;simpl;intros. ring. + destruct lp;trivial. simpl. ring. simpl in H;destruct H. - rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial]. + setoid_rewrite PolZadd_correct. + simpl. setoid_rewrite PolZmul_correct. simpl. setoid_rewrite H. + setoid_rewrite IHla. unfold zero. simpl. ring. trivial. Qed. Lemma compute_list_correct : forall l lla lp, @@ -209,7 +228,7 @@ Lemma check_correct : forall l lpe qe certif, check lpe qe certif = true -> Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe = 0. + PEevalR l qe == 0. Proof. unfold check;intros l lpe qe (lla, lq) H2 H1. apply PolZeq_correct with (l:=l) in H2. @@ -221,53 +240,53 @@ Proof. rewrite <- norm_correct;auto. Qed. -(* fin du code de Benjamin *) +(* fin *) -Lemma pow_not_zero: forall p n, pow p n = 0 -> p = 0. -induction n. unfold pow; simpl. intros. absurd (1 = 0). +Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. +induction n. unfold pow; simpl. intros. absurd (1 == 0). simpl. apply domain_axiom_one_zero. - trivial. replace (pow p (S n)) with (p * (pow p n)). intros. -case (@domain_axiom_product _ _ _ _ H). trivial. trivial. -unfold pow; simpl. -clear IHn. induction n; try ring2. simpl. - rewrite pow_pos_Psucc. trivial. exact Rset. - intros. rewrite H; rewrite H0; trivial. - intros. ring2. intros. ring2. Qed. + trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). intros. +case (@domain_axiom_product _ _ _ _ H). trivial. trivial. +unfold pow; simpl. +clear IHn. induction n; simpl; try ring. + rewrite pow_pos_Psucc. ring. exact Rset. + intros. setoid_rewrite H; setoid_rewrite H0; ring. + intros. simpl; ring. intros. simpl; ring. Qed. -Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0. -intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto. -intros. apply pow_not_zero with r. trivial. Qed. +Lemma Rdomain_pow: forall c p r, ~c == ring0 -> ring_mult c (pow p r) == ring0 -> p == ring0. +intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c == ring0); auto. +intros. apply pow_not_zero with r. trivial. Qed. -Definition R2:= 1 + 1. +Definition R2:= ring_plus ring1 ring1. Fixpoint IPR p {struct p}: R := match p with - xH => 1 - | xO xH => 1 + 1 - | xO p1 => R2 + (IPR p1) - | xI xH => 1 + (1 + 1) - | xI p1 => 1 + (R2 * (IPR p1)) + xH => ring1 + | xO xH => ring_plus ring1 ring1 + | xO p1 => ring_mult R2 (IPR p1) + | xI xH => ring_plus ring1 (ring_plus ring1 ring1) + | xI p1 => ring_plus ring1 (ring_mult R2 (IPR p1)) end. Definition IZR1 z := - match z with Z0 => 0 + match z with Z0 => ring0 | Zpos p => IPR p - | Zneg p => -(IPR p) + | Zneg p => ring_opp(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with | (PEadd t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) + let v2 := interpret3 t2 fv in (ring_plus v1 v2) | (PEmul t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) + let v2 := interpret3 t2 fv in (ring_mult v1 v2) | (PEsub t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) + let v2 := interpret3 t2 fv in (ring_sub v1 v2) | (PEopp t1) => - let v1 := interpret3 t1 fv in (- v1) + let v1 := interpret3 t1 fv in (ring_opp v1) | (PEpow t1 t2) => let v1 := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2) | (PEc t1) => (IZR1 t1) @@ -279,14 +298,11 @@ End domain. Ltac equalities_to_goal := lazymatch goal with - | H: (@eq _ ?x 0) |- _ => try revert H - | H: (@eq _ 0 ?x) |- _ => - try generalize (sym_equal H); clear H - | H: (@eq _ ?x ?y) |- _ => + | H: (@ring_eq _ _ ?x ?y) |- _ => try generalize (@psos_r1 _ _ _ _ H); clear H end. -Ltac nsatz_domain_begin tacsimpl:= +Ltac nsatz_domain_begin tacsimpl := intros; try apply (@psos_r1b _ _); repeat equalities_to_goal; @@ -295,7 +311,7 @@ Ltac nsatz_domain_begin tacsimpl:= Ltac generalise_eq_hyps:= repeat (match goal with - |h : (?p = ?q)|- _ => revert h + |h : (@ring_eq _ _ ?p ?q)|- _ => revert h end). Ltac lpol_goal t := @@ -328,9 +344,13 @@ Ltac rev l := | (cons ?x ?l) => let l' := rev l in append1 x l' end. -Ltac nsatz_call_n info nparam p rr lp kont := + + +Ltac nsatz_call_n info nparam p rr lp kont := + (*idtac "Trying power: " rr;*) let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in - nsatz_compute ll; + nsatz_compute ll; + (*idtac "done";*) match goal with | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => intros _; @@ -344,7 +364,6 @@ Ltac nsatz_call radicalmax info nparam p lp kont := lazymatch n with | 0%N => fail | _ => -(* idtac "Trying power: " n;*) (let r := eval compute in (Nminus radicalmax (Npred n)) in nsatz_call_n info nparam p r lp kont) || let n' := eval compute in (Npred n) in try_n n' @@ -368,7 +387,7 @@ Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:= Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}. Instance Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0. Instance Ireify_one (R:Type) (Rd:Domain R) l : Creify (PEc 1%Z) l ring1. -Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} +Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} : Creify (PEadd e1 e2) l (ring_plus b1 b2). Instance Ireify_mult (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} : Creify (PEmul e1 e2) l (ring_mult b1 b2). @@ -382,7 +401,7 @@ Instance Ireify_var (R:Type) b l i `{Cfind_at R b l i} Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}. Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R). -Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2} +Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2} : Creifylist (e1::le2) l (b1::lb2). Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb} @@ -392,29 +411,29 @@ Unset Implicit Arguments. Ltac lterm_goal g := match g with - ?b1 = ?b2 => constr:(b1::b2::nil) - | ?b1 = ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) + ring_eq ?b1 ?b2 => constr:(b1::b2::nil) + | ring_eq ?b1 ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) end. -Ltac reify_goal l le lb:= +Ltac reify_goal l le lb Rd:= match le with nil => idtac - | ?e::?le1 => + | ?e::?le1 => match lb with - ?b::?lb1 => + ?b::?lb1 => (* idtac "b="; idtac b;*) let x := fresh "B" in set (x:= b) at 1; - change x with (@interpret3 _ _ e l); - clear x; - reify_goal l le1 lb1 + change x with (@interpret3 _ Rd e l); + clear x; + reify_goal l le1 lb1 Rd end end. Ltac get_lpol g := match g with - (interpret3 _ _ ?p _) = _ => constr:(p::nil) - | (interpret3 _ _ ?p _) = _ -> ?g => - let l := get_lpol g in constr:(p::l) + ring_eq (interpret3 _ _ ?p _) _ => constr:(p::nil) + | ring_eq (interpret3 _ _ ?p _) _ -> ?g => + let l := get_lpol g in constr:(p::l) end. Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd := @@ -422,7 +441,7 @@ Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd := |- ?g => let lb := lterm_goal g in (*idtac "lb"; idtac lb;*) match eval red in (li_reifyl (lb:=lb)) with - | (?fv, ?le) => + | (?fv, ?le) => let fv := match lvar with (@nil _) => fv | _ => lvar @@ -431,64 +450,111 @@ Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd := let nparam := eval compute in (Z_of_nat (List.length lparam)) in let fv := parametres_en_tete fv lparam in (*idtac "variables:"; idtac fv; - idtac "nparam:"; idtac nparam;*) + idtac "nparam:"; idtac nparam; *) match eval red in (li_reifyl (l:=fv) (lb:=lb)) with - | (?fv, ?le) => - idtac "variables:";idtac fv; - reify_goal fv le lb; - match goal with - |- ?g => - let lp := get_lpol g in + | (?fv, ?le) => + (*idtac "variables:";idtac fv; idtac le; idtac lb;*) + reify_goal fv le lb Rd; + match goal with + |- ?g => + let lp := get_lpol g in let lpol := eval compute in (List.rev lp) in (*idtac "polynomes:"; idtac lpol;*) tacsimpl; intros; - + let SplitPolyList kont := match lpol with | ?p2::?lp2 => kont p2 lp2 | _ => idtac "polynomial not in the ideal" - end in - tacsimpl; + end in + tacsimpl; SplitPolyList ltac:(fun p lp => set (p21:=p) ; set (lp21:=lp); (*idtac "lp:"; idtac lp; *) - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); + nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + set (q := PEmul c (PEpow p21 r)); + let Hg := fresh "Hg" in + assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: interpret3 _ _ q fv = ring0); - [ tacsimpl; + | let Hg2 := fresh "Hg" in + assert (Hg2: ring_eq (interpret3 _ Rd q fv) ring0); + [ tacsimpl; apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg); tacsimpl; repeat (split;[assumption|idtac]); exact I - | simpl in Hg2; tacsimpl; - apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl; - [ apply domain_axiom_one_zero || idtac "could not prove discrimination result" - | exact Hg2] + | simpl in Hg2; tacsimpl; + apply Rdomain_pow with (interpret3 _ Rd c fv) (Nnat.nat_of_N r); auto with domain; + tacsimpl; apply domain_axiom_one_zero + || (simpl) || idtac "could not prove discrimination result" ] ] -) +) ) end end end end . -Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:= - nsatz_domain_begin tacsimpl; +Ltac nsatz_domainpv pretac radicalmax info lparam lvar tacsimpl rd := + pretac; + nsatz_domain_begin tacsimpl; auto with domain; nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd. -Ltac nsatz_domain:= +Ltac nsatz_domain:= intros; match goal with - |- (@eq ?r _ _ ) => - let a := constr:(@Ireify_zero _ _ (@nil r)) in - match a with - (@Ireify_zero _ ?rd _) => - nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd - end + |- (@ring_eq _ (@domain_ring ?r ?rd) _ _ ) => + nsatz_domainpv ltac:idtac 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd end. +(* Dans R *) +Require Import Reals. +Require Import RealField. + +Instance Rri : Ring R := { + ring0 := 0%R; + ring1 := 1%R; + ring_plus := Rplus; + ring_mult := Rmult; + ring_sub := Rminus; + ring_opp := Ropp; + ring_eq := @eq R; + ring_ring := RTheory}. + +Lemma Raxiom_one_zero: 1%R <> 0%R. +discrR. +Qed. + +Instance Rdi : Domain R := { + domain_ring := Rri; + domain_axiom_product := Rmult_integral; + domain_axiom_one_zero := Raxiom_one_zero}. + +Hint Resolve ring_setoid ring_plus_comp ring_mult_comp ring_sub_comp ring_opp_comp: domain. + +Ltac replaceR:= +replace 0%R with (@ring0 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace 1%R with (@ring1 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace Rplus with (@ring_plus _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace Rmult with (@ring_mult _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace Rminus with (@ring_sub _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace Ropp with (@ring_opp _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; +replace (@eq R) with (@ring_eq _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]. + +Ltac simplR:= + simpl; replaceR. + +Ltac pretacR:= + replaceR; + replace Rri with (@domain_ring _ Rdi) in *; [idtac | reflexivity]. + +Ltac nsatz_domainR:= + nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R) + ltac:simplR Rdi; + discrR. + + +Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R. +nsatz_domainR. +Qed. (* Dans Z *) @@ -498,7 +564,8 @@ Instance Zri : Ring Z := { ring_plus := Zplus; ring_mult := Zmult; ring_sub := Zminus; - ring_opp := Zopp; + ring_opp := Zopp; + ring_eq := (@eq Z); ring_ring := Zth}. Lemma Zaxiom_one_zero: 1%Z <> 0%Z. @@ -510,49 +577,87 @@ Instance Zdi : Domain Z := { domain_axiom_product := Zmult_integral; domain_axiom_one_zero := Zaxiom_one_zero}. +Ltac replaceZ := +replace 0%Z with (@ring0 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace 1%Z with (@ring1 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace Zplus with (@ring_plus _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace Zmult with (@ring_mult _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace Zminus with (@ring_sub _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace Zopp with (@ring_opp _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; +replace (@eq Z) with (@ring_eq _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]. Ltac simplZ:= - simpl; -replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity]; -replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity]; -replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity]; -replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity]; -replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity]; -replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity]. + simpl; replaceZ. -Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi. +Ltac pretacZ := +replaceZ; +replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity]. +Ltac nsatz_domainZ:= +nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi. -(* Dans R *) -Require Import Reals. -Require Import RealField. -Instance Rri : Ring R := { - ring0 := 0%R; - ring1 := 1%R; - ring_plus := Rplus; - ring_mult := Rmult; - ring_sub := Rminus; - ring_opp := Ropp; - ring_ring := RTheory}. +(* Dans Q *) +Require Import QArith. -Lemma Raxiom_one_zero: 1%R <> 0%R. -discrR. +Instance Qri : Ring Q := { + ring0 := 0%Q; + ring1 := 1%Q; + ring_plus := Qplus; + ring_mult := Qmult; + ring_sub := Qminus; + ring_opp := Qopp; + ring_eq := Qeq; + ring_ring := Qsrt}. + +Lemma Qaxiom_one_zero: not (Qeq 1%Q 0%Q). +discriminate. Qed. -Instance Rdi : Domain R := { - domain_ring := Rri; - domain_axiom_product := Rmult_integral; - domain_axiom_one_zero := Raxiom_one_zero}. +Instance Qdi : Domain Q := { + domain_ring := Qri; + domain_axiom_product := Qmult_integral; + domain_axiom_one_zero := Qaxiom_one_zero}. +Ltac replaceQ := +replace 0%Q with (@ring0 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace 1%Q with (@ring1 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace Qplus with (@ring_plus _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace Qmult with (@ring_mult _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace Qminus with (@ring_sub _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace Qopp with (@ring_opp _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; +replace Qeq with (@ring_eq _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]. -Ltac simplR:= - simpl; -replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity]; -replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity]; -replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity]; -replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity]; -replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity]; -replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity]. - -Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi. +Ltac simplQ:= + simpl; replaceQ. + +Ltac pretacQ := +replaceQ; +replace Qri with (@domain_ring _ Qdi) in *; [idtac | reflexivity]. + +Ltac nsatz_domainQ:= +nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi. + +(* tactique générique *) + +Ltac nsatz := + intros; + match goal with + | |- (@eq R _ _) => nsatz_domainR + | |- (@eq Z _ _) => nsatz_domainZ + | |- (@Qeq _ _) => nsatz_domainQ + | |- _ => nsatz_domain + end. +(* +Goal forall x y:Q, Qeq x y -> Qeq (x*x-x+1)%Q ((y*y-y)+1+0)%Q. +nsatz. +Qed. + +Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z. +nsatz. +Qed. + +Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R. +nsatz. +Qed. +*) diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v deleted file mode 100644 index 41e02c76..00000000 --- a/plugins/nsatz/NsatzR.v +++ /dev/null @@ -1,407 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* - Tactic nsatz: proofs of polynomials equalities with variables in R. - Uses Hilbert Nullstellensatz and Buchberger algorithm. - Thanks to B.Gregoire and L.Thery for help on ring tactic, - and to B.Barras for modularization of the ocaml code. - Example: see test-suite/success/Nsatz.v - L.Pottier, june 2010 -*) - -Require Import List. -Require Import Setoid. -Require Import BinPos. -Require Import BinList. -Require Import Znumtheory. -Require Import RealField Rdefinitions Rfunctions RIneq DiscrR. -Require Import Ring_polynom Ring_tac InitialRing. - -Declare ML Module "nsatz_plugin". - -Local Open Scope R_scope. - -Lemma psos_r1b: forall x y, x - y = 0 -> x = y. -intros x y H; replace x with ((x - y) + y); - [rewrite H | idtac]; ring. -Qed. - -Lemma psos_r1: forall x y, x = y -> x - y = 0. -intros x y H; rewrite H; ring. -Qed. - -Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0. -intros. -exists (1/(x-y)). -field. -unfold not. -unfold not in H. -intros. -apply H. -replace x with ((x-y)+y). -rewrite H0. -ring. -ring. -Qed. - -Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0. -intros. -exists (1/(x)). -field. -auto. -Qed. - - -Ltac equalities_to_goal := - lazymatch goal with - | H: (@eq R ?x 0) |- _ => try revert H - | H: (@eq R 0 ?x) |- _ => - try generalize (sym_equal H); clear H - | H: (@eq R ?x ?y) |- _ => - try generalize (psos_r1 _ _ H); clear H - end. - -Lemma nsatzR_not2: 1<>0. -auto with *. -Qed. - -Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0. -intros. -intro; apply H. -replace x with (x-y+y) by ring. -rewrite H0; ring. -Qed. - -(* Removes x<>0 from hypothesis *) -Ltac nsatzR_not_hyp:= - match goal with - | H: ?x<>?y |- _ => - match y with - |0 => - let H1:=fresh "Hnsatz" in - let y:=fresh "x" in - destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H - |_ => generalize (@nsatzR_diff _ _ H); clear H; intro - end - end. - -Ltac nsatzR_not_goal := - match goal with - | |- ?x<>?y :> R => red; intro; apply nsatzR_not2 - | |- False => apply nsatzR_not2 - end. - -Ltac nsatzR_begin := - intros; - repeat nsatzR_not_hyp; - try nsatzR_not_goal; - try apply psos_r1b; - repeat equalities_to_goal. - -(* code de Benjamin *) - -Definition PolZ := Pol Z. -Definition PEZ := PExpr Z. - -Definition P0Z : PolZ := @P0 Z 0%Z. - -Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Zplus Zeq_bool. - -Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. - -Definition PolZeq := @Peq Z Zeq_bool. - -Definition norm := - @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. - -Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := - match la, lp with - | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) - | _, _ => P0Z - end. - -Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := - match lla with - | List.nil => lp - | la::lla => compute_list lla ((mult_l la lp)::lp) - end. - -Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := - let (lla, lq) := certif in - let lp := List.map norm lpe in - PolZeq (norm qe) (mult_l lq (compute_list lla lp)). - - -(* Correction *) -Definition PhiR : list R -> PolZ -> R := - (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)). - -Definition PEevalR : list R -> PEZ -> R := - PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp) - Nnat.nat_of_N pow. - -Lemma P0Z_correct : forall l, PhiR l P0Z = 0. -Proof. trivial. Qed. - - -Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') = (PhiR l P + PhiR l P'). -Proof. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) - (gen_phiZ_morph Rset Rext (F_R Rfield))). -Qed. - -Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') = (PhiR l P * PhiR l P'). -Proof. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) - (gen_phiZ_morph Rset Rext (F_R Rfield))). -Qed. - -Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe). -Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) - (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil). - compute;trivial. -Qed. - -Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> - PhiR l P = PhiR l P'. -Proof. - intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial. -Qed. - -Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with - | List.nil => True - | a::l => Interp a = 0 /\ Cond0 A Interp l - end. - -Lemma mult_l_correct : forall l la lp, - Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) = 0. -Proof. - induction la;simpl;intros;trivial. - destruct lp;trivial. - simpl in H;destruct H. - rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial]. -Qed. - -Lemma compute_list_correct : forall l lla lp, - Cond0 PolZ (PhiR l) lp -> - Cond0 PolZ (PhiR l) (compute_list lla lp). -Proof. - induction lla;simpl;intros;trivial. - apply IHlla;simpl;split;trivial. - apply mult_l_correct;trivial. -Qed. - -Lemma check_correct : - forall l lpe qe certif, - check lpe qe certif = true -> - Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe = 0. -Proof. - unfold check;intros l lpe qe (lla, lq) H2 H1. - apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. - apply mult_l_correct. - apply compute_list_correct. - clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. - rewrite <- norm_correct;auto. -Qed. - -(* fin du code de Benjamin *) - -Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0. -intros. -elim (Rmult_integral _ _ H0);intros. - absurd (c=0);auto. - - clear H0; induction r; simpl in *. - contradict H1; discrR. - - elim (Rmult_integral _ _ H1); auto. -Qed. - - -Ltac generalise_eq_hyps:= - repeat - (match goal with - |h : (?p = ?q)|- _ => revert h - end). - -Ltac lpol_goal t := - match t with - | ?a = 0 -> ?b => - let r:= lpol_goal b in - constr:(a::r) - | ?a = 0 => constr:(a::nil) - end. - -Fixpoint IPR p {struct p}: R := - match p with - xH => 1 - | xO xH => 1 + 1 - | xO p1 => 2 * (IPR p1) - | xI xH => 1 + (1 + 1) - | xI p1 => 1 + 2 * (IPR p1) - end. - -Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) - end. - -Fixpoint interpret3 t fv {struct t}: R := - match t with - | (PEadd t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => - let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2) - | (PEc t1) => (IZR1 t1) - | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 - end. - -(* lp est incluse dans fv. La met en tete. *) - -Ltac parametres_en_tete fv lp := - match fv with - | (@nil _) => lp - | (@cons _ ?x ?fv1) => - let res := AddFvTail x lp in - parametres_en_tete fv1 res - end. - -Ltac append1 a l := - match l with - | (@nil _) => constr:(cons a l) - | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') - end. - -Ltac rev l := - match l with - |(@nil _) => l - | (cons ?x ?l) => let l' := rev l in append1 x l' - end. - - -Ltac nsatz_call_n info nparam p rr lp kont := - nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp); - match goal with - | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => - intros _; - set (lci:=lci0); - set (lq:=lq0); - kont c rr lq lci - end. - -Ltac nsatz_call radicalmax info nparam p lp kont := - let rec try_n n := - lazymatch n with - | 0%N => fail - | _ => -(* idtac "Trying power: " n;*) - (let r := eval compute in (Nminus radicalmax (Npred n)) in - nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (Npred n) in try_n n' - end in - try_n radicalmax. - - -Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl := - get_Pre RNG (); - let mkFV := Ring_tac.get_RingFV RNG in - let mkPol := Ring_tac.get_RingMeta RNG in - generalise_eq_hyps; - let t := Get_goal in - let lpol := lpol_goal t in - intros; - let fv := - match lvar with - | nil => - let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let fv1 := list_fold_right mkFV fv1 lpol in - rev fv1 - (* heuristique: les dernieres variables auront le poid le plus fort *) - | _ => lvar - end in - check_fv fv; - (*idtac "variables:";idtac fv;*) - let nparam := eval compute in (Z_of_nat (List.length lparam)) in - let fv := parametres_en_tete fv lparam in - idtac "variables:"; idtac fv; - (* idtac "nparam:"; idtac nparam;*) - let lpol := list_fold_right - ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l)) - (@nil (PExpr Z)) - lpol in - let lpol := eval compute in (List.rev lpol) in - (*idtac lpol;*) - let SplitPolyList kont := - match lpol with - | ?p2::?lp2 => kont p2 lp2 - | _ => idtac "polynomial not in the ideal" - end in - SplitPolyList ltac:(fun p lp => - set (p21:=p) ; - set (lp21:=lp); - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); - [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: interpret3 q fv = 0); - [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl; - repeat (split;[assumption|idtac]); exact I - | simpl in Hg2; simpl; - apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl; - [ discrR || idtac "could not prove discrimination result" - | exact Hg2] - ] - ])). - -Ltac nsatzRpv radicalmax info lparam lvar:= - nsatzR_begin; - intros; - let G := Get_goal in - ring_lookup - (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter)) - [] G. - -Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R). -Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R). -Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R). - -Tactic Notation "nsatz" := nsatzR. -Tactic Notation "nsatz" "with" "lexico" := - nsatzRpv 6%N 2%Z (@nil R) (@nil R). -Tactic Notation "nsatz" "with" "lexico" "sugar":= - nsatzRpv 6%N 3%Z (@nil R) (@nil R). -Tactic Notation "nsatz" "without" "sugar":= - nsatzRpv 6%N 0%Z (@nil R) (@nil R). - - diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v deleted file mode 100644 index b57aa0ed..00000000 --- a/plugins/nsatz/NsatzZ.v +++ /dev/null @@ -1,73 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Reals ZArith. -Require Export NsatzR. - -Open Scope Z_scope. - -Lemma nsatzZhypR: forall x y:Z, x=y -> IZR x = IZR y. -Proof IZR_eq. (* or f_equal ... *) - -Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y. -Proof eq_IZR. - -Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y. -Proof IZR_neq. - -Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y. -Proof. -intros x y H. contradict H. f_equal. assumption. -Qed. - -Ltac nsatzZtoR1 := - repeat - (match goal with - | H:(@eq Z ?x ?y) |- _ => - generalize (@nsatzZhypR _ _ H); clear H; intro H - | |- (@eq Z ?x ?y) => apply nsatzZconclR - | H:not (@eq Z ?x ?y) |- _ => - generalize (@nsatzZhypnotR _ _ H); clear H; intro H - | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR - end). - -Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R. -Proof plus_IZR. - -Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R. -Proof mult_IZR. - -Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R. -Proof. -intros; symmetry. apply Z_R_minus. -Qed. - -Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R. -Proof. -intros. rewrite pow_IZR. -do 2 f_equal. -apply Zpos_eq_Z_of_nat_o_nat_of_P. -Qed. - -Ltac nsatzZtoR2:= - repeat - (rewrite nsatzZR1 in * || - rewrite nsatzZR2 in * || - rewrite nsatzZR3 in * || - rewrite nsatzZR4 in *). - -Ltac nsatzZ_begin := - intros; - nsatzZtoR1; - nsatzZtoR2; - simpl in *. - (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*) - -Ltac nsatzZ := - nsatzZ_begin; (*idtac "nsatzZ_begin;";*) - nsatzR. diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget index 4af4786d..06fc8834 100644 --- a/plugins/nsatz/vo.itarget +++ b/plugins/nsatz/vo.itarget @@ -1,3 +1 @@ -NsatzR.vo -Nsatz_domain.vo -NsatzZ.vo +Nsatz.vo diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v index 65b780dd..fadecf5d 100644 --- a/plugins/omega/Omega.v +++ b/plugins/omega/Omega.v @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id$ *) +(* $Id: Omega.v 13323 2010-07-24 15:57:30Z herbelin $ *) (* We do not require [ZArith] anymore, but only what's necessary for Omega *) Require Export ZArith_base. diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index 56a854d6..ec9faedd 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id$ i*) +(*i $Id: OmegaLemmas.v 12337 2009-09-17 15:58:14Z glondu $ i*) Require Import ZArith_base. Open Local Scope Z_scope. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index c0b0eb47..ee942db0 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: OmegaPlugin.v 13323 2010-07-24 15:57:30Z herbelin $ *) Declare ML Module "omega_plugin". diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 471fb5da..e3f9a309 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id$ *) +(* $Id: coq_omega.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 4be7f2e5..eefa67ec 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -15,7 +15,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_omega.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Coq_omega open Refiner diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v index ea8f5bf9..b7cc13ae 100644 --- a/plugins/quote/Quote.v +++ b/plugins/quote/Quote.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Quote.v 13323 2010-07-24 15:57:30Z herbelin $ *) Declare ML Module "quote_plugin". diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index ef87a596..83bfb6ed 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_quote.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Tacexpr diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 760f93b8..b6ca770e 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: quote.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* The `Quote' tactic *) diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v index 27349683..3e30b90f 100644 --- a/plugins/ring/LegacyArithRing.v +++ b/plugins/ring/LegacyArithRing.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *) (* Instantiation of the Ring tactic for the naturals of Arith $*) diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v index 7a2f4abc..337c3085 100644 --- a/plugins/ring/LegacyNArithRing.v +++ b/plugins/ring/LegacyNArithRing.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyNArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *) (* Instantiation of the Ring tactic for the binary natural numbers *) diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v index 5ab90555..6b655134 100644 --- a/plugins/ring/LegacyRing.v +++ b/plugins/ring/LegacyRing.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyRing.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Bool. Require Export LegacyRing_theory. diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v index 74d8f186..fb4c87fb 100644 --- a/plugins/ring/LegacyRing_theory.v +++ b/plugins/ring/LegacyRing_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyRing_theory.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Bool. diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v index 293ac12e..22fa87c8 100644 --- a/plugins/ring/LegacyZArithRing.v +++ b/plugins/ring/LegacyZArithRing.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: LegacyZArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *) (* Instantiation of the Ring tactic for the binary integers of ZArith *) diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v index 96764e51..e65e1ce8 100644 --- a/plugins/ring/Ring_abstract.v +++ b/plugins/ring/Ring_abstract.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Ring_abstract.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import LegacyRing_theory. Require Import Quote. diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v index 320e1ab2..d68fef4f 100644 --- a/plugins/ring/Ring_normalize.v +++ b/plugins/ring/Ring_normalize.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Ring_normalize.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import LegacyRing_theory. Require Import Quote. diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v index 15495071..3a3dfe84 100644 --- a/plugins/ring/Setoid_ring.v +++ b/plugins/ring/Setoid_ring.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Setoid_ring.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Setoid_ring_theory. Require Export Quote. diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v index 6bd5b419..6a53b519 100644 --- a/plugins/ring/Setoid_ring_normalize.v +++ b/plugins/ring/Setoid_ring_normalize.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Setoid_ring_normalize.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import Setoid_ring_theory. Require Import Quote. diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v index 96910db6..d55f25fc 100644 --- a/plugins/ring/Setoid_ring_theory.v +++ b/plugins/ring/Setoid_ring_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Setoid_ring_theory.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Bool. Require Export Setoid. diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4 index dc34fdbc..7fda4920 100644 --- a/plugins/ring/g_ring.ml4 +++ b/plugins/ring/g_ring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: g_ring.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Quote open Ring diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index fc2a04b3..3cdf0117 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ring.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* ML part of the Ring tactic *) diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 8e7cf569..a62a0780 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Bintree.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export List. Require Export BinPos. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index a61a2605..ffa619d0 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Rtauto.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export List. diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index 73311f63..22f8ca2a 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$*) +(* $Id: g_rtauto.ml4 13323 2010-07-24 15:57:30Z herbelin $*) (*i camlp4deps: "parsing/grammar.cma" i*) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index cf9e7fd3..23530ef8 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: proof_search.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Util diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index 5ccc59a5..685a3059 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: proof_search.mli 13323 2010-07-24 15:57:30Z herbelin $ *) type form= Atom of int diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 77ef5a9c..e079a83c 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: refl_tauto.ml 13323 2010-07-24 15:57:30Z herbelin $ *) module Search = Explore.Make(Proof_search) diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index e8264c83..2ff45f57 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: refl_tauto.mli 13323 2010-07-24 15:57:30Z herbelin $ *) (* raises Not_found if no proof is found *) diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index a5187224..8940e565 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id$ i*) +(*i $Id: newring.ml4 13332 2010-07-26 22:12:43Z msozeau $ i*) open Pp open Util @@ -531,7 +531,7 @@ let ring_equality (r,add,mul,opp,req) = (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req);Some (r,req)],Some(r,req) in + let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> @@ -544,7 +544,7 @@ let ring_equality (r,add,mul,opp,req) = match opp with | Some opp -> (let opp_m,opp_m_lem = - try Rewrite.default_morphism ([Some(r,req)],Some(r,req)) opp + try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> error "ring opposite should be declared as a morphism" in let op_morph = @@ -1031,7 +1031,7 @@ let field_equality r inv req = mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req)],Some(r,req) in + let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv with Not_found -> diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index 4b95df19..f1bdd640 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -141,16 +141,28 @@ let evar_dependencies evm ev = if Intset.equal deps deps' then deps else aux deps' in aux (Intset.singleton ev) - -let sort_dependencies evl = - List.stable_sort - (fun (id, ev, deps) (id', ev', deps') -> - if id = id' then 0 - else if Intset.mem id deps' then -1 - else if Intset.mem id' deps then 1 - else Pervasives.compare id id') - evl +let move_after (id, ev, deps as obl) l = + let rec aux restdeps = function + | (id', _, _) as obl' :: tl -> + let restdeps' = Intset.remove id' restdeps in + if Intset.is_empty restdeps' then + obl' :: obl :: tl + else obl' :: aux restdeps' tl + | [] -> [obl] + in aux (Intset.remove id deps) l + +let sort_dependencies evl = + let rec aux l found list = + match l with + | (id, ev, deps) as obl :: tl -> + let found' = Intset.union found (Intset.singleton id) in + if Intset.subset deps found' then + aux tl found' (obl :: list) + else aux (move_after obl tl) found list + | [] -> List.rev list + in aux evl Intset.empty [] + let map_evar_body f = function | Evar_empty -> Evar_empty | Evar_defined c -> Evar_defined (f c) diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli index d727c19c..262889c8 100644 --- a/plugins/subtac/eterm.mli +++ b/plugins/subtac/eterm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: eterm.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Environ open Tacmach open Term diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index 87fd0479..cd8708d5 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -14,7 +14,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id$ *) +(* $Id: g_subtac.ml4 13332 2010-07-26 22:12:43Z msozeau $ *) open Flags @@ -53,7 +53,7 @@ open Constr let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) GEXTEND Gram - GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_withtac; + GLOBAL: subtac_gallina_loc typeclass_constraint subtac_withtac; subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g @@ -65,21 +65,12 @@ GEXTEND Gram | -> None ] ] ; - Constr.binder_let: + Constr.closed_binder: [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in [LocalRawAssum ([id], default_binder_kind, typ)] ] ]; - Constr.binder: - [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> - ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)])) - | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> - ([id],default_binder_kind, c) - | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> - (id::lid,default_binder_kind, c) - ] ]; - END @@ -161,9 +152,11 @@ VERNAC COMMAND EXTEND Subtac_Set_Solver (Tacinterp.glob_tactic t) ] END +open Pp + VERNAC COMMAND EXTEND Subtac_Show_Solver | [ "Show" "Obligation" "Tactic" ] -> [ - Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ] + msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ] END VERNAC COMMAND EXTEND Subtac_Show_Obligations diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index c859c690..885f7fb6 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: subtac.ml 13344 2010-07-28 15:04:36Z msozeau $ *) open Global open Pp @@ -76,7 +76,7 @@ let start_proof_com env isevars sopt kind (bl,t) hook = (Pfedit.get_all_proof_names ()) in let evm, c, typ, imps = - Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None + Subtac_pretyping.subtac_process ~is_type:true env isevars id [] (Topconstr.prod_constr_expr t bl) None in let c = solve_tccs_in_type env id isevars evm c typ in Lemmas.start_proof id kind c (fun loc gr -> @@ -138,9 +138,6 @@ let subtac (loc, command) = Dumpglob.dump_definition lid false "def"; (match expr with | ProveBody (bl, t) -> - if Lib.is_modtype () then - errorlabstrm "Subtac_command.StartProof" - (str "Proof editing mode not supported in module types"); start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) (fun _ _ -> ()) | DefineBody (bl, _, c, tycon) -> @@ -218,33 +215,10 @@ let subtac (loc, command) = ++ x ++ spc () ++ str "and" ++ spc () ++ y in msg_warning cmds - | Cases.PatternMatchingError (env, exn) as e -> - debug 2 (Himsg.explain_pattern_matching_error env exn); - raise e + | Cases.PatternMatchingError (env, exn) as e -> raise e - | Type_errors.TypeError (env, exn) as e -> - debug 2 (Himsg.explain_type_error env exn); - raise e + | Type_errors.TypeError (env, exn) as e -> raise e - | Pretype_errors.PretypeError (env, exn) as e -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e + | Pretype_errors.PretypeError (env, exn) as e -> raise e - | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) | - Stdpp.Exc_located (loc, e') as e) -> - debug 2 (str "Parsing exception: "); - (match e' with - | Type_errors.TypeError (env, exn) -> - debug 2 (Himsg.explain_type_error env exn); - raise e - - | Pretype_errors.PretypeError (env, exn) -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e - - | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); - raise e) - - | e -> - msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); - raise e + | e -> raise e diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 28cedc8a..f6f8695b 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: subtac_cases.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Cases open Util @@ -23,13 +23,11 @@ open Sign open Reductionops open Typeops open Type_errors - open Rawterm open Retyping open Pretype_errors open Evarutil open Evarconv - open Subtac_utils (************************************************************************) @@ -125,7 +123,7 @@ type tomatch_stack = tomatch_status list originating from a subterm in which case real args are not dependent; it accounts for n+1 binders if dep or n binders if not dep - [PrProd] types abstracted term ([Abstract]); it accounts for one binder - - [PrCcl] types the right-hand-side + - [PrCcl] types the right-hand side - Aliases [Alias] have no trace in [predicate_signature] *) @@ -1152,7 +1150,7 @@ let rec generalize_problem pb = function tomatch = Abstract d :: tomatch; pred = Option.map (generalize_predicate i d) pb'.pred } -(* No more patterns: typing the right-hand-side of equations *) +(* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in let tycon = match pb.pred with @@ -1514,11 +1512,11 @@ let eq_id avoid id = let hid' = next_ident_away hid avoid in hid' -let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) +let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) let mk_JMeq typ x typ' y = - mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) -let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) + mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |]) let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) @@ -1610,7 +1608,7 @@ let vars_of_ctx ctx = | Some t' when kind_of_term t' = Rel 0 -> prev, (RApp (dummy_loc, - (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars + (RRef (dummy_loc, delayed_force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars | _ -> match na with Anonymous -> raise (Invalid_argument "vars_of_ctx") @@ -1651,7 +1649,7 @@ let build_ineqs prevpatterns pats liftsign = lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) - mkApp (Lazy.force eq_ind, + mkApp (delayed_force eq_ind, [| lift (len' + liftsign) curpat_ty; liftn (len + liftsign) (succ lens) ppat_c ; lift len' curpat_c |]) :: @@ -1929,7 +1927,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra let typing_fun tycon env = typing_fun tycon env isevars in - (* We build the matrix of patterns and right-hand-side *) + (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in (* We build the vector of terms to match consistently with the *) diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli index 823e9912..a4df1257 100644 --- a/plugins/subtac/subtac_cases.mli +++ b/plugins/subtac/subtac_cases.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: subtac_cases.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml index f0ff9ba3..b2bf9912 100644 --- a/plugins/subtac/subtac_classes.ml +++ b/plugins/subtac/subtac_classes.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: subtac_classes.ml 13328 2010-07-26 11:05:30Z herbelin $ i*) open Pretyping open Evd @@ -30,11 +30,11 @@ open Util module SPretyping = Subtac_pretyping.Pretyping -let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c = +let interp_constr_evars_gen evdref env ?(impls=[]) kind c = SPretyping.understand_tcc_evars evdref env kind (intern_gen (kind=IsType) ~impls ( !evdref) env c) -let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ = +let interp_casted_constr_evars evdref env ?(impls=[]) c typ = interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c let interp_context_evars evdref env params = diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli index 1c6c473a..57c7aa5b 100644 --- a/plugins/subtac/subtac_classes.mli +++ b/plugins/subtac/subtac_classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: subtac_classes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index 3f2a5dba..17c7284c 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: subtac_coercion.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Util open Names @@ -39,7 +39,7 @@ let rec disc_subset x = (match kind_of_term c with Ind i -> let len = Array.length l in - let sig_ = Lazy.force sig_ in + let sig_ = delayed_force sig_ in if len = 2 && i = Term.destInd sig_.typ then let (a, b) = pair_of_array l in @@ -53,7 +53,7 @@ and disc_exist env x = | App (c, l) -> (match kind_of_term c with Construct c -> - if c = Term.destConstruct (Lazy.force sig_).intro + if c = Term.destConstruct (delayed_force sig_).intro then Some (l.(0), l.(1), l.(2), l.(3)) else None | _ -> None) @@ -66,7 +66,7 @@ module Coercion = struct let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> - (if Term.eq_constr c (Lazy.force sig_).proj1 + (if Term.eq_constr c (delayed_force sig_).proj1 && Array.length l = 3 then disc_exist env l.(2) else None) @@ -100,7 +100,7 @@ module Coercion = struct Some (u, p) -> let f, ct = aux u in (Some (fun x -> - app_opt f (mkApp ((Lazy.force sig_).proj1, + app_opt f (mkApp ((delayed_force sig_).proj1, [| u; p; x |]))), ct) | None -> (None, v) @@ -146,9 +146,9 @@ module Coercion = struct in let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in - let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in + let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in let evar = make_existential loc env isevars eq in - let eq_app x = mkApp (Lazy.force eq_rect, + let eq_app x = mkApp (delayed_force eq_rect, [| eqT; hdx; pred; x; hdy; evar|]) in aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some co @@ -187,8 +187,8 @@ module Coercion = struct (match kind_of_term c, kind_of_term c' with Ind i, Ind i' -> (* Inductive types *) let len = Array.length l in - let existS = Lazy.force existS in - let prod = Lazy.force prod in + let existS = delayed_force existS in + let prod = delayed_force prod in (* Sigma types *) if len = Array.length l' && len = 2 && i = i' && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) @@ -279,7 +279,7 @@ module Coercion = struct Some (u, p) -> let c = coerce_unify env u y in let f x = - app_opt c (mkApp ((Lazy.force sig_).proj1, + app_opt c (mkApp ((delayed_force sig_).proj1, [| u; p; x |])) in Some f | None -> @@ -292,7 +292,7 @@ module Coercion = struct let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in (mkApp - ((Lazy.force sig_).intro, + ((delayed_force sig_).intro, [| u; p; cx; evar |]))) | None -> raise NoSubtacCoercion @@ -496,8 +496,7 @@ module Coercion = struct with NoCoercion -> coerce_itf loc env' isevars None t t') with NoSubtacCoercion -> - let sigma = isevars in - error_cannot_coerce env' sigma (t, t')) + error_cannot_coerce env' isevars (t, t')) else isevars with _ -> isevars end diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index f2747225..e7dd7ef1 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -53,7 +53,7 @@ let evar_nf isevars c = Evarutil.nf_evar !isevars c let interp_gen kind isevars env - ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) + ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in let c' = SPretyping.understand_tcc_evars isevars env kind c' in @@ -62,13 +62,13 @@ let interp_gen kind isevars env let interp_constr isevars env c = interp_gen (OfType None) isevars env c -let interp_type_evars isevars env ?(impls=([],[])) c = +let interp_type_evars isevars env ?(impls=[]) c = interp_gen IsType isevars env ~impls c -let interp_casted_constr isevars env ?(impls=([],[])) c typ = +let interp_casted_constr isevars env ?(impls=[]) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c -let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ = +let interp_casted_constr_evars isevars env ?(impls=[]) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c let interp_open_constr isevars env c = @@ -237,14 +237,18 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let rel = interp_constr isevars env r in let relty = type_of env !isevars rel in let relargty = - let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in - match ctx, kind_of_term ar with - | [(_, None, t); (_, None, u)], Sort (Prop Null) - when Reductionops.is_conv env !isevars t u -> t - | _, _ -> - user_err_loc (constr_loc r, - "Subtac_command.build_wellfounded", - my_print_constr env rel ++ str " is not an homogeneous binary relation.") + let error () = + user_err_loc (constr_loc r, + "Subtac_command.build_wellfounded", + my_print_constr env rel ++ str " is not an homogeneous binary relation.") + in + try + let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in + match ctx, kind_of_term ar with + | [(_, None, t); (_, None, u)], Sort (Prop Null) + when Reductionops.is_conv env !isevars t u -> t + | _, _ -> error () + with _ -> error () in let measure = interp_casted_constr isevars binders_env measure relargty in let wf_rel, wf_rel_fun, measure_fn = @@ -252,14 +256,14 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = it_mkLambda_or_LetIn measure letbinders, it_mkLambda_or_LetIn measure binders in - let comb = constr_of_global (Lazy.force measure_on_R_ref) in + let comb = constr_of_global (delayed_force measure_on_R_ref) in let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; subst1 y measure_body |]) in wf_rel, wf_rel_fun, measure in - let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in + let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in let argid' = id_of_string (string_of_id argname ^ "'") in let wfarg len = (Name argid', None, mkSubset (Name argid') argtyp @@ -267,7 +271,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in - let proj = (Lazy.force sig_).Coqlib.proj1 in + let proj = (delayed_force sig_).Coqlib.proj1 in let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) @@ -280,7 +284,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let arg = mkApp ((delayed_force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in let lam = (Name (id_of_string "recproof"), None, rcurry) in @@ -292,21 +296,20 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let lift_lets = Termops.lift_rel_context 1 letbinders in let intern_body = let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in - let (r, l, impls, scopes) = + let (r, l, impls, scopes) = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls in let newimpls = [(recname, (r, l, impls @ [Some (id_of_string "recproof", Impargs.Manual, (true, false))], scopes @ [None]))] in - let newimpls = Constrintern.set_internalization_env_params newimpls [] in interp_casted_constr isevars ~impls:newimpls (push_rel_context ctx env) body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let def = - mkApp (constr_of_global (Lazy.force fix_sub_ref), + mkApp (constr_of_global (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; prop ; intern_body_lam |]) @@ -429,7 +432,7 @@ let interp_recursive fixkind l boxed = List.fold_left2 (fun env' id t -> let sort = Retyping.get_type_of env !evdref t in let fixprot = - try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) + try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|]) with e -> t in (id,None,fixprot) :: env') @@ -438,8 +441,8 @@ let interp_recursive fixkind l boxed = let env_rec = push_named_context rec_sign env in (* Get interpretation metadatas *) - let impls = Constrintern.compute_full_internalization_env env - Constrintern.Recursive [] fixnames fixtypes fiximps + let impls = Constrintern.compute_internalization_env env + Constrintern.Recursive fixnames fixtypes fiximps in let notations = List.flatten ntnl in @@ -453,7 +456,7 @@ let interp_recursive fixkind l boxed = let fixdefs = List.map out_def fixdefs in (* Instantiate evars and check all are resolved *) - let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in + let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:false env_rec evd in @@ -518,8 +521,8 @@ let build_recursive l b = m ntn false) | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> - let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; + let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive (IsFixpoint g) fixl b | _, _ -> @@ -528,7 +531,7 @@ let build_recursive l b = let build_corecursive l b = let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; + ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive IsCoFixpoint fixl b diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli index 304aa139..0f24915e 100644 --- a/plugins/subtac/subtac_command.mli +++ b/plugins/subtac/subtac_command.mli @@ -13,7 +13,7 @@ val interp_gen : typing_constraint -> evar_map ref -> env -> - ?impls:full_internalization_env -> + ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign -> constr_expr -> constr @@ -23,12 +23,12 @@ val interp_constr : val interp_type_evars : evar_map ref -> env -> - ?impls:full_internalization_env -> + ?impls:internalization_env -> constr_expr -> constr val interp_casted_constr_evars : evar_map ref -> env -> - ?impls:full_internalization_env -> + ?impls:internalization_env -> constr_expr -> types -> constr val interp_open_constr : evar_map ref -> env -> constr_expr -> constr diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 2836bc73..1424618f 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -21,8 +21,8 @@ let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) let pperror cmd = Util.errorlabstrm "Program" cmd let error s = pperror (str s) -let reduce = - Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty +let reduce c = + Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c exception NoObligations of identifier option @@ -61,16 +61,15 @@ type program_info = { prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list; prg_notations : notations ; prg_kind : definition_kind; + prg_reduce : constr -> constr; prg_hook : Tacexpr.declaration_hook; } let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") -let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC -let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Tacexpr.TacId []) - -let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t +let (set_default_tactic, get_default_tactic, print_default_tactic) = + Tactic_option.declare_tactic_option "Program tactic" (* true = All transparent, false = Opaque if possible *) let proofs_transparency = ref true @@ -136,10 +135,9 @@ let map_first m = let from_prg : program_info ProgMap.t ref = ref ProgMap.empty -let freeze () = !from_prg, !default_tactic_expr -let unfreeze (v, t) = from_prg := v; set_default_tactic t -let init () = - from_prg := ProgMap.empty; set_default_tactic (Tacexpr.TacId []) +let freeze () = !from_prg +let unfreeze v = from_prg := v +let init () = from_prg := ProgMap.empty (** Beware: if this code is dynamically loaded via dynlink after the start of Coq, then this [init] function will not be run by [Lib.init ()]. @@ -155,35 +153,16 @@ let _ = let progmap_union = ProgMap.fold ProgMap.add -let cache (_, (local, tac)) = - set_default_tactic tac - -let load (_, (local, tac)) = - if not local then set_default_tactic tac - -let subst (s, (local, tac)) = - (local, Tacinterp.subst_tactic s tac) - let (input,output) = declare_object { (default_object "Program state") with - cache_function = cache; - load_function = (fun _ -> load); - open_function = (fun _ -> load); - classify_function = (fun (local, tac) -> + classify_function = (fun () -> if not (ProgMap.is_empty !from_prg) then errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++ prlist_with_sep spc (fun x -> Nameops.pr_id x) (map_keys !from_prg)); - if local then Dispose else Substitute (local, tac)); - subst_function = subst} + Dispose) } -let update_state local = - Lib.add_anonymous_leaf (input (local, !default_tactic_expr)) - -let set_default_tactic local t = - set_default_tactic t; update_state local - open Evd let progmap_remove prg = @@ -270,7 +249,7 @@ let declare_mutual_definition l = let subs, typ = (subst_body true x) in let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in - reduce term, reduce typ, x.prg_implicits) l) + x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) in (* let fixdefs = List.map reduce_fix fixdefs in *) let fixkind = Option.get first.prg_fixkind in @@ -300,8 +279,8 @@ let declare_mutual_definition l = List.iter progmap_remove l; kn let declare_obligation prg obl body = - let body = reduce body in - let ty = reduce obl.obl_type in + let body = prg.prg_reduce body in + let ty = prg.prg_reduce obl.obl_type in match obl.obl_status with | Expand -> { obl with obl_body = Some body } | Define opaque -> @@ -321,9 +300,7 @@ let declare_obligation prg obl body = print_message (Subtac_utils.definition_message obl.obl_name); { obl with obl_body = Some (mkConst constant) } -let red = Reductionops.nf_betaiota Evd.empty - -let init_prog_info n b t deps fixkind notations obls impls kind hook = +let init_prog_info n b t deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -337,13 +314,13 @@ let init_prog_info n b t deps fixkind notations obls impls kind hook = Array.mapi (fun i (n, t, l, o, d, tac) -> { obl_name = n ; obl_body = None; - obl_location = l; obl_type = red t; obl_status = o; + obl_location = l; obl_type = reduce t; obl_status = o; obl_deps = d; obl_tac = tac }) obls, b in - { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); + { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; - prg_implicits = impls; prg_kind = kind; prg_hook = hook; } + prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; } let get_prog name = let prg_infos = !from_prg in @@ -469,7 +446,7 @@ let rec solve_obligation prg num tac = | _ -> ()); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by !default_tactic; + Pfedit.by (snd (get_default_tactic ())); Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac; Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " @@ -501,7 +478,7 @@ and solve_obligation_by_tac prg obls i tac = | None -> match obl.obl_tac with | Some t -> t - | None -> !default_tactic + | None -> snd (get_default_tactic ()) in let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in obls.(i) <- declare_obligation prg obl t; @@ -579,9 +556,10 @@ let show_term n = my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ my_print_constr (Global.env ()) prg.prg_body) -let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls = +let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic + ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); - let prg = init_prog_info n term t [] None [] obls implicits kind hook in + let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Array.length obls = 0 then ( Flags.if_verbose ppnl (str "."); @@ -596,12 +574,14 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?ta | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind = +let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) + ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in let upd = List.fold_left (fun acc (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t deps (Some fixkind) notations obls imps kind hook in - ProgMap.add n prg acc) + let prg = init_prog_info n (Some b) t deps (Some fixkind) + notations obls imps kind reduce hook + in ProgMap.add n prg acc) !from_prg l in from_prg := upd; @@ -647,6 +627,3 @@ let next_obligation n tac = try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i tac - -let default_tactic () = !default_tactic -let default_tactic_expr () = !default_tactic_expr diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli index 1608c134..bc5fc3e1 100644 --- a/plugins/subtac/subtac_obligations.mli +++ b/plugins/subtac/subtac_obligations.mli @@ -3,6 +3,7 @@ open Util open Libnames open Evd open Proof_type +open Vernacexpr type obligation_info = (identifier * Term.types * loc * @@ -16,8 +17,8 @@ type progress = (* Resolution status of a program *) | Defined of global_reference (* Defined as id *) val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit -val default_tactic : unit -> Proof_type.tactic -val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr +val get_default_tactic : unit -> locality_flag * Proof_type.tactic +val print_default_tactic : unit -> Pp.std_ppcmds val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool @@ -26,6 +27,7 @@ val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:Proof_type.tactic -> + ?reduce:(Term.constr -> Term.constr) -> ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list @@ -39,6 +41,7 @@ val add_mutual_definitions : (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> + ?reduce:(Term.constr -> Term.constr) -> ?hook:Tacexpr.declaration_hook -> notations -> fixpoint_kind -> unit diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml index 030bb3c5..23323ab3 100644 --- a/plugins/subtac/subtac_pretyping.ml +++ b/plugins/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: subtac_pretyping.ml 13344 2010-07-28 15:04:36Z msozeau $ *) open Global open Pp @@ -70,7 +70,7 @@ let merge_evms x y = let interp env isevars c tycon = let j = pretype tycon env isevars ([],[]) c in let _ = isevars := Evarutil.nf_evar_map !isevars in - let evd,_ = consider_remaining_unif_problems env !isevars in + let evd = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in @@ -86,8 +86,10 @@ let find_with_index x l = open Vernacexpr -let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr ( evd) env -let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( evd) env +let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = + Constrintern.intern_constr evd env +let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = + Constrintern.intern_type evd env let env_with_binders env isevars l = let rec aux ((env, rels) as acc) = function @@ -109,21 +111,25 @@ let env_with_binders env isevars l = | [] -> acc in aux (env, []) l -let subtac_process env isevars id bl c tycon = +let subtac_process ?(is_type=false) env isevars id bl c tycon = let c = Topconstr.abstract_constr_expr c bl in - let tycon = + let tycon, imps = match tycon with - None -> empty_tycon + None -> empty_tycon, None | Some t -> let t = Topconstr.prod_constr_expr t bl in let t = coqintern_type !isevars env t in + let imps = Implicit_quantifiers.implicits_of_rawterm t in let coqt, ttyp = interp env isevars t empty_tycon in - mk_tycon coqt + mk_tycon coqt, Some imps in let c = coqintern_constr !isevars env c in - let imps = Implicit_quantifiers.implicits_of_rawterm c in + let imps = match imps with + | Some i -> i + | None -> Implicit_quantifiers.implicits_of_rawterm ~with_products:is_type c + in let coqc, ctyp = interp env isevars c tycon in - let evm = non_instanciated_map env isevars ( !isevars) in + let evm = non_instanciated_map env isevars !isevars in let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in evm, coqc, ty, imps diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli index 055c6df2..48906b23 100644 --- a/plugins/subtac/subtac_pretyping.mli +++ b/plugins/subtac/subtac_pretyping.mli @@ -16,7 +16,7 @@ val interp : Rawterm.rawconstr -> Evarutil.type_constraint -> Term.constr * Term.constr -val subtac_process : env -> evar_map ref -> identifier -> local_binder list -> +val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list -> constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list -> diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index 16f2031b..7fcd4267 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: subtac_pretyping_F.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -166,6 +166,28 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RProp c -> judge_of_prop_contents c | RType _ -> judge_of_new_Type () + let split_tycon_lam loc env evd tycon = + let rec real_split evd c = + let t = whd_betadeltaiota env evd c in + match kind_of_term t with + | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Evar ev when not (Evd.is_defined_evar evd ev) -> + let (evd',prod) = define_evar_as_product evd ev in + let (_,dom,rng) = destProd prod in + evd',(Anonymous, dom, rng) + | _ -> error_not_product_loc loc env evd c + in + match tycon with + | None -> evd,(Anonymous,None,None) + | Some (abs, c) -> + (match abs with + | None -> + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) + | Some (init, cur) -> + evd, (Anonymous, None, Some (Some (init, succ cur), c))) + + (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [( evdref)] and *) (* the type constraint tycon *) @@ -233,7 +255,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let newenv = let marked_ftys = Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in - mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |])) + mkApp (delayed_force Subtac_utils.fix_proto, [| sort; ty |])) ftys in push_rec_types (names,marked_ftys,[||]) env @@ -355,7 +377,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct evd, Some ty') evdref tycon in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let (name',dom,rng) = evd_comb1 (split_tycon_lam loc env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in @@ -586,11 +608,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (pretype tycon env evdref lvar c).uj_val | IsType -> (pretype_type empty_valcon env evdref lvar c).utj_val in - evdref := fst (consider_remaining_unif_problems env !evdref); + evdref := consider_remaining_unif_problems env !evdref; if resolve_classes then - evdref := - Typeclasses.resolve_typeclasses ~onlyargs:false + (evdref := Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:fail_evar env !evdref; + 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; c @@ -603,7 +625,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let understand_judgment sigma env c = let evdref = ref (create_evar_defs sigma) in let j = pretype empty_tycon env evdref ([],[]) c in - let evd,_ = consider_remaining_unif_problems env !evdref in + let evd = consider_remaining_unif_problems env !evdref in let j = j_nf_evar evd j in check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); j diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 06a80f68..689b110f 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -1,3 +1,5 @@ +(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) + open Evd open Libnames open Coqlib @@ -18,14 +20,14 @@ let utils_module = "Utils" let fixsub_module = subtac_dir @ [fix_sub_module] let utils_module = subtac_dir @ [utils_module] let tactics_module = subtac_dir @ ["Tactics"] -let init_constant dir s = gen_constant contrib_name dir s -let init_reference dir s = gen_reference contrib_name dir s +let init_constant dir s () = gen_constant contrib_name dir s +let init_reference dir s () = gen_reference contrib_name dir s -let fixsub = lazy (init_constant fixsub_module "Fix_sub") -let ex_pi1 = lazy (init_constant utils_module "ex_pi1") -let ex_pi2 = lazy (init_constant utils_module "ex_pi2") +let fixsub = init_constant fixsub_module "Fix_sub" +let ex_pi1 = init_constant utils_module "ex_pi1" +let ex_pi2 = init_constant utils_module "ex_pi2" -let make_ref l s = lazy (init_reference l s) +let make_ref l s = init_reference l s let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" let acc_ref = make_ref ["Init";"Wf"] "Acc" let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" @@ -41,68 +43,67 @@ let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" let build_sig () = - { proj1 = init_constant ["Init"; "Specif"] "proj1_sig"; - proj2 = init_constant ["Init"; "Specif"] "proj2_sig"; - elim = init_constant ["Init"; "Specif"] "sig_rec"; - intro = init_constant ["Init"; "Specif"] "exist"; - typ = init_constant ["Init"; "Specif"] "sig" } + { proj1 = init_constant ["Init"; "Specif"] "proj1_sig" (); + proj2 = init_constant ["Init"; "Specif"] "proj2_sig" (); + elim = init_constant ["Init"; "Specif"] "sig_rec" (); + intro = init_constant ["Init"; "Specif"] "exist" (); + typ = init_constant ["Init"; "Specif"] "sig" () } -let sig_ = lazy (build_sig ()) +let sig_ = build_sig -let fix_proto = lazy (init_constant tactics_module "fix_proto") +let fix_proto = init_constant tactics_module "fix_proto" let fix_proto_ref () = match Nametab.global (make_ref "Program.Tactics.fix_proto") with | ConstRef c -> c | _ -> assert false -let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq") -let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec") -let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect") -let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal") -let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq") -let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") +let eq_ind = init_constant ["Init"; "Logic"] "eq" +let eq_rec = init_constant ["Init"; "Logic"] "eq_rec" +let eq_rect = init_constant ["Init"; "Logic"] "eq_rect" +let eq_refl = init_constant ["Init"; "Logic"] "refl_equal" +let eq_ind_ref = init_reference ["Init"; "Logic"] "eq" +let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal" -let not_ref = lazy (init_constant ["Init"; "Logic"] "not") +let not_ref = init_constant ["Init"; "Logic"] "not" -let and_typ = lazy (Coqlib.build_coq_and ()) +let and_typ = Coqlib.build_coq_and -let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep") -let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") -let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") -let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") +let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep" +let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec" +let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep" +let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro" let jmeq_ind = - lazy (check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq") + init_constant ["Logic";"JMeq"] "JMeq" + let jmeq_rec = - lazy (check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_rec") + init_constant ["Logic";"JMeq"] "JMeq_rec" + let jmeq_refl = - lazy (check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_refl") + init_constant ["Logic";"JMeq"] "JMeq_refl" -let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") -let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") +let ex_ind = init_constant ["Init"; "Logic"] "ex" +let ex_intro = init_reference ["Init"; "Logic"] "ex_intro" -let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1") -let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2") +let proj1 = init_constant ["Init"; "Logic"] "proj1" +let proj2 = init_constant ["Init"; "Logic"] "proj2" -let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool") -let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool") -let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") -let intind = lazy (init_constant ["ZArith"; "binint"] "Z") -let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") +let boolind = init_constant ["Init"; "Datatypes"] "bool" +let sumboolind = init_constant ["Init"; "Specif"] "sumbool" +let natind = init_constant ["Init"; "Datatypes"] "nat" +let intind = init_constant ["ZArith"; "binint"] "Z" +let existSind = init_constant ["Init"; "Specif"] "sigS" -let existS = lazy (build_sigma_type ()) +let existS = build_sigma_type -let prod = lazy (build_prod ()) +let prod = build_prod (* orders *) -let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded") -let fix = lazy (init_constant ["Init"; "Wf"] "Fix") -let acc = lazy (init_constant ["Init"; "Wf"] "Acc") -let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv") +let well_founded = init_constant ["Init"; "Wf"] "well_founded" +let fix = init_constant ["Init"; "Wf"] "Fix" +let acc = init_constant ["Init"; "Wf"] "Acc" +let acc_inv = init_constant ["Init"; "Wf"] "Acc_inv" let extconstr = Constrextern.extern_constr true (Global.env ()) let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s) @@ -151,8 +152,8 @@ let wf_relations = Hashtbl.create 10 let std_relations () = let add k v = Hashtbl.add wf_relations k v in - add (init_constant ["Init"; "Peano"] "lt") - (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf")) + add (init_constant ["Init"; "Peano"] "lt" ()) + (init_constant ["Arith"; "Wf_nat"] "lt_wf") let std_relations = Lazy.lazy_from_fun std_relations @@ -226,7 +227,6 @@ let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixp open Tactics open Tacticals -let id x = x let filter_map f l = let rec aux acc = function hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl @@ -257,51 +257,51 @@ let build_dependent_sum l = (fun typ -> let tex = mkLambda (Name n, t, typ) in conttype - (mkApp (Lazy.force ex_ind, [| t; tex |]))) + (mkApp (ex_ind (), [| t; tex |]))) in aux (mkVar n :: names) conttac conttype tl | (n, t) :: [] -> (conttac intros, conttype t) | [] -> raise (Invalid_argument "build_dependent_sum") - in aux [] id id (List.rev l) + in aux [] identity identity (List.rev l) open Proof_type open Tacexpr let mkProj1 a b c = - mkApp (Lazy.force proj1, [| a; b; c |]) + mkApp (delayed_force proj1, [| a; b; c |]) let mkProj2 a b c = - mkApp (Lazy.force proj2, [| a; b; c |]) + mkApp (delayed_force proj2, [| a; b; c |]) let mk_ex_pi1 a b c = - mkApp (Lazy.force ex_pi1, [| a; b; c |]) + mkApp (delayed_force ex_pi1, [| a; b; c |]) let mk_ex_pi2 a b c = - mkApp (Lazy.force ex_pi2, [| a; b; c |]) + mkApp (delayed_force ex_pi2, [| a; b; c |]) let mkSubset name typ prop = - mkApp ((Lazy.force sig_).typ, + mkApp ((delayed_force sig_).typ, [| typ; mkLambda (name, typ, prop) |]) -let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |]) -let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |]) +let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |]) +let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (delayed_force jmeq_refl, [| typ; x |]) let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd | [] -> raise (Invalid_argument "unsafe_fold_right") let mk_conj l = - let conj_typ = Lazy.force and_typ in + let conj_typ = delayed_force and_typ in unsafe_fold_right (fun c conj -> mkApp (conj_typ, [| c ; conj |])) l let mk_not c = - let notc = Lazy.force not_ref in + let notc = delayed_force not_ref in mkApp (notc, [| c |]) let and_tac l hook = @@ -336,7 +336,7 @@ let destruct_ex ext ex = match kind_of_term c with App (f, args) -> (match kind_of_term f with - Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 -> + 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) @@ -477,6 +477,7 @@ let pr_evar_map evd = let contrib_tactics_path = make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"]) + let tactics_tac s = lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)) diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli index d0ad334d..f56c2932 100644 --- a/plugins/subtac/subtac_utils.mli +++ b/plugins/subtac/subtac_utils.mli @@ -17,53 +17,53 @@ val contrib_name : string val subtac_dir : string list val fix_sub_module : string val fixsub_module : string list -val init_constant : string list -> string -> constr -val init_reference : string list -> string -> global_reference -val fixsub : constr lazy_t -val well_founded_ref : global_reference lazy_t -val acc_ref : global_reference lazy_t -val acc_inv_ref : global_reference lazy_t -val fix_sub_ref : global_reference lazy_t -val measure_on_R_ref : global_reference lazy_t -val fix_measure_sub_ref : global_reference lazy_t -val refl_ref : global_reference lazy_t +val init_constant : string list -> string -> constr delayed +val init_reference : string list -> string -> global_reference delayed +val fixsub : constr delayed +val well_founded_ref : global_reference delayed +val acc_ref : global_reference delayed +val acc_inv_ref : global_reference delayed +val fix_sub_ref : global_reference delayed +val measure_on_R_ref : global_reference delayed +val fix_measure_sub_ref : global_reference delayed +val refl_ref : global_reference delayed val lt_ref : reference val sig_ref : reference val proj1_sig_ref : reference val proj2_sig_ref : reference val build_sig : unit -> coq_sigma_data -val sig_ : coq_sigma_data lazy_t +val sig_ : coq_sigma_data delayed -val fix_proto : constr lazy_t +val fix_proto : constr delayed val fix_proto_ref : unit -> constant -val eq_ind : constr lazy_t -val eq_rec : constr lazy_t -val eq_rect : constr lazy_t -val eq_refl : constr lazy_t - -val not_ref : constr lazy_t -val and_typ : constr lazy_t - -val eqdep_ind : constr lazy_t -val eqdep_rec : constr lazy_t - -val jmeq_ind : constr lazy_t -val jmeq_rec : constr lazy_t -val jmeq_refl : constr lazy_t - -val boolind : constr lazy_t -val sumboolind : constr lazy_t -val natind : constr lazy_t -val intind : constr lazy_t -val existSind : constr lazy_t -val existS : coq_sigma_data lazy_t -val prod : coq_sigma_data lazy_t - -val well_founded : constr lazy_t -val fix : constr lazy_t -val acc : constr lazy_t -val acc_inv : constr lazy_t +val eq_ind : constr delayed +val eq_rec : constr delayed +val eq_rect : constr delayed +val eq_refl : constr delayed + +val not_ref : constr delayed +val and_typ : constr delayed + +val eqdep_ind : constr delayed +val eqdep_rec : constr delayed + +val jmeq_ind : constr delayed +val jmeq_rec : constr delayed +val jmeq_refl : constr delayed + +val boolind : constr delayed +val sumboolind : constr delayed +val natind : constr delayed +val intind : constr delayed +val existSind : constr delayed +val existS : coq_sigma_data delayed +val prod : coq_sigma_data delayed + +val well_founded : constr delayed +val fix : constr delayed +val acc : constr delayed +val acc_inv : constr delayed val extconstr : constr -> constr_expr val extsort : sorts -> constr_expr @@ -81,7 +81,7 @@ val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds val debug : int -> std_ppcmds -> unit val debug_msg : int -> std_ppcmds -> std_ppcmds val trace : std_ppcmds -> unit -val wf_relations : (constr, constr lazy_t) Hashtbl.t +val wf_relations : (constr, constr delayed) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 19473dfa..ae3afff4 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id$ i*) +(*i $Id: ascii_syntax.ml 12406 2009-10-21 15:12:52Z soubiran $ i*) open Pp open Util diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 89419d5e..1e9a055f 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: nat_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* This file defines the printer for natural numbers in [nat] *) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 162588ac..787577b2 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: numbers_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (* digit-based syntax for int31, bigN bigZ and bigQ *) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index f8e8e210..af1477f1 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: r_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Util diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index bc02357a..534605c8 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id$ i*) +(*i $Id: string_syntax.ml 12337 2009-09-17 15:58:14Z glondu $ i*) open Pp open Util diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 931bd77d..87f14a64 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: z_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pcoq open Pp diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli index cfa050d7..2a9d1de4 100644 --- a/plugins/xml/xml.mli +++ b/plugins/xml/xml.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: xml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Tokens for XML cdata, empty elements and not-empty elements *) (* Usage: *) diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli index fc9fbf32..476ad630 100644 --- a/plugins/xml/xmlcommand.mli +++ b/plugins/xml/xmlcommand.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: xmlcommand.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* print_global qid fn *) (* where qid is a long name denoting a definition/theorem or *) diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4 index a6d815da..bf6c7388 100644 --- a/plugins/xml/xmlentries.ml4 +++ b/plugins/xml/xmlentries.ml4 @@ -14,7 +14,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: xmlentries.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util;; open Vernacinterp;; diff --git a/pretyping/cases.ml b/pretyping/cases.ml index eb02f7ae..9027315e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: cases.ml 13329 2010-07-26 11:05:39Z herbelin $ *) open Util open Names @@ -1054,7 +1054,7 @@ let rec generalize_problem names pb = function tomatch = Abstract d :: tomatch; pred = generalize_predicate names i d pb.tomatch pb'.pred } -(* No more patterns: typing the right-hand-side of equations *) +(* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in @@ -1690,7 +1690,7 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred = let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = - (* We build the matrix of patterns and right-hand-side *) + (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env tomatchl eqns in (* We build the vector of terms to match consistently with the *) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 8b8ab3db..7bc635fb 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cases.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index b5550c19..ec71159b 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: cbv.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index c0081174..5486b064 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cbv.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 4079728c..17f18a9b 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: classops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 54e57131..f905e392 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: classops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml index 412763d7..a41cdd6f 100644 --- a/pretyping/clenv.ml +++ b/pretyping/clenv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: clenv.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -128,7 +128,7 @@ let clenv_conv_leq env sigma t c bound = let evd = Evd.create_goal_evar_defs sigma in let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in - let evars,_ = Evarconv.consider_remaining_unif_problems env evars in + let evars = Evarconv.consider_remaining_unif_problems env evars in let args = List.map (whd_evar evars) args in check_evars env sigma evars (applist (c,args)); args @@ -454,18 +454,23 @@ let clenv_constrain_dep_args hyps_only bl clenv = (****************************************************************) (* Clausal environment for an application *) -let make_clenv_binding_gen hyps_only n gls (c,t) = function + +let make_clenv_binding_gen hyps_only n env sigma (c,t) = function | ImplicitBindings largs -> - let clause = mk_clenv_from_n gls n (c,t) in + let clause = mk_clenv_from_env env sigma n (c,t) in clenv_constrain_dep_args hyps_only largs clause | ExplicitBindings lbind -> - let clause = mk_clenv_rename_from_n gls n (c,t) in - clenv_match_args lbind clause + let clause = mk_clenv_from_env env sigma n + (c,rename_bound_vars_as_displayed [] t) + in clenv_match_args lbind clause | NoBindings -> - mk_clenv_from_n gls n (c,t) + mk_clenv_from_env env sigma n (c,t) -let make_clenv_binding_apply gls n = make_clenv_binding_gen true n gls -let make_clenv_binding = make_clenv_binding_gen false None +let make_clenv_binding_env_apply env sigma n = + make_clenv_binding_gen true n env sigma + +let make_clenv_binding_apply gls n = make_clenv_binding_gen true n (pf_env gls) gls.sigma +let make_clenv_binding gls = make_clenv_binding_gen false None (pf_env gls) gls.sigma (****************************************************************) (* Pretty-print *) diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli index aec9e7c9..b50e313c 100644 --- a/pretyping/clenv.mli +++ b/pretyping/clenv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: clenv.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Util @@ -111,6 +111,9 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv val make_clenv_binding_apply : evar_info sigma -> int option -> constr * constr -> constr bindings -> clausenv +val make_clenv_binding_env_apply : + env -> evar_map -> int option -> constr * constr -> constr bindings -> + clausenv val make_clenv_binding : evar_info sigma -> constr * constr -> constr bindings -> clausenv diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 48a8d28e..dd099aa1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coercion.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 89be8069..00848dac 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coercion.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c0e5234b..e435484e 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: detyping.ml 13329 2010-07-26 11:05:39Z herbelin $ *) open Pp open Util @@ -364,6 +364,8 @@ let detype_sort = function | Prop c -> RProp c | Type u -> RType (Some u) +type binder_kind = BProd | BLambda | BLetIn + (**********************************************************************) (* Main detyping function *) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index ecf724ca..cdb840b6 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: detyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 20957e07..51183be3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: evarconv.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -551,10 +551,10 @@ let apply_conversion_problem_heuristic env evd pbty t1 t2 = let consider_remaining_unif_problems env evd = let (evd,pbs) = extract_all_conv_pbs evd in List.fold_left - (fun (evd,b as p) (pbty,env,t1,t2) -> - if b then apply_conversion_problem_heuristic env evd pbty t1 t2 else p) - (evd,true) - pbs + (fun evd (pbty,env,t1,t2) -> + let evd', b = apply_conversion_problem_heuristic env evd pbty t1 t2 in + if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2)) + evd pbs (* Main entry points *) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index add7ccd4..b0702038 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: evarconv.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Term @@ -34,7 +34,7 @@ val evar_eqappr_x : evar_map * bool (*i*) -val consider_remaining_unif_problems : env -> evar_map -> evar_map * bool +val consider_remaining_unif_problems : env -> evar_map -> evar_map val check_conv_record : constr * types list -> constr * types list -> constr * constr list * (constr list * constr list) * diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index ac653c75..09ec8dda 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: evarutil.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Util open Pp @@ -1434,6 +1434,10 @@ let judge_of_new_Type () = Typeops.judge_of_type (new_univ ()) constraint on its domain and codomain. If the input constraint is an evar instantiate it with the product of 2 new evars. *) +let unlift_tycon init cur c = + if cur = 1 then None, c + else Some (init, pred cur), c + let split_tycon loc env evd tycon = let rec real_split evd c = let t = whd_betadeltaiota env evd c in @@ -1453,14 +1457,7 @@ let split_tycon loc env evd tycon = let evd', (n, dom, rng) = real_split evd c in evd', (n, mk_tycon dom, mk_tycon rng) | Some (init, cur) -> - if cur = 0 then - let evd', (x, dom, rng) = real_split evd c in - evd, (Anonymous, - Some (None, dom), - Some (None, rng)) - else - evd, (Anonymous, None, - Some (if cur = 1 then None,c else Some (init, pred cur), c))) + evd, (Anonymous, None, Some (unlift_tycon init cur c))) let valcon_of_tycon x = match x with diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index d0b65d54..d677b972 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: evarutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 109fea4a..77442584 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: evd.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -498,7 +498,8 @@ let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } (* spiwack: tentatively deprecated *) let create_goal_evar_defs sigma = { sigma with - conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } + (* conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } *) + metas=Metamap.empty } let empty = { evars=EvarMap.empty; conv_pbs=[]; diff --git a/pretyping/evd.mli b/pretyping/evd.mli index ea484b5f..ce4e1b28 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: evd.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index f83aff69..927af594 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: indrec.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* File initially created by Christine Paulin, 1996 *) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index ea5d13dc..188ad74d 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: indrec.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 03589c4f..85c865fa 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: inductiveops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 7f29cba9..251c6b2e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: inductiveops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/pretyping/matching.ml b/pretyping/matching.ml index 843122e7..6ee67bf2 100644 --- a/pretyping/matching.ml +++ b/pretyping/matching.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: matching.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (*i*) open Util diff --git a/pretyping/matching.mli b/pretyping/matching.mli index 7677c076..25863129 100644 --- a/pretyping/matching.mli +++ b/pretyping/matching.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: matching.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index 3c95d1ea..6e3e2f7c 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: namegen.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Created from contents that was formerly in termops.ml and nameops.ml, Nov 2009 *) diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli index fa89426c..419624b8 100644 --- a/pretyping/namegen.mli +++ b/pretyping/namegen.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: namegen.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Term diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 4f62252f..d1c4cfc1 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pattern.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 92344e47..fbc6bbaa 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pattern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 9f441c21..6befdedc 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pretype_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Stdpp diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index ad122127..496e16d2 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pretype_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 5438d982..7b4b5e07 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pretyping.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -684,11 +684,14 @@ module Pretyping_F (Coercion : Coercion.S) = struct (pretype tycon env evdref lvar c).uj_val | IsType -> (pretype_type empty_valcon env evdref lvar c).utj_val in - evdref := fst (consider_remaining_unif_problems env !evdref); - if resolve_classes then - evdref := - Typeclasses.resolve_typeclasses ~onlyargs:false - ~split:true ~fail:fail_evar env !evdref; + if resolve_classes then ( + evdref := Typeclasses.resolve_typeclasses ~onlyargs:false + ~split:true ~fail:fail_evar env !evdref); + evdref := (try consider_remaining_unif_problems env !evdref + with e when not resolve_classes -> + consider_remaining_unif_problems env + (Typeclasses.resolve_typeclasses ~onlyargs:false + ~split:true ~fail:fail_evar 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; c @@ -701,7 +704,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct let understand_judgment sigma env c = let evdref = ref (create_evar_defs sigma) in let j = pretype empty_tycon env evdref ([],[]) c in - let evd,_ = consider_remaining_unif_problems env !evdref in + let evd = consider_remaining_unif_problems env !evdref in let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:false ~fail:true env evd in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ea6b43fb..7d08026f 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pretyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index 492d9a73..afb942fb 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: rawterm.ml 13329 2010-07-26 11:05:39Z herbelin $ *) (*i*) open Util @@ -34,8 +34,6 @@ type patvar = identifier type rawsort = RProp of Term.contents | RType of Univ.universe option -type binder_kind = BProd | BLambda | BLetIn - type binding_kind = Lib.binding_kind = Explicit | Implicit type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier @@ -185,6 +183,36 @@ let map_rawconstr_with_binders_loc loc g f e = function | RDynamic (_,x) -> RDynamic (loc,x) *) +let fold_rawconstr f acc = + let rec fold acc = function + | RVar _ -> acc + | RApp (_,c,args) -> List.fold_left fold (fold acc c) args + | RLambda (_,_,_,b,c) | RProd (_,_,_,b,c) | RLetIn (_,_,b,c) -> + fold (fold acc b) c + | RCases (_,_,rtntypopt,tml,pl) -> + List.fold_left fold_pattern + (List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml)) + pl + | RLetTuple (_,_,rtntyp,b,c) -> + fold (fold (fold_return_type acc rtntyp) b) c + | RIf (_,c,rtntyp,b1,b2) -> + fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2 + | RRec (_,_,_,bl,tyl,bv) -> + let acc = Array.fold_left + (List.fold_left (fun acc (na,k,bbd,bty) -> + fold (Option.fold_left fold acc bbd) bty)) acc bl in + Array.fold_left fold (Array.fold_left fold acc tyl) bv + | RCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> acc + + and fold_pattern acc (_,idl,p,c) = fold acc c + + and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt + + in fold acc + +let iter_rawconstr f = fold_rawconstr (fun () -> f) () + let occur_rawconstr id = let rec occur = function | RVar (loc,id') -> id = id' diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index c9dbe4bf..39ff74a3 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: rawterm.mli 13329 2010-07-26 11:05:39Z herbelin $ i*) (*i*) open Util @@ -38,8 +38,6 @@ type patvar = identifier type rawsort = RProp of Term.contents | RType of Univ.universe option -type binder_kind = BProd | BLambda | BLetIn - type binding_kind = Lib.binding_kind = Explicit | Implicit type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier @@ -110,6 +108,8 @@ val map_rawconstr_with_binders_loc : loc -> ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr i*) +val fold_rawconstr : ('a -> rawconstr -> 'a) -> 'a -> rawconstr -> 'a +val iter_rawconstr : (rawconstr -> unit) -> rawconstr -> unit val occur_rawconstr : identifier -> rawconstr -> bool val free_rawvars : rawconstr -> identifier list val loc_of_rawconstr : rawconstr -> loc diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 47178d06..68ae9208 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: recordops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index da883b19..3d97d8b2 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: recordops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7519e508..556134de 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: reductionops.ml 13354 2010-07-29 16:44:45Z barras $ *) open Pp open Util @@ -525,9 +525,11 @@ let nf_evar = (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add a [nf_evar] here *) let clos_norm_flags flgs env sigma t = - norm_val - (create_clos_infos ~evars:(safe_evar_value sigma) flgs env) - (inject t) + try + norm_val + (create_clos_infos ~evars:(safe_evar_value sigma) flgs env) + (inject t) + with Anomaly _ -> error "Tried to normalized ill-typed term" let nf_beta = clos_norm_flags Closure.beta empty_env let nf_betaiota = clos_norm_flags Closure.betaiota empty_env @@ -586,9 +588,11 @@ let nf_betaiota_preserving_vm_cast = (* lazy weak head reduction functions *) let whd_flags flgs env sigma t = - whd_val - (create_clos_infos ~evars:(safe_evar_value sigma) flgs env) - (inject t) + try + whd_val + (create_clos_infos ~evars:(safe_evar_value sigma) flgs env) + (inject t) + with Anomaly _ -> error "Tried to normalized ill-typed term" (********************************************************************) (* Conversion *) @@ -620,6 +624,7 @@ let test_conversion (f:?evars:'a->'b) env sigma x y = try let _ = f ~evars:(safe_evar_value sigma) env x y in true with NotConvertible -> false + | Anomaly _ -> error "Conversion test raised an anomaly" let is_conv env sigma = test_conversion Reduction.conv env sigma let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma @@ -628,6 +633,7 @@ let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq let test_trans_conversion f reds env sigma x y = try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true with NotConvertible -> false + | Anomaly _ -> error "Conversion test raised an anomaly" let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index ab4c6f5d..f557df00 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: reductionops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index d736031f..e4a85b84 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: retyping.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Term diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 7b53da7e..98a3ff42 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: retyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 3089b7ca..49ccb80c 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tacred.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index d5703d6b..064d2ce4 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tacred.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/termops.ml b/pretyping/termops.ml index f746245f..a2759688 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: termops.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/pretyping/termops.mli b/pretyping/termops.mli index f13df9d2..7977fe28 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: termops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Pp diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index da17c299..d75032e7 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typeclasses.ml 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Names @@ -106,6 +106,29 @@ let _ = Summary.unfreeze_function = unfreeze; Summary.init_function = init } +let class_info c = + try Gmap.find c !classes + with _ -> not_a_class (Global.env()) (constr_of_global c) + +let global_class_of_constr env c = + try class_info (global_of_constr c) + with Not_found -> not_a_class env c + +let dest_class_app env c = + let cl, args = decompose_app c in + global_class_of_constr env cl, args + +let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None + +let rec is_class_type evd c = + match kind_of_term c with + | Prod (_, _, t) -> is_class_type evd t + | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) + | _ -> class_of_constr c <> None + +let is_class_evar evd evi = + is_class_type evd evi.Evd.evar_concl + (* * classes persistent object *) @@ -153,8 +176,15 @@ let discharge_class (_,cl) = | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in let discharge_context ctx' subst (grs, ctx) = - let grs' = List.map (fun _ -> None) subst @ - list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + let grs' = + let newgrs = List.map (fun (_, _, t) -> + match class_of_constr t with + | None -> None + | Some tc -> Some (tc.cl_impl, true)) + ctx' + in + list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else @@ -265,10 +295,6 @@ let add_inductive_class ind = * interface functions *) -let class_info c = - try Gmap.find c !classes - with _ -> not_a_class (Global.env()) (constr_of_global c) - let instance_constructor cl args = let lenpars = List.length (List.filter (fun (na, b, t) -> b = None) (snd cl.cl_context)) in let pars = fst (list_chop lenpars args) in @@ -322,16 +348,6 @@ let is_implicit_arg k = | InternalHole -> true | _ -> false -let global_class_of_constr env c = - try class_info (global_of_constr c) - with Not_found -> not_a_class env c - -let dest_class_app env c = - let cl, args = decompose_app c in - global_class_of_constr env cl, args - -let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None - (* To embed a boolean for resolvability status. This is essentially a hack to mark which evars correspond to goals and do not need to be resolved when we have nested [resolve_all_evars] @@ -356,15 +372,6 @@ let mark_unresolvables sigma = Evd.add evs ev (mark_unresolvable evi)) sigma Evd.empty -let rec is_class_type evd c = - match kind_of_term c with - | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) - | _ -> class_of_constr c <> None - -let is_class_evar evd evi = - is_class_type evd evi.Evd.evar_concl - let has_typeclasses evd = Evd.fold (fun ev evi has -> has || (evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi)) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 80387ec5..8e1c2a92 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typeclasses.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index eb24c731..b3ab1f07 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typeclasses_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 4ec5ad70..94e1a57d 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typeclasses_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 43880615..82b59d16 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 49a6a23e..32b64c5f 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a096a074..02af6090 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: unification.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -573,12 +573,9 @@ let is_mimick_head f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to dummy_loc env evd j tycon in - let (evd',b) = Evarconv.consider_remaining_unif_problems env evd' in - if b then - let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in + let evd' = Evarconv.consider_remaining_unif_problems env evd' in + let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in (evd',j'.uj_val) - else - error "Cannot solve unification constraints" let w_coerce_to_type env evd c cty mvty = let evd,mvty = pose_all_metas_as_evars env evd mvty in @@ -634,9 +631,7 @@ let order_metas metas = let solve_simple_evar_eqn env evd ev rhs = let evd,b = solve_simple_eqn Evarconv.evar_conv_x env evd (None,ev,rhs) in if not b then error_cannot_unify env evd (mkEvar ev,rhs); - let (evd,b) = Evarconv.consider_remaining_unif_problems env evd in - if not b then error "Cannot solve unification constraints"; - evd + Evarconv.consider_remaining_unif_problems env evd (* [w_merge env sigma b metas evars] merges common instances in metas or in evars, possibly generating new unification problems; if [b] @@ -656,11 +651,16 @@ let w_merge env with_types flags (evd,metas,evars) = else begin let rhs' = subst_meta_instances metas rhs in match kind_of_term rhs with - | App (f,cl) when is_mimick_head f & occur_meta rhs' -> + | App (f,cl) when occur_meta rhs' -> if occur_evar evn rhs' then error_occur_check env evd evn rhs'; - let evd' = mimick_evar evd flags f (Array.length cl) evn in - w_merge_rec evd' metas evars eqns + if is_mimick_head f then + let evd' = mimick_evar evd flags f (Array.length cl) evn in + w_merge_rec evd' metas evars eqns + else + let evd', rhs'' = pose_all_metas_as_evars env evd rhs' in + w_merge_rec (solve_simple_evar_eqn env evd' ev rhs'') + metas evars' eqns | _ -> w_merge_rec (solve_simple_evar_eqn env evd ev rhs') metas evars' eqns diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 7a91ce66..419d5d4f 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: unification.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 2de542cd..2c8705d5 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vnorm.ml 13351 2010-07-29 15:26:31Z barras $ i*) open Names open Declarations @@ -117,7 +117,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in let codom = - let papp = mkApp(p,crealargs) in + let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index de2ba7c9..5f0f5e7d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: clenvtac.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index 72b812ce..3840cc0a 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: clenvtac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli index 91f0a9ff..24cf2c1d 100644 --- a/proofs/decl_expr.mli +++ b/proofs/decl_expr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_expr.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Util diff --git a/proofs/decl_mode.ml b/proofs/decl_mode.ml index d28d9a0d..8810820d 100644 --- a/proofs/decl_mode.ml +++ b/proofs/decl_mode.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: decl_mode.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli index b6e77b43..b309c9f0 100644 --- a/proofs/decl_mode.mli +++ b/proofs/decl_mode.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_mode.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Term diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index a5a0cde4..484d5332 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: evar_refiner.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index e4303f42..3f7f88d1 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: evar_refiner.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/proofs/logic.ml b/proofs/logic.ml index 83dc497c..fda14f53 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: logic.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -58,7 +58,7 @@ let rec catchable_exception = function (* unification errors *) | PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _ |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ - |CannotFindWellTypedAbstraction _ + |CannotFindWellTypedAbstraction _|OccurCheck _ |UnsolvableImplicit _)) -> true | Typeclasses_errors.TypeClassError (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true diff --git a/proofs/logic.mli b/proofs/logic.mli index c7cf6472..960505ed 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: logic.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3adfd522..171db848 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: pfedit.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index b5003425..1b284f8d 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: pfedit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index b352fdc8..4c55af90 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: proof_trees.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Closure open Util diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli index 477c3162..0a2c6e9a 100644 --- a/proofs/proof_trees.mli +++ b/proofs/proof_trees.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: proof_trees.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index f7c937bd..d11e6676 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ *) +(*i $Id: proof_type.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (*i*) open Environ diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index c6f0658b..5f8a63b0 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: proof_type.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Environ diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index f7d83c0a..77a5db12 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: redexpr.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli index 93c34d86..ce0cb8e7 100644 --- a/proofs/redexpr.mli +++ b/proofs/redexpr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: redexpr.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Term diff --git a/proofs/refiner.ml b/proofs/refiner.ml index e0ed7861..ddb7eefc 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: refiner.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 2b213c3f..7126533d 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: refiner.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index 8761bfae..00dfb122 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tacexpr.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Topconstr diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 60e79c19..55996f33 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tacmach.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 489786ef..30851b95 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tacmach.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 6455420c..75783ab4 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tactic_debug.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Names open Constrextern diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli index 8a6a22c6..8f74eae6 100644 --- a/proofs/tactic_debug.mli +++ b/proofs/tactic_debug.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tactic_debug.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Environ open Pattern diff --git a/scripts/coqc.ml b/scripts/coqc.ml index c091d030..7185b140 100644 --- a/scripts/coqc.ml +++ b/scripts/coqc.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqc.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Afin de rendre Coq plus portable, ce programme Caml remplace le script coqc. diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index d1f15f8e..ada14fda 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqmktop.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* coqmktop is a script to link Coq, analogous to ocamlmktop. The command line contains options specific to coqmktop, options for the diff --git a/tactics/auto.ml b/tactics/auto.ml index e53e05d0..faf0482b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: auto.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/auto.mli b/tactics/auto.mli index 09af7f8c..9a0719fc 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: auto.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index c81dcfed..09f80377 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: autorewrite.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Equality open Hipattern diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index d6fa2455..b7300cba 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: autorewrite.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index cf536bfd..73aac029 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: btermdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Term open Names @@ -79,8 +79,7 @@ struct | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) - | Sort s when is_small s -> Dn.Label(Term_dn.SortLabel (Some s), []) - | Sort _ -> Dn.Label(Term_dn.SortLabel None, []) + | Sort _ -> Dn.Label(Term_dn.SortLabel, []) | Evar _ -> Dn.Everything | _ -> Dn.Nothing diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 859890a4..14f9fb23 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: btermdn.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Term diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 7105e84d..afd13b4c 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: class_tactics.ml4 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -69,7 +69,7 @@ let evar_filter evi = { evi with evar_hyps = Environ.val_of_named_context hyps'; evar_filter = List.map (fun _ -> true) hyps' } - + let evars_to_goals p evm = let goals, evm' = Evd.fold @@ -85,6 +85,7 @@ let evars_to_goals p evm = if goals = [] then None else let goals = List.rev goals in + let evm' = evars_reset_evd evm' evm in Some (goals, evm') (** Typeclasses instance search tactic / eauto *) @@ -331,7 +332,14 @@ let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls } let solve_tac (x : 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> if gls = [] then sk res fk else fk ()) fk gls } + { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> + if gls = [] then sk res fk else fk ()) fk gls } + +let solve_unif_tac : atac = + { skft = fun sk fk {it = gl; sigma = s} -> + try let s' = Evarconv.consider_remaining_unif_problems (Global.env ()) s in + normevars_tac.skft sk fk ({it=gl; sigma=s'}) + with _ -> fk () } let hints_tac hints = { skft = fun sk fk {it = gl,info; sigma = s} -> @@ -456,7 +464,6 @@ let then_tac (first : atac) (second : atac) : atac = let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = t.skft (fun x _ -> Some x) (fun _ -> None) gl - type run_list_res = (auto_result * run_list_res fk) option let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = @@ -491,7 +498,7 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac = let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in match get_result res with | None -> raise Not_found - | Some (evm', fk) -> Some (Evd.evars_reset_evd evm' evm, fk) + | Some (evm', fk) -> Some (evars_reset_evd evm' evm, fk) let eauto_tac hints = fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac) @@ -551,16 +558,31 @@ let rec merge_deps deps = function else hd :: merge_deps deps tl let evars_of_evi evi = - Intset.union (Evarutil.evars_of_term evi.evar_concl) - (match evi.evar_body with - | Evar_defined b -> Evarutil.evars_of_term b - | Evar_empty -> Intset.empty) + Intset.union (evars_of_term evi.evar_concl) + (Intset.union + (match evi.evar_body with + | Evar_empty -> Intset.empty + | Evar_defined b -> evars_of_term b) + (Evarutil.evars_of_named_context (evar_filtered_context evi))) + +let deps_of_constraints cstrs deps = + List.fold_right (fun (_, _, x, y) deps -> + let evs = Intset.union (evars_of_term x) (evars_of_term y) in + merge_deps evs deps) + cstrs deps + +let evar_dependencies evm = + Evd.fold + (fun ev evi acc -> + merge_deps (Intset.union (Intset.singleton ev) + (evars_of_evi evi)) acc) + evm [] let split_evars evm = - Evd.fold (fun ev evi acc -> - let deps = Intset.union (Intset.singleton ev) (evars_of_evi evi) in - merge_deps deps acc) - evm [] + let _, cstrs = extract_all_conv_pbs evm in + let evmdeps = evar_dependencies evm in + let deps = deps_of_constraints cstrs evmdeps in + List.sort Intset.compare deps let select_evars evs evm = Evd.fold (fun ev evi acc -> diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 44bde497..9ea4892e 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: contradiction.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Term diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 14dcb469..7306f875 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: contradiction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index eebce493..7866d640 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: decl_interp.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Util open Names diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli index 2d8b2c1d..859db444 100644 --- a/tactics/decl_interp.mli +++ b/tactics/decl_interp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_interp.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Tacinterp open Decl_expr diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index 02a0050d..f9a51afe 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_proof_instr.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli index 170269dc..6f8126ed 100644 --- a/tactics/decl_proof_instr.mli +++ b/tactics/decl_proof_instr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: decl_proof_instr.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Refiner open Names diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 4a779edb..5b7e7e94 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: dhyp.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Chet's comments about this tactic : diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index 5af4e56b..a4be2e42 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: dhyp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index d101b9d7..2b25ad73 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: eauto.ml4 13344 2010-07-28 15:04:36Z msozeau $ *) open Pp open Util @@ -396,7 +396,7 @@ END let cons a l = a :: l -let autounfold db cl = +let autounfolds db occs = let unfolds = List.concat (List.map (fun dbname -> let db = try searchtable_map dbname with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) @@ -404,7 +404,15 @@ let autounfold db cl = let (ids, csts) = Hint_db.unfolds db in Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) - in unfold_option unfolds cl + in unfold_option unfolds + +let autounfold db cls gl = + let cls = concrete_clause_of cls gl in + let tac = autounfolds db in + tclMAP (function + | OnHyp (id,occs,where) -> tac occs (Some (id,where)) + | OnConcl occs -> tac occs None) + cls gl let autosimpl db cl = let unfold_of_elts constr (b, elts) = @@ -419,12 +427,13 @@ let autosimpl db cl = unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db) in unfold_option unfolds cl +open Extraargs + TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) "in" hyp(id) ] -> - [ autounfold (match db with None -> ["core"] | Some x -> x) (Some (id, InHyp)) ] -| [ "autounfold" hintbases(db) ] -> - [ autounfold (match db with None -> ["core"] | Some x -> x) None ] - END +| [ "autounfold" hintbases(db) in_arg_hyp(id) ] -> + [ autounfold (match db with None -> Auto.current_db_names () | Some [] -> ["core"] | Some x -> x) + (glob_in_arg_hyp_to_clause id) ] +END let unfold_head env (ids, csts) c = let rec aux c = @@ -498,7 +507,7 @@ TACTIC EXTEND autounfoldify let db = match kind_of_term x with | Const c -> string_of_label (con_label c) | _ -> assert false - in autounfold ["core";db] None ] + in autounfold ["core";db] onConcl ] END TACTIC EXTEND unify diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 331d2b44..eb90b1b6 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -17,6 +17,8 @@ open Environ open Explore (*i*) +val hintbases : hint_db_name list option Pcoq.Gram.Entry.e +val wit_hintbases : hint_db_name list option typed_abstract_argument_type val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type val rawwit_auto_using : constr_expr list raw_abstract_argument_type @@ -36,4 +38,4 @@ val eauto_with_bases : bool * int -> Term.constr list -> Auto.hint_db list -> Proof_type.tactic -val autounfold : hint_db_name list -> Tacticals.goal_location -> tactic +val autounfold : hint_db_name list -> Tacticals.clause -> tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index 7f1d4249..0372a88d 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: elim.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/elim.mli b/tactics/elim.mli index 8ea6695a..fa18ab0b 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: elim.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 77c878fc..c82e8f64 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: elimschemes.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Created by Hugo Herbelin from contents related to inductive schemes initially developed by Christine Paulin (induction schemes), Vincent diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 795add12..ba0389e5 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: elimschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ *) open Ind_tables diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 7ed6bf1e..90e4b44c 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -14,7 +14,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: eqdecide.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Names diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 9972c2a5..22c3b47f 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: eqschemes.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* File created by Hugo Herbelin, Nov 2009 *) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index ae3b1578..447fb359 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: eqschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* This file builds schemes relative to equality inductive types *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 68f0cc7c..6b16adb4 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: equality.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/equality.mli b/tactics/equality.mli index 7c09ae09..f14b3867 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: equality.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 78757939..3e2191d1 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: evar_tactics.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Util diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index ed4a33ae..78412150 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: evar_tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Tacmach open Names diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index bb63f6b9..c9b2a969 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: extraargs.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Pcoq diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 22a0c2da..e53fc604 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extraargs.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Tacexpr open Term diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 7afd0543..e1ac42c2 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: extratactics.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Pcoq diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 50757148..cfbc8f3d 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: extratactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Proof_type diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 12ecbd9a..220c00d3 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: hiddentac.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Term open Proof_type diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 7bd57cdd..1724bf9c 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: hiddentac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 3dc9403c..dfa596d3 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*) -(* $Id$ *) +(* $Id: hipattern.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index f486f348..cf4cdd0d 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: hipattern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/tactics/inv.ml b/tactics/inv.ml index 7290b66b..430f7d5f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: inv.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/inv.mli b/tactics/inv.mli index 033082e9..eb899699 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: inv.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/tactics/leminv.ml b/tactics/leminv.ml index c102d8ec..76432dd8 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: leminv.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index 26167978..bdea29df 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: nbtermdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Util open Names @@ -117,7 +117,7 @@ let constr_val_discr_st (idpred,cpred) t = | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l) | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c]) | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l) - | Sort s -> Dn.Label(Term_dn.SortLabel (Some s), []) + | Sort _ -> Dn.Label(Term_dn.SortLabel, []) | Evar _ -> Dn.Everything | _ -> Dn.Nothing diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli index 3b90b12a..36c54bd3 100644 --- a/tactics/nbtermdn.mli +++ b/tactics/nbtermdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: nbtermdn.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Term @@ -24,7 +24,7 @@ sig | GRLabel of global_reference | ProdLabel | LambdaLabel - | SortLabel of sorts option + | SortLabel end type 'na t diff --git a/tactics/refine.ml b/tactics/refine.ml index 87769ccb..06a78011 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: refine.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* JCF -- 6 janvier 1998 EXPERIMENTAL *) diff --git a/tactics/refine.mli b/tactics/refine.mli index e847a749..55b4033b 100644 --- a/tactics/refine.mli +++ b/tactics/refine.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: refine.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Tacmach diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index 010fd088..9d99ad96 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -135,8 +135,7 @@ let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrit let arrow_morphism a b = if isprop a && isprop b then Lazy.force impl - else - mkApp(Lazy.force arrow, [|a;b|]) + else Lazy.force arrow let setoid_refl pars x = applistc (Lazy.force setoid_refl_proj) (pars @ [x]) @@ -176,17 +175,18 @@ let new_cstr_evar (goal,cstr) env t = let cstr', t = Evarutil.new_evar cstr env t in (goal, cstr'), t -let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) (f : 'a -> constr) = +let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = let new_evar evars env t = 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 = match obj with - | None -> + | None | Some (_, None) -> let relty = mk_relation ty in new_evar evars env relty - | Some x -> evars, f x + | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = let t = Reductionops.whd_betadeltaiota env (fst evars) ty in @@ -209,12 +209,11 @@ let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) | _, obj :: _ -> anomaly "build_signature: not enough products" | _, [] -> (match finalcstr with - | None -> + | None | Some (_, None) -> let t = Reductionops.nf_betaiota (fst evars) ty in let evars, rel = mk_relty evars env t None in evars, t, rel, [t, Some rel] - | Some codom -> let (t, rel) = codom in - evars, t, rel, [t, Some rel]) + | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) in aux env evars m cstrs let proper_proof env evars carrier relation x = @@ -248,7 +247,7 @@ type hypinfo = { l2r : bool; c1 : constr; c2 : constr; - c : constr option; + c : constr with_bindings option; abs : (constr * types) option; } @@ -256,25 +255,35 @@ let evd_convertible env evd x y = try ignore(Evarconv.the_conv_x env x y evd); true with _ -> false -let decompose_applied_relation env sigma c left2right = +let rec decompose_app_rel env evd t = + match kind_of_term t with + | App (f, args) -> + if Array.length args > 1 then + let fargs, args = array_chop (Array.length args - 2) args in + mkApp (f, fargs), args + else + let (f', args) = decompose_app_rel env evd args.(0) in + let ty = Typing.type_of env evd args.(0) in + let f'' = mkLambda (Name (id_of_string "x"), ty, + mkLambda (Name (id_of_string "y"), lift 1 ty, + mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) + in (f'', args) + | _ -> error "The term provided is not an applied relation." + +let decompose_applied_relation env sigma (c,l) left2right = let ctype = Typing.type_of env sigma c in let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> error "The term provided is not an applied relation." in - let others,(c1,c2) = split_last_two args in + let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c,ty) l in + let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in + let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None else Some { cl=eqclause; prf=(Clenv.clenv_value eqclause); - car=ty1; rel=mkApp (equiv, Array.of_list others); - l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } + car=ty1; rel = equiv; + l2r=left2right; c1=c1; c2=c2; c=Some (c,l); abs=None } in match find_rel ctype with | Some c -> c @@ -398,27 +407,53 @@ let rec decomp_pointwise n c = if n = 0 then c else match kind_of_term c with - | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb - | _ -> raise Not_found + | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> raise (Invalid_argument "decomp_pointwise") + +let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> raise (Invalid_argument "apply_pointwise")) + | [] -> rel + +let pointwise_or_dep_relation n t car rel = + if noccurn 1 car then + mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) + else + mkApp (Lazy.force forall_relation, + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) -let lift_cstr env sigma evars args cstr = +let lift_cstr env sigma evars (args : constr list) ty cstr = let cstr = - let start = + let start env car = match cstr with - | Some codom -> codom - | None -> - let car = Evarutil.e_new_evar evars env (new_Type ()) in - let rel = Evarutil.e_new_evar evars env (mk_relation car) in - (car, rel) + | None | Some (_, None) -> + Evarutil.e_new_evar evars env (mk_relation car) + | Some (ty, Some rel) -> rel in - Array.fold_right - (fun arg (car, rel) -> - let ty = Typing.type_of env sigma arg in - let car' = mkProd (Anonymous, ty, car) in - let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in - (car', rel')) - args start - in Some cstr + let rec aux env prod n = + if n = 0 then start env prod + else + match kind_of_term (Reduction.whd_betadeltaiota env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let rb = aux env b' (pred n) in + mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |]) + else + let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in + mkApp (Lazy.force forall_relation, + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]) + | _ -> assert false + in aux env ty (List.length args) + in Some (ty, cstr) let unlift_cstr env sigma = function | None -> None @@ -430,12 +465,17 @@ let default_flags = { under_lambdas = true; on_morphisms = true; } type evars = evar_map * evar_map (* goal evars, constraint evars *) +type rewrite_proof = + | RewPrf of constr * constr + | RewCast of cast_kind + +let get_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None + type rewrite_result_info = { rew_car : constr; - rew_rel : constr; rew_from : constr; rew_to : constr; - rew_prf : constr; + rew_prf : rewrite_proof; rew_evars : evars; } @@ -444,7 +484,13 @@ type rewrite_result = rewrite_result_info option type strategy = Environ.env -> evar_map -> constr -> types -> constr option -> evars -> rewrite_result option -let resolve_subrelation env sigma car rel rel' res = +let get_rew_prf r = match r.rew_prf with + | RewPrf (rel, prf) -> prf + | RewCast c -> + mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]), + c, mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |])) + +let resolve_subrelation env sigma car rel prf rel' res = if eq_constr rel rel' then res else (* try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *) @@ -452,12 +498,11 @@ let resolve_subrelation env sigma car rel rel' res = (* with NotConvertible -> *) let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in let evars, subrel = new_cstr_evar res.rew_evars env app in + let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with - rew_prf = mkApp (subrel, [| res.rew_from ; res.rew_to ; res.rew_prf |]); - rew_rel = rel'; + rew_prf = RewPrf (rel', appsub); rew_evars = evars } - let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = try (array_find args' (fun i b -> b <> None)) @@ -466,9 +511,11 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars let morphargs', morphobjs' = array_chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.type_of env sigma appm in - let cstrs = List.map (Option.map (fun r -> r.rew_car, r.rew_rel)) (Array.to_list morphobjs') in + let cstrs = List.map (Option.map (fun r -> r.rew_car, get_rew_rel r.rew_prf)) (Array.to_list morphobjs') in (* Desired signature *) - let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a,r) -> r) in + let evars, appmtype', signature, sigargs = + build_signature evars env appmtype cstrs cstr + in (* Actual signature found *) let cl_args = [| appmtype' ; signature ; appm |] in let app = mkApp (Lazy.force proper_type, cl_args) in @@ -492,7 +539,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars let evars, proof = proper_proof env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' | Some r -> - [ r.rew_prf; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') + [ get_rew_prf r; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') | None -> if y <> None then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') @@ -504,10 +551,10 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars [ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt | _ -> assert(false) -let apply_constraint env sigma car rel cstr res = +let apply_constraint env sigma car rel prf cstr res = match cstr with | None -> res - | Some r -> resolve_subrelation env sigma car rel r res + | Some r -> resolve_subrelation env sigma car rel prf r res let eq_env x y = x == y @@ -523,12 +570,14 @@ let apply_rule hypinfo loccs : strategy = match unif with | Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ -> begin - let goalevars = Evd.evar_merge (fst evars) - (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd)) - in - let res = { rew_car = ty; rew_rel = rel; rew_from = c1; - rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars } - in Some (Some (apply_constraint env sigma car rel cstr res)) + if eq_constr t c2 then Some None + else + let goalevars = Evd.evar_merge (fst evars) + (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd)) + in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars } + in Some (Some (apply_constraint env sigma car rel prf cstr res)) end | _ -> None @@ -539,24 +588,79 @@ let apply_lemma (evm,c) left2right loccs : strategy = apply_rule hypinfo loccs env sigma let make_leibniz_proof c ty r = - let prf = mkApp (Lazy.force coq_f_equal, - [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c (mkRel 1)); - r.rew_from; r.rew_to; r.rew_prf |]) + let prf = + match r.rew_prf with + | RewPrf (rel, prf) -> + let rel = mkApp (Lazy.force coq_eq, [| ty |]) in + let prf = + mkApp (Lazy.force coq_f_equal, + [| r.rew_car; ty; + mkLambda (Anonymous, r.rew_car, c (mkRel 1)); + r.rew_from; r.rew_to; prf |]) + in RewPrf (rel, prf) + | RewCast k -> r.rew_prf in - { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]); + { r with rew_car = ty; rew_from = c r.rew_from; rew_to = c r.rew_to; rew_prf = prf } -let pointwise_or_dep_relation n t car rel = - if noccurn 1 car then - mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) - else - mkApp (Lazy.force forall_relation, - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]) - +open Elimschemes + +let reset_env env = + let env' = Global.env_of_context (Environ.named_context_val env) in + Environ.push_rel_context (Environ.rel_context env) env' + +let fold_match ?(force=false) env sigma c = + let (ci, p, c, brs) = destCase c in + let cty = Retyping.get_type_of env sigma c in + let dep, pred, exists, sk = + let env', ctx, body = + let ctx, pred = decompose_lam_assum p in + let env' = Environ.push_rel_context ctx env in + env', ctx, pred + in + let sortp = Retyping.get_sort_family_of env' sigma body in + let sortc = Retyping.get_sort_family_of env sigma cty in + let dep = not (noccurn 1 body) in + let pred = if dep then p else + it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) + in + let sk = + if sortp = InProp then + if sortc = InProp then + if dep then case_dep_scheme_kind_from_prop + else case_scheme_kind_from_prop + else ( + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) + else ((* sortc <> InProp by typing *) + if dep + then case_dep_scheme_kind_from_type + else case_scheme_kind_from_type) + in + let exists = Ind_tables.check_scheme sk ci.ci_ind in + if exists || force then + dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + else raise Not_found + in + let app = + let ind, args = Inductive.find_rectype env cty in + let pars, args = list_chop ci.ci_npar args in + let meths = List.map (fun br -> br) (Array.to_list brs) in + applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) + in + sk, (if exists then env else reset_env env), app + +let unfold_match env sigma sk app = + match kind_of_term app with + | App (f', args) when f' = mkConst sk -> + let v = Environ.constant_value (Global.env ()) sk in + Reductionops.whd_beta sigma (mkApp (v, args)) + | _ -> app + let subterm all flags (s : strategy) : strategy = let rec aux env sigma t ty cstr evars = - let cstr' = Option.map (fun c -> (ty, c)) cstr in + let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> let rewrite_args success = @@ -578,29 +682,39 @@ let subterm all flags (s : strategy) : strategy = | Some true -> let args' = Array.of_list (List.rev args') in let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in - let res = { rew_car = ty; rew_rel = rel; rew_from = c1; - rew_to = c2; rew_prf = prf; rew_evars = evars' } in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Some (Some res) in if flags.on_morphisms then let evarsref = ref (snd evars) in - let cstr' = lift_cstr env sigma evarsref args cstr' in - let m' = s env sigma m (Typing.type_of env sigma m) - (Option.map snd cstr') (fst evars, !evarsref) - in + let mty = Typing.type_of env sigma m in + let argsl = Array.to_list args in + let cstr' = lift_cstr env sigma evarsref argsl mty None in + let m' = s env sigma m mty (Option.map snd cstr') (fst evars, !evarsref) in match m' with | None -> rewrite_args None (* Standard path, try rewrite on arguments *) | Some None -> rewrite_args (Some false) | Some (Some r) -> (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) - let nargs = Array.length args in + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + RewPrf (apply_pointwise rel argsl, mkApp (prf, args)) + | x -> x + in let res = - { rew_car = decomp_prod env (fst r.rew_evars) nargs r.rew_car; - rew_rel = decomp_pointwise nargs r.rew_rel; + { rew_car = prod_appvect r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = mkApp (r.rew_prf, args); rew_evars = r.rew_evars } - in Some (Some res) + rew_prf = prf; + rew_evars = r.rew_evars } + in + match prf with + | RewPrf (rel, prf) -> + Some (Some (apply_constraint env sigma res.rew_car rel prf cstr res)) + | _ -> Some (Some res) else rewrite_args None | Prod (n, x, b) when noccurn 1 b -> @@ -637,18 +751,24 @@ let subterm all flags (s : strategy) : strategy = let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in (match b' with | Some (Some r) -> - Some (Some { r with - rew_prf = mkLambda (n, t, r.rew_prf); - rew_car = mkProd (n, t, r.rew_car); - rew_rel = pointwise_or_dep_relation n t r.rew_car r.rew_rel; - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) }) + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + let rel = pointwise_or_dep_relation n t r.rew_car rel in + let prf = mkLambda (n, t, prf) in + RewPrf (rel, prf) + | x -> x + in + Some (Some { r with + rew_prf = prf; + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) }) | _ -> b') | Case (ci, p, c, brs) -> let cty = Typing.type_of env sigma c in - let cstr = Some (mkApp (Lazy.force coq_eq, [| cty |])) in - let c' = s env sigma c cty cstr evars in + let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in + let c' = s env sigma c cty cstr' evars in (match c' with | Some (Some r) -> Some (Some (make_leibniz_proof (fun x -> mkCase (ci, p, x, brs)) ty r)) @@ -668,7 +788,14 @@ let subterm all flags (s : strategy) : strategy = let ctxc x = mkCase (ci, p, c, Array.of_list (List.rev (brs' x))) in Some (Some (make_leibniz_proof ctxc ty r)) | None -> x - else x) + else + match try Some (fold_match env sigma t) with Not_found -> None with + | None -> x + | Some (cst, _, t') -> + match aux env sigma t' ty cstr evars with + | Some (Some prf) -> Some (Some { prf with + rew_from = t; rew_to = unfold_match env sigma cst prf.rew_to }) + | x' -> x) | _ -> if all then Some None else None in aux @@ -676,19 +803,27 @@ let subterm all flags (s : strategy) : strategy = let all_subterms = subterm true default_flags let one_subterm = subterm false default_flags -(** Requires transitivity of the rewrite step, not tail-recursive. *) +(** Requires transitivity of the rewrite step, if not a reduction. + Not tail-recursive. *) let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option = - match next env sigma res.rew_to res.rew_car (Some res.rew_rel) res.rew_evars with + match next env sigma res.rew_to res.rew_car (get_rew_rel res.rew_prf) res.rew_evars with | None -> None | Some None -> Some (Some res) | Some (Some res') -> - let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car ; res.rew_rel |]) in - let evars, prf = new_cstr_evar res'.rew_evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - res.rew_prf; res'.rew_prf |]) - in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = prf }) - + match res.rew_prf with + | RewCast c -> Some (Some { res' with rew_from = res.rew_from }) + | RewPrf (rew_rel, rew_prf) -> + match res'.rew_prf with + | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to })) + | RewPrf (res'_rel, res'_prf) -> + let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in + let evars, prf = new_cstr_evar res'.rew_evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Some (Some { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }) + (** Rewriting strategies. Inspired by ELAN's rewriting strategies: @@ -714,8 +849,8 @@ module Strategies = let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in new_cstr_evar evars env mty in - Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t; - rew_prf = proof; rew_evars = evars }) + Some (Some { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars }) let progress (s : strategy) : strategy = fun env sigma t ty cstr evars -> @@ -769,13 +904,24 @@ module Strategies = let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in - lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) + lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) let hints (db : string) : strategy = fun env sigma t ty cstr evars -> - let rules = Autorewrite.find_matches db t in - lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) - env sigma t ty cstr evars + let rules = Autorewrite.find_matches db t in + lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules) + env sigma t ty cstr evars + + let reduce (r : Redexpr.red_expr) : strategy = + let rfn, ckind = Redexpr.reduction_of_red_expr r in + fun env sigma t ty cstr evars -> + let t' = rfn env sigma t in + if eq_constr t' t then + Some None + else + Some (Some { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; rew_evars = evars }) + end @@ -787,7 +933,7 @@ let rewrite_strat flags occs hyp = Strategies.choice app (subterm true flags (fun env -> aux () env)) in aux () -let rewrite_with (evm,c) left2right loccs : strategy = +let rewrite_with {it = c; sigma = evm} left2right loccs : strategy = fun env sigma -> let evars = Evd.merge sigma evm in let hypinfo = ref (decompose_applied_relation env evars c left2right) in @@ -803,7 +949,7 @@ let apply_strategy (s : strategy) env sigma concl cstr evars = | Some None -> Some None | Some (Some res) -> evars := res.rew_evars; - Some (Some (res.rew_prf, (res.rew_car, res.rew_rel, res.rew_from, res.rew_to))) + Some (Some (res.rew_prf, (res.rew_car, res.rew_from, res.rew_to))) let split_evars_once sigma evd = Evd.fold (fun ev evi deps -> @@ -834,6 +980,12 @@ let solve_constraints env evars = let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) +let map_rewprf f = function + | RewPrf (rel, prf) -> RewPrf (f rel, f prf) + | RewCast c -> RewCast c + +exception RewriteFailure + let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = let concl, is_hyp = match clause with @@ -852,12 +1004,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = let env = pf_env gl in let eq = apply_strategy strat env sigma concl (Some cstr) evars in match eq with - | Some (Some (p, (_, _, oldt, newt))) -> + | Some (Some (p, (car, oldt, newt))) -> (try let cstrevars = !evars in let evars = solve_constraints env cstrevars in - let p = Evarutil.nf_evar evars p in - let p = nf_zeta env evars p in + let p = map_rewprf + (fun p -> nf_zeta env evars (Evarutil.nf_evar evars p)) + p + in let newt = Evarutil.nf_evar evars newt in let abs = Option.map (fun (x, y) -> Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in @@ -865,27 +1019,36 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = let rewtac = match is_hyp with | Some id -> - let term = - match abs with - | None -> p - | Some (t, ty) -> - mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) - in - cut_replacing id newt - (Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) + (match p with + | RewPrf (rel, p) -> + let term = + match abs with + | None -> p + | Some (t, ty) -> + mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) + in + cut_replacing id newt + (Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) + | RewCast c -> + change_in_hyp None newt (id, InHypTypeOnly)) + | None -> - (match abs with - | None -> - let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in - tclTHENLAST - (Tacmach.internal_cut_no_check false name newt) - (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) - | Some (t, ty) -> - Tacmach.refine_no_check - (mkApp (mkLambda (Name (id_of_string "newt"), newt, - mkLambda (Name (id_of_string "lemma"), ty, - mkApp (p, [| mkRel 2 |]))), - [| mkMeta goal_meta; t |]))) + (match p with + | RewPrf (rel, p) -> + (match abs with + | None -> + let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in + tclTHENLAST + (Tacmach.internal_cut_no_check false name newt) + (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) + | Some (t, ty) -> + Tacmach.refine_no_check + (mkApp (mkLambda (Name (id_of_string "newt"), newt, + mkLambda (Name (id_of_string "lemma"), ty, + mkApp (p, [| mkRel 2 |]))), + [| mkMeta goal_meta; t |]))) + | RewCast c -> + change_in_concl None newt) in let evartac = if not (undef = Evd.empty) then @@ -900,14 +1063,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = ++ fnl () ++ Himsg.explain_typeclass_error env e)) gl) | Some None -> tclFAIL 0 (str"setoid rewrite failed: no progress made") gl - | None -> raise Not_found + | None -> raise RewriteFailure let cl_rewrite_clause_strat strat clause gl = init_setoid (); let meta = Evarutil.new_meta() in let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in try cl_rewrite_clause_aux strat meta clause gl - with Not_found -> + with RewriteFailure -> tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl let cl_rewrite_clause l left2right occs clause gl = @@ -939,11 +1102,13 @@ let glob_strategy ist l = l let subst_strategy evm l = l let apply_constr_expr c l2r occs = fun env sigma -> - let c = Constrintern.interp_open_constr sigma env c in - apply_lemma c l2r occs env sigma + let evd, c = Constrintern.interp_open_constr sigma env c in + apply_lemma (evd, (c, NoBindings)) l2r occs env sigma -let interp_constr_list env sigma cs = - List.map (fun c -> Constrintern.interp_open_constr sigma env c, true) cs +let interp_constr_list env sigma = + List.map (fun c -> + let evd, c = Constrintern.interp_open_constr sigma env c in + (evd, (c, NoBindings)), true) open Pcoq @@ -980,15 +1145,18 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ] | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ] | [ "hints" preident(h) ] -> [ Strategies.hints h ] - | [ "terms" constr_list(h) ] -> [ fun env sigma -> Strategies.lemmas (interp_constr_list env sigma h) env sigma ] + | [ "terms" constr_list(h) ] -> [ fun env sigma -> + Strategies.lemmas (interp_constr_list env sigma h) env sigma ] + | [ "eval" red_expr(r) ] -> [ fun env sigma -> + Strategies.reduce (Tacinterp.interp_redexp env sigma r) env sigma ] END TACTIC EXTEND class_rewrite -| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ] -| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] -| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] +| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ] +| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ] +| [ "clrewrite" orient(o) constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] END TACTIC EXTEND class_rewrite_strat @@ -998,7 +1166,7 @@ END let clsubstitute o c = - let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in + let is_tac id = match kind_of_term (fst c.it) with Var id' when id' = id -> true | _ -> false in Tacticals.onAllHypsAndConcl (fun cl -> match cl with @@ -1006,22 +1174,22 @@ let clsubstitute o c = | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl)) TACTIC EXTEND substitute -| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ] +| [ "substitute" orient(o) constr_with_bindings(c) ] -> [ clsubstitute o c ] END (* Compatibility with old Setoids *) TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) open_constr(c) ] + [ "setoid_rewrite" orient(o) constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] - | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] -> + | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id)] - | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> + | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None] - | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] -> + | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] - | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] -> + | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id)] END @@ -1104,12 +1272,12 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) -type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type +type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type -let (wit_binders_let : Genarg.tlevel binders_let_argtype), - (globwit_binders_let : Genarg.glevel binders_let_argtype), - (rawwit_binders_let : Genarg.rlevel binders_let_argtype) = - Genarg.create_arg "binders_let" +let (wit_binders : Genarg.tlevel binders_argtype), + (globwit_binders : Genarg.glevel binders_argtype), + (rawwit_binders : Genarg.rlevel binders_argtype) = + Genarg.create_arg "binders" open Pcoq.Constr @@ -1147,35 +1315,35 @@ VERNAC COMMAND EXTEND AddRelation3 END VERNAC COMMAND EXTEND AddParametricRelation - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None None ] END VERNAC COMMAND EXTEND AddParametricRelation2 - [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] END VERNAC COMMAND EXTEND AddParametricRelation3 - [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END @@ -1242,7 +1410,7 @@ let build_morphism_signature m = | _ -> [] in aux t in - let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None snd in + let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None in let _ = isevars := evars in let _ = List.iter (fun (ty, rel) -> @@ -1264,7 +1432,7 @@ let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in let evars, _, sign, cstrs = - build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) (fun (ty, rel) -> rel) + build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) in let morph = mkApp (Lazy.force proper_type, [| t; sign; m |]) @@ -1324,13 +1492,13 @@ let add_morphism glob binders m s n = VERNAC COMMAND EXTEND AddSetoid1 [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid [] a aeq t n ] - | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> [ add_setoid binders a aeq t n ] | [ "Add" "Morphism" constr(m) ":" ident(n) ] -> [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ] - | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) + | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ] END @@ -1390,16 +1558,16 @@ let unification_rewrite l2r c1 c2 cl car rel but gl = let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} -let get_hyp gl evars c clause l2r = - let hi = decompose_applied_relation (pf_env gl) evars c l2r in +let get_hyp gl evars (c,l) clause l2r = + let hi = decompose_applied_relation (pf_env gl) evars (c,l) l2r in let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl -let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } +let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } -let apply_lemma gl c cl l2r occs = +let apply_lemma gl (c,l) cl l2r occs = let sigma = project gl in - let hypinfo = ref (get_hyp gl sigma c cl l2r) in + let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in let app = apply_rule hypinfo occs in let rec aux () = Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) @@ -1407,12 +1575,12 @@ let apply_lemma gl c cl l2r occs = let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let meta = Evarutil.new_meta() in - let hypinfo, strat = apply_lemma gl c cl l2r occs in + let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in try tclTHEN (Refiner.tclEVARS hypinfo.cl.evd) (cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl - with Not_found -> + with RewriteFailure -> let {l2r=l2r; c1=x; c2=y} = hypinfo in raise (Pretype_errors.PretypeError (pf_env gl, @@ -1441,18 +1609,10 @@ let not_declared env ty rel = tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ str ty ++ str" relation. Maybe you need to require the Setoid library") -let relation_of_constr env c = - match kind_of_term c with - | App (f, args) when Array.length args >= 2 -> - let relargs, args = array_chop (Array.length args - 2) args in - mkApp (f, relargs), args - | _ -> errorlabstrm "relation_of_constr" - (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") - let setoid_proof gl ty fn fallback = let env = pf_env gl in try - let rel, args = relation_of_constr env (pf_concl gl) in + let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in let evm, car = project gl, pf_type_of gl args.(0) in fn env evm car rel gl with e -> @@ -1460,7 +1620,7 @@ let setoid_proof gl ty fn fallback = with Hipattern.NoEquationFound -> match e with | Not_found -> - let rel, args = relation_of_constr env (pf_concl gl) in + let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in not_declared env ty rel gl | _ -> raise e @@ -1480,8 +1640,7 @@ let setoid_transitivity c gl = let proof = get_transitive_proof env evm car rel in match c with | None -> eapply proof - | Some c -> - apply_with_bindings (proof,Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) + | Some c -> apply_with_bindings (proof,Rawterm.ImplicitBindings [ c ])) (transitivity_red true c) let setoid_symmetry_in id gl = @@ -1539,3 +1698,25 @@ let implify id gl = TACTIC EXTEND implify [ "implify" hyp(n) ] -> [ implify n ] END + +let rec fold_matches env sigma c = + map_constr_with_full_binders Environ.push_rel + (fun env c -> + match kind_of_term c with + | Case _ -> + let cst, env, c' = fold_match ~force:true env sigma c in + fold_matches env sigma c' + | _ -> fold_matches env sigma c) + env c + +TACTIC EXTEND fold_match +[ "fold_match" constr(c) ] -> [ fun gl -> + let _, _, c' = fold_match ~force:true (pf_env gl) (project gl) c in + change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ] +END + +TACTIC EXTEND fold_matches +| [ "fold_matches" constr(c) ] -> [ fun gl -> + let c' = fold_matches (pf_env gl) (project gl) c in + change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ] +END diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 291df0fe..95e44c40 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tacinterp.ml 13360 2010-07-30 08:47:08Z herbelin $ *) open Constrintern open Closure @@ -2415,7 +2415,9 @@ and interp_atomic ist gl tac = | TacChange (Some op,c,cl) -> let sign,op = interp_typed_pattern ist env sigma op in h_change (Some op) - (pf_interp_constr ist (extend_gl_hyps gl sign) c) + (try pf_interp_constr ist (extend_gl_hyps gl sign) c + with Not_found | Anomaly _ (* Hack *) -> + errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")) (interp_clause ist gl cl) (* Equivalence relations *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 854664e9..82f4d99a 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tacinterp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml new file mode 100644 index 00000000..df5a3283 --- /dev/null +++ b/tactics/tactic_option.ml @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *) + +open Libobject +open Proof_type +open Pp + +let declare_tactic_option ?(default=Tacexpr.TacId []) name = + let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref default in + let default_tactic : Proof_type.tactic ref = ref (Tacinterp.eval_tactic !default_tactic_expr) in + let locality = ref false in + let set_default_tactic local t = + locality := local; + default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t + in + let cache (_, (local, tac)) = set_default_tactic local tac in + let load (_, (local, tac)) = + if not local then set_default_tactic local tac + in + let subst (s, (local, tac)) = + (local, Tacinterp.subst_tactic s tac) + in + let input, _output = + declare_object + { (default_object name) with + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if local then Dispose else Substitute (local, tac)); + subst_function = subst} + in + let put local tac = + set_default_tactic local tac; + Lib.add_anonymous_leaf (input (local, tac)) + in + let get () = !locality, !default_tactic in + let print () = + Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ + (if !locality then str" (locally defined)" else str" (globally defined)") + in + let freeze () = !locality, !default_tactic_expr in + let unfreeze (local, t) = set_default_tactic local t in + let init () = () in + Summary.declare_summary name + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init }; + put, get, print + diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli new file mode 100644 index 00000000..890ba98e --- /dev/null +++ b/tactics/tactic_option.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *) + +open Proof_type +open Tacexpr +open Vernacexpr + +val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> + (* put *) (locality_flag -> glob_tactic_expr -> unit) * + (* get *) (unit -> locality_flag * tactic) * + (* print *) (unit -> Pp.std_ppcmds) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 59a8b794..171a35c0 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tacticals.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 90508436..af74e382 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tacticals.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e09707ab..9e4be0af 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: tactics.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -2320,6 +2320,9 @@ let linear vars args = true with Seen -> false +let is_defined_variable env id = + pi2 (lookup_named id env) <> None + let abstract_args gl generalize_vars dep id defined f args = let sigma = project gl in let env = pf_env gl in @@ -2347,7 +2350,7 @@ let abstract_args gl generalize_vars dep id defined f args = let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in match kind_of_term arg with - | Var id when leq && not (Idset.mem id nongenvars) -> + | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, Idset.add id nongenvars, Idset.remove id vars, env) | _ -> @@ -2374,7 +2377,7 @@ let abstract_args gl generalize_vars dep id defined f args = let parvars = ids_of_constr ~all:true Idset.empty f' in if not (linear parvars args') then true, f, args else - match array_find_i (fun i x -> not (isVar x)) args' with + match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with | None -> false, f', args' | Some nonvar -> let before, after = array_chop nonvar args' in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 92477e23..bfc32654 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 0a634138..b885b152 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -21,3 +21,4 @@ Evar_tactics Autorewrite Decl_interp Decl_proof_instr +Tactic_option diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 6091e3d1..a7e7613d 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id$ i*) +(*i $Id: tauto.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*) open Term open Hipattern diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 828fc065..f9f086d9 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: termdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Util open Names @@ -33,7 +33,7 @@ struct | GRLabel of global_reference | ProdLabel | LambdaLabel - | SortLabel of sorts option + | SortLabel module Y = struct type t = term_label @@ -97,12 +97,7 @@ let constr_pat_discr_st (idpred,cpred) t = Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l) - | PSort s, [] -> - let s' = match s with - | RProp c -> Some (Prop c) - | RType _ -> None - (* Don't try to be clever about type levels here *) - in Some (SortLabel s', []) + | PSort s, [] -> Some (SortLabel, []) | _ -> None open Dn @@ -125,8 +120,7 @@ let constr_val_discr_st (idpred,cpred) t = | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l) - | Sort s when is_small s -> Label(SortLabel (Some s), []) - | Sort _ -> Label (SortLabel None, []) + | Sort _ -> Label (SortLabel, []) | Evar _ -> Everything | _ -> Nothing diff --git a/tactics/termdn.mli b/tactics/termdn.mli index b7c9f273..e778de8d 100644 --- a/tactics/termdn.mli +++ b/tactics/termdn.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: termdn.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Term @@ -58,7 +58,7 @@ sig | GRLabel of global_reference | ProdLabel | LambdaLabel - | SortLabel of sorts option + | SortLabel val constr_pat_discr_st : transparent_state -> constr_pattern -> (term_label * constr_pattern list) option diff --git a/test-suite/bugs/closed/2319.v b/test-suite/bugs/closed/2319.v new file mode 100644 index 00000000..e06fb975 --- /dev/null +++ b/test-suite/bugs/closed/2319.v @@ -0,0 +1,13 @@ +Section S. + + CoInductive A (X: Type) := mkA: A X -> A X. + Variable T : Type. + + (* This used to loop (bug #2319) *) + Timeout 5 Eval vm_compute in cofix s : A T := mkA T s. + + CoFixpoint s : A T := mkA T s + with t : A unit := mkA unit (mkA unit t). + Timeout 5 Eval vm_compute in s. + +End S.
\ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v index f1872a2b..ea72ba89 100644 --- a/test-suite/bugs/closed/shouldsucceed/1507.v +++ b/test-suite/bugs/closed/shouldsucceed/1507.v @@ -2,7 +2,7 @@ Implementing reals a la Stolzenberg Danko Ilik, March 2007 - svn revision: $Id$ + svn revision: $Id: 1507.v 12337 2009-09-17 15:58:14Z glondu $ XField.v -- (unfinished) axiomatisation of the theories of real and rational intervals. diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/shouldsucceed/2145.v index b6c5da65..4dc0de74 100644 --- a/test-suite/bugs/closed/shouldsucceed/2145.v +++ b/test-suite/bugs/closed/shouldsucceed/2145.v @@ -1,7 +1,7 @@ (* Test robustness of Groebner tactic in presence of disequalities *) Require Export Reals. -Require Export NsatzR. +Require Export Nsatz. Open Scope R_scope. @@ -15,6 +15,6 @@ Lemma essai : Proof. intros. (* clear H. groebner used not to work when H was not cleared *) -nsatzR. +nsatz. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2262.v b/test-suite/bugs/closed/shouldsucceed/2262.v new file mode 100644 index 00000000..b61f18b8 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2262.v @@ -0,0 +1,11 @@ + + +Generalizable Variables A. +Class Test A := { test : A }. + +Lemma mylemma : forall `{Test A}, test = test. +Admitted. (* works fine *) + +Definition mylemma' := forall `{Test A}, test = test. +About mylemma'. + diff --git a/test-suite/bugs/closed/shouldsucceed/2303.v b/test-suite/bugs/closed/shouldsucceed/2303.v new file mode 100644 index 00000000..e614b9b5 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2303.v @@ -0,0 +1,4 @@ +Class A := a: unit. +Class B (x: unit). +Axiom H: forall x: A, @B x -> x = x -> unit. +Definition Field (z: A) (m: @B z) x := (@H _ _ x) = z. diff --git a/test-suite/bugs/closed/shouldsucceed/2347.v b/test-suite/bugs/closed/shouldsucceed/2347.v new file mode 100644 index 00000000..e433f158 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2347.v @@ -0,0 +1,10 @@ +Require Import EquivDec List. +Generalizable All Variables. + +Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := + (fun (x y : list A) => _). +Admit Obligations of list_eqdec. + +Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq := + (fun _ : nat => (fun (x y : list A) => _)) 0. +Admit Obligations of list_eqdec'. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 924030ba..215d9b68 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -46,6 +46,32 @@ fun x : nat => ifn x is succ n then n else 0 : bool -4 : Z +The command has indeed failed with message: +=> Error: x should not be bound in a recursive pattern of the right-hand side. +The command has indeed failed with message: +=> Error: in the right-hand side, y and z should appear in + term position as part of a recursive pattern. +The command has indeed failed with message: +=> Error: The reference w was not found in the current environment. +The command has indeed failed with message: +=> Error: x is unbound in the right-hand side. +The command has indeed failed with message: +=> Error: in the right-hand side, y and z should appear in + term position as part of a recursive pattern. +The command has indeed failed with message: +=> Error: z is expected to occur in binding position in the right-hand side. +The command has indeed failed with message: +=> Error: as y is a non-closed binder, no such "," is allowed to occur. +The command has indeed failed with message: +=> Error: Cannot find where the recursive pattern starts. +The command has indeed failed with message: +=> Error: Cannot find where the recursive pattern starts. +The command has indeed failed with message: +=> Error: Cannot find where the recursive pattern starts. +The command has indeed failed with message: +=> Error: Cannot find where the recursive pattern starts. +The command has indeed failed with message: +=> Error: Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) @@ -59,6 +85,8 @@ Defining 'I' as keyword : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) +[|0 * (1, 2, 3); (4, 5, 6) * false|] + : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool)) fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z : (Z -> Z -> Z -> Z) -> Z plus diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index f041b9b7..b8f8f48f 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -121,6 +121,39 @@ Notation "- 4" := (-2 + -2). Check -4. (**********************************************************************) +(* Check ill-formed recursive notations *) + +(* Recursive variables not part of a recursive pattern *) +Fail Notation "( x , y , .. , z )" := (pair x .. (pair y z) ..). + +(* No recursive notation *) +Fail Notation "( x , y , .. , z )" := (pair x (pair y z)). + +(* Left-unbound variable *) +Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..). + +(* Right-unbound variable *) +Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..). + +(* Not the right kind of recursive pattern *) +Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)). +Fail Notation "( x -- y , .. , z )" := (pair y .. (pair z 0) ..) + (y closed binder, z closed binder). + +(* No separator allowed with open binders *) +Fail Notation "( x -- y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)) + (y binder, z binder). + +(* Ends of pattern do not match *) +Fail Notation "( x , y , .. , z )" := (pair y .. (pair (plus z) 0) ..). +Fail Notation "( x , y , .. , z )" := (pair y .. (plus z 0) ..). +Fail Notation "( x1 , x2 , y , .. , z )" := (y y .. (x2 z 0) ..). +Fail Notation "( x1 , x2 , y , .. , z )" := (x1 y .. (x2 z 0) ..). + +(* Ends of pattern are the same *) +Fail Notation "( x , y , .. , z )" := (pair .. (pair (pair y z) x) .. x). + +(**********************************************************************) (* Check preservation of scopes at printing time *) Notation SUM := sum. @@ -163,6 +196,12 @@ Notation "[| x , y , .. , z ; a , b , .. , c |]" := (pair (pair .. (pair x y) .. z) (pair .. (pair a b) .. c)). Check [|1,2,3;4,5,6|]. +Notation "[| t * ( x , y , .. , z ) ; ( a , b , .. , c ) * u |]" := + (pair (pair .. (pair (pair t x) (pair t y)) .. (pair t z)) + (pair .. (pair (pair a u) (pair b u)) .. (pair c u))) + (t at level 39). +Check [|0*(1,2,3);(4,5,6)*false|]. + (**********************************************************************) (* Test recursive notations involving applications *) (* Caveat: does not work for applied constant because constants are *) diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index 20d20d82..6731d505 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -10,3 +10,18 @@ end : nat let '(a, _, _) := (2, 3, 4) in a : nat +∃ n p : nat, n + p = 0 + : Prop +∀ n p : nat, n + p = 0 + : Prop +λ n p : nat, n + p = 0 + : nat -> nat -> Prop +λ (A : Type) (n p : A), n = p + : ∀ A : Type, A -> A -> Prop +λ A : Type, ∃ n p : A, n = p + : Type -> Prop +λ A : Type, ∀ n p : A, n = p + : Type -> Prop +Defining 'let'' as keyword +let' f (x y z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2 + : bool -> nat diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index 2e136edf..57d8ebbc 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -24,3 +24,44 @@ Check forall (A: Set) (le: A -> A -> Prop) (x y: A), le x y \/ le y x. Remove Printing Let prod. Check match (0,0,0) with (x,y,z) => x+y+z end. Check let '(a,b,c) := ((2,3),4) in a. + +(* Test notations with binders *) + +Notation "∃ x .. y , P":= + (ex (fun x => .. (ex (fun y => P)) ..)) (x binder, y binder, at level 200). + +Check (∃ n p, n+p=0). + +Notation "∀ x .. y , P":= (forall x, .. (forall y, P) ..) + (x binder, at level 200, right associativity). + +Check (∀ n p, n+p=0). + +Notation "'λ' x .. y , P":= (fun x, .. (fun y, P) ..) + (y binder, at level 200, right associativity). + +Check (λ n p, n+p=0). + +Generalizable Variable A. + +Check `(λ n p : A, n=p). +Check `(∃ n p : A, n=p). +Check `(∀ n p : A, n=p). + +Notation "'let'' f x .. y := t 'in' u":= + (let f := fun x => .. (fun y => t) .. in u) + (f ident, x closed binder, y closed binder, at level 200, + right associativity). + +Check let' f x y z (a:bool) := x+y+z+1 in f 0 1 2. + +(* This one is not fully satisfactory because binders in the same type + are re-factorized and parentheses are needed even for atomic binder + +Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":= + (let f := fun x => .. (fun y => t) .. in u) + (f ident, x closed binder, y closed binder, at level 200, + right associativity). + +Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. +*) diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 99e736dd..154d9cdd 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -2,29 +2,11 @@ le_S: forall n m : nat, n <= m -> n <= S m le_n: forall n : nat, n <= n false: bool true: bool -sumor_beq: - forall (A : Type) (B : Prop), - (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool -sumbool_beq: - forall A B : Prop, - (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool xorb: bool -> bool -> bool -sum_beq: - forall A B : Type, - (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool -prod_beq: - forall A B : Type, - (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool orb: bool -> bool -> bool -option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool negb: bool -> bool -nat_beq: nat -> nat -> bool -list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool implb: bool -> bool -> bool -comparison_beq: comparison -> comparison -> bool -bool_beq: bool -> bool -> bool andb: bool -> bool -> bool -Empty_set_beq: Empty_set -> Empty_set -> bool pred_Sn: forall n : nat, n = pred (S n) plus_n_Sm: forall n m : nat, S (n + m) = n + S m plus_n_O: forall n : nat, n = n + 0 diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 1a87f4cc..c87eaadc 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -1,28 +1,10 @@ false: bool true: bool -sumor_beq: - forall (A : Type) (B : Prop), - (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool -sumbool_beq: - forall A B : Prop, - (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool xorb: bool -> bool -> bool -sum_beq: - forall A B : Type, - (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool -prod_beq: - forall A B : Type, - (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool orb: bool -> bool -> bool -option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool negb: bool -> bool -nat_beq: nat -> nat -> bool -list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool implb: bool -> bool -> bool -comparison_beq: comparison -> comparison -> bool -bool_beq: bool -> bool -> bool andb: bool -> bool -> bool -Empty_set_beq: Empty_set -> Empty_set -> bool S: nat -> nat O: nat pred: nat -> nat diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v index b5fba17b..cb90e742 100644 --- a/test-suite/success/Field.v +++ b/test-suite/success/Field.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Field.v 13323 2010-07-24 15:57:30Z herbelin $ *) (**** Tests of Field with real numbers ****) diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v index fde9f470..518d22e9 100644 --- a/test-suite/success/Nsatz.v +++ b/test-suite/success/Nsatz.v @@ -1,4 +1,74 @@ -Require Import NsatzR ZArith Reals List Ring_polynom. +Require Import Nsatz ZArith Reals List Ring_polynom. + +(* Example with a generic domain *) + +Variable A: Type. +Variable Ad: Domain A. + +Definition Ari : Ring A:= (@domain_ring A Ad). +Existing Instance Ari. + +Existing Instance ring_setoid. +Existing Instance ring_plus_comp. +Existing Instance ring_mult_comp. +Existing Instance ring_sub_comp. +Existing Instance ring_opp_comp. + +Add Ring Ar: (@ring_ring A (@domain_ring A Ad)). + +Instance zero_ring2 : Zero A := {zero := ring0}. +Instance one_ring2 : One A := {one := ring1}. +Instance addition_ring2 : Addition A := {addition x y := ring_plus x y}. +Instance multiplication_ring2 : Multiplication A := {multiplication x y := ring_mult x y}. +Instance subtraction_ring2 : Subtraction A := {subtraction x y := ring_sub x y}. +Instance opposite_ring2 : Opposite A := {opposite x := ring_opp x}. + +Infix "==" := ring_eq (at level 70, no associativity). + +Ltac nsatzA := simpl; unfold Ari; nsatz_domain. + +Goal forall x y:A, x == y -> x+0 == y*1+0. +nsatzA. +Qed. + +Lemma example3 : forall x y z, + x+y+z==0 -> + x*y+x*z+y*z==0-> + x*y*z==0 -> x*x*x==0. +Proof. +Time nsatzA. +Admitted. + +Lemma example4 : forall x y z u, + x+y+z+u==0 -> + x*y+x*z+x*u+y*z+y*u+z*u==0-> + x*y*z+x*y*u+x*z*u+y*z*u==0-> + x*y*z*u==0 -> x*x*x*x==0. +Proof. +Time nsatzA. +Qed. + +Lemma example5 : forall x y z u v, + x+y+z+u+v==0 -> + x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0-> + x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0-> + x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 -> + x*y*z*u*v==0 -> x*x*x*x*x ==0. +Proof. +Time nsatzA. +Qed. + +Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z. +nsatz. +Qed. + +Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R. +nsatz. +Qed. + +Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R. +nsatz. +Qed. Section Examples. @@ -16,12 +86,12 @@ Lemma example1 : forall x y, x*y=0 -> x^2=0. Proof. - nsatzR. + nsatz. Qed. Lemma example2 : forall x, x^2=0 -> x=0. Proof. - nsatzR. + nsatz. Qed. (* @@ -29,12 +99,12 @@ Notation X := (PEX Z 3). Notation Y := (PEX Z 2). Notation Z_ := (PEX Z 1). *) -Lemma example3 : forall x y z, +Lemma example3b : forall x y z, x+y+z=0 -> x*y+x*z+y*z=0-> x*y*z=0 -> x^3=0. Proof. -Time nsatzR. +Time nsatz. Qed. (* @@ -43,13 +113,13 @@ Notation Y := (PEX Z 3). Notation Z_ := (PEX Z 2). Notation U := (PEX Z 1). *) -Lemma example4 : forall x y z u, +Lemma example4b : forall x y z u, x+y+z+u=0 -> x*y+x*z+x*u+y*z+y*u+z*u=0-> x*y*z+x*y*u+x*z*u+y*z*u=0-> x*y*z*u=0 -> x^4=0. Proof. -Time nsatzR. +Time nsatz. Qed. (* @@ -64,20 +134,20 @@ Notation "x :: y" := (List.app x y) (at level 60, right associativity, format "x :: y"). *) -Lemma example5 : forall x y z u v, +Lemma example5b : forall x y z u v, x+y+z+u+v=0 -> x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0-> x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0-> x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 -> x*y*z*u*v=0 -> x^5=0. Proof. -Time nsatzR. +Time nsatz. Qed. End Examples. Section Geometry. -Require Export Reals NsatzR. + Open Scope R_scope. Record point:Type:={ @@ -169,6 +239,7 @@ Ltac geo_begin:= (* Examples *) + Lemma Thales: forall O A B C D:point, collinear O A C -> collinear O B D -> parallel A B C D -> @@ -176,26 +247,7 @@ Lemma Thales: forall O A B C D:point, /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B) \/ collinear O A B. repeat geo_begin. -(* Time nsatz. -*) -Time nsatz without sugar. -(* -Time nsatz with lexico sugar. -Time nsatz with lexico. -*) -(* -Time nsatzRpv 1%N 1%Z (@nil R) (@nil R). (* revlex, sugar, no div *) -(*Finished transaction in 1. secs (0.479927u,0.s)*) -Time nsatzRpv 1%N 0%Z (@nil R) (@nil R). (* revlex, no sugar, no div *) -(*Finished transaction in 0. secs (0.543917u,0.s)*) -Time nsatzRpv 1%N 2%Z (@nil R) (@nil R). (* lex, no sugar, no div *) -(*Finished transaction in 0. secs (0.586911u,0.s)*) -Time nsatzRpv 1%N 3%Z (@nil R) (@nil R). (* lex, sugar, no div *) -(*Finished transaction in 0. secs (0.481927u,0.s)*) -Time nsatzRpv 1%N 5%Z (@nil R) (@nil R). (* revlex, sugar, div *) -(*Finished transaction in 1. secs (0.601909u,0.s)*) -*) Time nsatz. Qed. @@ -209,8 +261,26 @@ Lemma hauteurs:forall A B C A1 B1 C1 H:point, \/ collinear A B C. geo_begin. -Time nsatz. -(*Finished transaction in 3. secs (2.43263u,0.010998s)*) + +(* Time nsatzRpv 2%N 1%Z (@nil R) (@nil R).*) +(*Finished transaction in 3. secs (2.363641u,0.s)*) +(*Time nsatz_domainR. trop long! *) +Time + let lv := constr:(Y A1 + :: X A1 + :: Y B1 + :: X B1 + :: Y A0 + :: Y B + :: X B + :: X A0 + :: X H + :: Y C + :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in + nsatz_domainpv ltac:pretacR 2%N 1%Z (@Datatypes.nil R) lv ltac:simplR Rdi; + discrR. +(* Finished transaction in 6. secs (5.579152u,0.001s) *) Qed. End Geometry. + diff --git a/test-suite/success/Nsatz_domain.v b/test-suite/success/Nsatz_domain.v deleted file mode 100644 index 8a30b47f..00000000 --- a/test-suite/success/Nsatz_domain.v +++ /dev/null @@ -1,274 +0,0 @@ -Require Import Nsatz_domain ZArith Reals List Ring_polynom. - -Variable A: Type. -Variable Ad: Domain A. - -Add Ring Ar1: (@ring_ring A (@domain_ring _ Ad)). - -Instance Ari : Ring A := { - ring0 := @ring0 A (@domain_ring _ Ad); - ring1 := @ring1 A (@domain_ring _ Ad); - ring_plus := @ring_plus A (@domain_ring _ Ad); - ring_mult := @ring_mult A (@domain_ring _ Ad); - ring_sub := @ring_sub A (@domain_ring _ Ad); - ring_opp := @ring_opp A (@domain_ring _ Ad); - ring_ring := @ring_ring A (@domain_ring _ Ad)}. - -Instance Adi : Domain A := { - domain_ring := Ari; - domain_axiom_product := @domain_axiom_product A Ad; - domain_axiom_one_zero := @domain_axiom_one_zero A Ad}. - -Instance zero_ring2 : Zero A := {zero := ring0}. -Instance one_ring2 : One A := {one := ring1}. -Instance addition_ring2 : Addition A := {addition x y := ring_plus x y}. -Instance multiplication_ring2 : Multiplication A := {multiplication x y := ring_mult x y}. -Instance subtraction_ring2 : Subtraction A := {subtraction x y := ring_sub x y}. -Instance opposite_ring2 : Opposite A := {opposite x := ring_opp x}. - -Goal forall x y:A, x = y -> x+0 = y*1+0. -nsatz_domain. -Qed. - -Goal forall a b c:A, a = b -> b = c -> c = a. -nsatz_domain. -Qed. - -Goal forall a b c:A, a = b -> b = c -> a = c. -nsatz_domain. -Qed. - -Goal forall a b c x:A, a = b -> b = c -> a*a = c*c. -nsatz_domain. -Qed. - -Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z. -nsatz_domainZ. -Qed. - -Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R. -nsatz_domainR. -Qed. - -Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R. -nsatz_domainR. -Qed. - -Section Examples. - -Delimit Scope PE_scope with PE. -Infix "+" := PEadd : PE_scope. -Infix "*" := PEmul : PE_scope. -Infix "-" := PEsub : PE_scope. -Infix "^" := PEpow : PE_scope. -Notation "[ n ]" := (@PEc Z n) (at level 0). - -Open Scope R_scope. - -Lemma example1 : forall x y, - x+y=0 -> - x*y=0 -> - x^2=0. -Proof. - nsatz_domainR. -Qed. - -Lemma example2 : forall x, x^2=0 -> x=0. -Proof. - nsatz_domainR. -Qed. - -(* -Notation X := (PEX Z 3). -Notation Y := (PEX Z 2). -Notation Z_ := (PEX Z 1). -*) -Lemma example3 : forall x y z, - x+y+z=0 -> - x*y+x*z+y*z=0-> - x*y*z=0 -> x^3=0. -Proof. -Time nsatz_domainR. -simpl. -discrR. -Qed. - -(* -Notation X := (PEX Z 4). -Notation Y := (PEX Z 3). -Notation Z_ := (PEX Z 2). -Notation U := (PEX Z 1). -*) -Lemma example4 : forall x y z u, - x+y+z+u=0 -> - x*y+x*z+x*u+y*z+y*u+z*u=0-> - x*y*z+x*y*u+x*z*u+y*z*u=0-> - x*y*z*u=0 -> x^4=0. -Proof. -Time nsatz_domainR. -Qed. - -(* -Notation x_ := (PEX Z 5). -Notation y_ := (PEX Z 4). -Notation z_ := (PEX Z 3). -Notation u_ := (PEX Z 2). -Notation v_ := (PEX Z 1). -Notation "x :: y" := (List.cons x y) -(at level 60, right associativity, format "'[hv' x :: '/' y ']'"). -Notation "x :: y" := (List.app x y) -(at level 60, right associativity, format "x :: y"). -*) - -Lemma example5 : forall x y z u v, - x+y+z+u+v=0 -> - x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0-> - x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0-> - x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 -> - x*y*z*u*v=0 -> x^5=0. -Proof. -Time nsatz_domainR. -Qed. - -End Examples. - -Section Geometry. - -Open Scope R_scope. - -Record point:Type:={ - X:R; - Y:R}. - -Definition collinear(A B C:point):= - (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0. - -Definition parallel (A B C D:point):= - ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)). - -Definition notparallel (A B C D:point)(x:R):= - x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1. - -Definition orthogonal (A B C D:point):= - ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0. - -Definition equal2(A B:point):= - (X A)=(X B) /\ (Y A)=(Y B). - -Definition equal3(A B:point):= - ((X A)-(X B))^2+((Y A)-(Y B))^2 = 0. - -Definition nequal2(A B:point):= - (X A)<>(X B) \/ (Y A)<>(Y B). - -Definition nequal3(A B:point):= - not (((X A)-(X B))^2+((Y A)-(Y B))^2 = 0). - -Definition middle(A B I:point):= - 2*(X I)=(X A)+(X B) /\ 2*(Y I)=(Y A)+(Y B). - -Definition distance2(A B:point):= - (X B - X A)^2 + (Y B - Y A)^2. - -(* AB = CD *) -Definition samedistance2(A B C D:point):= - (X B - X A)^2 + (Y B - Y A)^2 = (X D - X C)^2 + (Y D - Y C)^2. -Definition determinant(A O B:point):= - (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O). -Definition scalarproduct(A O B:point):= - (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O). -Definition norm2(A O B:point):= - ((X A - X O)^2+(Y A - Y O)^2)*((X B - X O)^2+(Y B - Y O)^2). - - -Lemma a1:forall A B C:Prop, ((A\/B)/\(A\/C)) -> (A\/(B/\C)). -intuition. -Qed. - -Lemma a2:forall A B C:Prop, ((A\/C)/\(B\/C)) -> ((A/\B)\/C). -intuition. -Qed. - -Lemma a3:forall a b c d:R, (a-b)*(c-d)=0 -> (a=b \/ c=d). -intros. -assert ( (a-b = 0) \/ (c-d = 0)). -apply Rmult_integral. -trivial. -destruct H0. -left; nsatz_domainR. -right; nsatz_domainR. -Qed. - -Ltac geo_unfold := - unfold collinear; unfold parallel; unfold notparallel; unfold orthogonal; - unfold equal2; unfold equal3; unfold nequal2; unfold nequal3; - unfold middle; unfold samedistance2; - unfold determinant; unfold scalarproduct; unfold norm2; unfold distance2. - -Ltac geo_end := - repeat ( - repeat (match goal with h:_/\_ |- _ => decompose [and] h; clear h end); - repeat (apply a1 || apply a2 || apply a3); - repeat split). - -Ltac geo_rewrite_hyps:= - repeat (match goal with - | h:X _ = _ |- _ => rewrite h in *; clear h - | h:Y _ = _ |- _ => rewrite h in *; clear h - end). - -Ltac geo_begin:= - geo_unfold; - intros; - geo_rewrite_hyps; - geo_end. - -(* Examples *) - -Lemma Thales: forall O A B C D:point, - collinear O A C -> collinear O B D -> - parallel A B C D -> - (distance2 O B * distance2 O C = distance2 O D * distance2 O A - /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B) - \/ collinear O A B. -repeat geo_begin. - -Time nsatz_domainR. -simpl;discrR. -Time nsatz_domainR. -simpl;discrR. -Qed. - -Require Import NsatzR. - -Lemma hauteurs:forall A B C A1 B1 C1 H:point, - collinear B C A1 -> orthogonal A A1 B C -> - collinear A C B1 -> orthogonal B B1 A C -> - collinear A B C1 -> orthogonal C C1 A B -> - collinear A A1 H -> collinear B B1 H -> - - collinear C C1 H - \/ collinear A B C. - -geo_begin. -(* Time nsatzRpv 2%N 1%Z (@nil R) (@nil R).*) -(*Finished transaction in 3. secs (2.363641u,0.s)*) -(*Time nsatz_domainR. trop long! *) -(* en fait nsatz_domain ne tient pas encore compte de la liste des variables! ;-) *) -Time - let lv := constr:(Y A1 - :: X A1 - :: Y B1 - :: X B1 - :: Y A0 - :: Y B - :: X B - :: X A0 - :: X H - :: Y C - :: Y C1 :: Y H :: X C1 :: X C ::nil) in - nsatz_domainpv 2%N 1%Z (@List.nil R) lv ltac:simplR Rdi. -(* Finished transaction in 6. secs (5.579152u,0.001s) *) -Qed. - -End Geometry. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v index b9326c64..6322ed2b 100644 --- a/test-suite/success/Tauto.v +++ b/test-suite/success/Tauto.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Tauto.v 13323 2010-07-24 15:57:30Z herbelin $ *) (**** Tactics Tauto and Intuition ****) diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 55351a47..30a2a742 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -8,9 +8,9 @@ Reserved Notation "x >>= y" (at level 65, left associativity). Record Monad {m : Type -> Type} := { - unit : Î {α}, α -> m α where "'return' t" := (unit t) ; - bind : Î {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ; - bind_unit_left : Î {α β} (a : α) (f : α -> m β), return a >>= f = f a }. + unit : forall {α}, α -> m α where "'return' t" := (unit t) ; + bind : forall {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ; + bind_unit_left : forall {α β} (a : α) (f : α -> m β), return a >>= f = f a }. Print Visibility. Print unit. diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 3cf607d9..0f5ef9d0 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Arith.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Arith_base. Require Export ArithRing. diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index e975f273..c5135f63 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Arith_base.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Le. Require Export Lt. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 8ab49f25..2ccf802d 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Between.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Le. Require Import Lt. diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index 5904e989..9ace38b1 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Bool_nat.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Compare_dec. Require Export Peano_dec. diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v index cdba76eb..2775d132 100644 --- a/theories/Arith/Compare.v +++ b/theories/Arith/Compare.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Compare.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Equality is decidable on [nat] *) diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 5d20261c..0811fea7 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Compare_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Le. Require Import Lt. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 0a3b7dcc..adbca442 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Div2.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Lt. Require Import Plus. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index edf31c62..e49e5d14 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: EqNat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Equality on natural numbers *) diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index 78185715..54f4f013 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Euclid.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Mult. Require Import Compare_dec. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 266d51fc..527ad748 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Even.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index aa8bb7bd..5385bf61 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Factorial.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Plus. Require Import Mult. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index bcf38c02..eda051df 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Gt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as: << diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index a8b86ab7..f24667d0 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Le.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Order on natural numbers. [le] is defined in [Init/Peano.v] as: << diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 68ac6e73..0032741e 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Lt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as: << diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 3a566321..b4c4d7ad 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Max.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index f646c80a..81142249 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Min.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 74d2c9a8..39062348 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Minus.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as: << diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index bfefb967..3ba98472 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Mult.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Plus. Require Export Minus. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 5eb86168..908f99f0 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Peano_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Decidable. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 2ea65696..3c5f28b6 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Plus.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Properties of addition. [add] is defined in [Init/Peano.v] as: << diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index a42c38eb..07ab1c3e 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Wf_nat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Well-founded relations and natural numbers *) diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 43ffde86..8f3c29c6 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Bool.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** The type [bool] is defined in the prelude as [Inductive bool : Set := true : bool | false : bool] *) diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index 2c3952e7..9a006e80 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BoolEq.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Cuihtlauac Alvarado - octobre 2000 *) (** Properties of a boolean equality *) diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 5190a246..3f3acccf 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Bvector.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index 746507c4..f3123a7a 100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DecBool.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 2d0f15a1..dcab1446 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: IfProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Bool. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 7945fbae..543ff67d 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Sumbool.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Here are collected some results about the type sumbool (see INIT/Specif.v) [sumbool A B], which is written [{A}+{B}], is the informative diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index 1c6b84ce..a89138d1 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zerob.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Arith. Require Import Bool. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 5748a5f3..cc6e8936 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -12,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: EquivDec.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Export notations. *) diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 65231ce1..3d8c3434 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -12,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: Equivalence.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 6e576c96..8cc1216b 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -13,7 +13,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: Init.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Hints for the proof search: these combinators should be considered rigid. *) diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 9895c5a4..d31829e1 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -13,7 +13,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: Morphisms.v 13359 2010-07-30 08:46:55Z herbelin $ *) Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. @@ -23,6 +23,12 @@ Require Export Coq.Classes.RelationClasses. Generalizable All Variables. Local Obligation Tactic := simpl_relation. +Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) + (at level 200, x binder, y binder, right associativity). + +Local Notation "'Î ' x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + (** * Morphisms. We now turn to the definition of [Proper] and declare standard instances. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 89c23b3e..1aad3cec 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -15,7 +15,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: RelationClasses.v 13344 2010-07-28 15:04:36Z msozeau $ *) Require Export Coq.Classes.Init. Require Import Coq.Program.Basics. @@ -76,7 +76,7 @@ Hint Extern 4 => solve_relation : relations. Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. -Program Lemma flip_Reflexive `(Reflexive A R) : Reflexive (flip R). +Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R). Proof. tauto. Qed. Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index ff91bd91..b20f9d88 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -12,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: SetoidClass.v 13323 2010-07-24 15:57:30Z herbelin $ *) Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 6e92a5de..fe775abb 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -13,13 +13,16 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: SetoidDec.v 13359 2010-07-30 08:46:55Z herbelin $ *) Set Implicit Arguments. Unset Strict Implicit. Generalizable Variables A B . +Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) + (at level 200, x binder, y binder, right associativity). + (** Export notations. *) Require Export Coq.Classes.SetoidClass. diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index fd3b9f3b..0d43de5a 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -12,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id$ *) +(* $Id: SetoidTactics.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop. Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8158324e..7b64ded7 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -8,7 +8,7 @@ (* Finite map library. *) -(* $Id$ *) +(* $Id: FMapAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *) (** * FMapAVL *) diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 4c59971c..8944f7ce 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMapFacts.v 12459 2009-11-02 18:51:43Z letouzey $ *) (** * Finite maps library *) diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index e4f8b4df..2b9e7077 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -8,7 +8,7 @@ (* Finite map library. *) -(* $Id$ *) +(* $Id: FMapFullAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *) (** * FMapFullAVL diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index e60cca9d..bbfecfb1 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMapInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *) (** * Finite map library *) diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 56fc35d8..4b7f183c 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMapList.v 12458 2009-11-02 18:50:33Z letouzey $ *) (** * Finite map library *) diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 7c5a4fa1..30bce2db 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMapPositive.v 13297 2010-07-19 23:32:42Z letouzey $ *) (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 38ed172b..db479ea8 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMapWeakList.v 12458 2009-11-02 18:50:33Z letouzey $ *) (** * Finite map library *) diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v index 6b110240..75904202 100644 --- a/theories/FSets/FMaps.v +++ b/theories/FSets/FMaps.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *) Require Export OrderedType OrderedTypeEx OrderedTypeAlt. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index bc6c731f..2cbba723 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetAVL.v 12641 2010-01-07 15:32:52Z letouzey $ *) (** * FSetAVL : Implementation of FSetInterface via AVL trees *) diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 7f8c51d6..c2d921be 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetBridge.v 13253 2010-07-07 08:39:30Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index b7d6382e..497f4e6d 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetDecide.v 13171 2010-06-18 21:45:40Z letouzey $ *) (**************************************************************) (* FSetDecide.v *) diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index ec0c6a55..ac55aef5 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetEqProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index b750edfc..45b43d83 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetFacts.v 12461 2009-11-03 08:24:06Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 8aede552..f366ed3e 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *) (** * Finite set library *) diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index f83259c4..9408ba05 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetList.v 12641 2010-01-07 15:32:52Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 84c26dac..59e19cd3 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 01138270..2aa1b433 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetToFiniteSet.v 12363 2009-09-28 15:04:07Z letouzey $ *) (** * Finite sets library : conversion to old [Finite_sets] *) diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 711cbd9a..b55db37a 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSetWeakList.v 12641 2010-01-07 15:32:52Z letouzey $ *) (** * Finite sets library *) diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index 62a95734..a725c1eb 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: FSets.v 13297 2010-07-19 23:32:42Z letouzey $ *) Require Export OrderedType. Require Export OrderedTypeEx. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 62e0d398..7f2ea63d 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Datatypes.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 16c32b35..4c9bd919 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Logic.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index d002c967..b9ea3095 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Logic_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This module defines type constructors for types in [Type] ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *) diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index e8a11952..0eba44b3 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Notations.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** These are the notations whose level and associativity are imposed by Coq *) diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index e86939c8..a6f94752 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Peano.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index d7625147..63d53560 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Prelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Notations. Require Export Logic. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 26c0194e..436a7957 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Specif.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Basic specifications : sets that may contain logical information *) diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 3a845e6a..58920228 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Tactics.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Notations. Require Import Logic. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index a7887913..be7becda 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Wf.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** * This module proves the validity of - well-founded recursion (also known as course of values) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index bc55ef02..c4957578 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: List.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Le Gt Minus Min Bool. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 9978f5bc..2833ca3e 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ListSet.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** A Library for finite sets, implemented as lists *) diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index c7d37dd9..5de2780a 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ListTactics.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinPos. Require Import List. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index d42e71e5..ec31f37d 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: SetoidList.v 12919 2010-04-10 16:30:44Z herbelin $ *) Require Export List. Require Export Sorting. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index feb8c654..e07347a0 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Streams.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v index bb5c7b17..aa1b099b 100644 --- a/theories/Lists/TheoryList.v +++ b/theories/Lists/TheoryList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: TheoryList.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Some programs and results about lists following CAML Manual *) diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 7d9fb802..c4c8bbe2 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Berardi.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file formalizes Berardi's paradox which says that in the calculus of constructions, excluded middle (EM) and axiom of diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 959670cb..34ebc329 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ChoiceFacts.v 12363 2009-09-28 15:04:07Z letouzey $ i*) +(*i $Id: ChoiceFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Some facts and definitions concerning choice and description in intuitionistic logic. diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index b2cca5c2..d6c79882 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Classical Logic *) diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index 50ce871b..08a34bc8 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ClassicalChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides classical logic and functional choice; this especially provides both indefinite descriptions and choice functions diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index 793c6ab7..f9896669 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ClassicalDescription.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides classical logic and definite description, which is equivalent to providing classical logic and Church's iota operator *) diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 53989d07..c45bc052 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ClassicalEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides classical logic and indefinite description under the form of Hilbert's epsilon operator *) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index c5822bac..cd885592 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ClassicalFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Some facts and definitions about classical logic diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 6c1c68cf..ea0898d4 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ClassicalUniqueChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides classical logic and unique choice; this is weaker than providing iota operator and classical logic as the diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v index 3f30abe5..b95373e5 100644 --- a/theories/Logic/Classical_Pred_Set.v +++ b/theories/Logic/Classical_Pred_Set.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical_Pred_Set.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file is obsolete, use Classical_Pred_Type.v via Classical.v instead *) diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 638c58d2..32f0a6ac 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical_Pred_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Classical Predicate Logic on Type *) diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index 91392ca6..77715ce3 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical_Prop.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Classical Propositional Logic *) diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v index 2f5c9726..2319638f 100644 --- a/theories/Logic/Classical_Type.v +++ b/theories/Logic/Classical_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file is obsolete, use Classical.v instead *) diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 90aa0f30..738ca1d5 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ConstructiveEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*) -(*i $Id: ConstructiveEpsilon.v 12112 2009-04-28 15:47:34Z herbelin $ i*) +(*i $Id: ConstructiveEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This module proves the constructive description schema, which infers the sigma-existence (i.e., [Set]-existence) of a witness to a diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index df9acbcc..ac4f686b 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Decidable.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Properties of decidable propositions *) diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index c569dc46..deedf35b 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Description.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides a constructive form of definite description; it allows to build functions from the proof of their existence in any diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 4c4785cf..ff640af7 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Diaconescu.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index 9cea8dfd..4ec0c83d 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Epsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides indefinite description under the form of Hilbert's epsilon operator; it does not assume classical logic. *) diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index ed9d1a9f..53b19ff6 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Eqdep.v 13332 2010-07-26 22:12:43Z msozeau $ i*) (** This file axiomatizes the invariance by substitution of reflexive equality proofs [[Streicher93]] and exports its consequences, such @@ -31,5 +31,5 @@ Export EqdepTheory. (** Exported hints *) -Hint Resolve eq_dep_eq: core v62. -Hint Resolve inj_pair2 inj_pairT2: core. +Hint Resolve eq_dep_eq: eqdep v62. +Hint Resolve inj_pair2 inj_pairT2: eqdep. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 15a36dd4..3e49c759 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: EqdepFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file defines dependent equality and shows its equivalence with equality on dependent pairs (inhabiting sigma-types). It derives diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 0ad7e909..c45643e4 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Eqdep_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** We prove that there is only one proof of [x=x], i.e [refl_equal x]. This holds if the equality upon the set of [x] is decidable. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 5e9953d4..4def8910 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: FunctionalExtensionality.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion. It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *) diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 05c04952..e0537238 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: IndefiniteDescription.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file provides a constructive form of indefinite description that allows to build choice functions; this is weaker than Hilbert's diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 06903c3b..3de77074 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: JMeq.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** John Major's Equality as proposed by Conor McBride diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 85da26b3..e0a10d46 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: RelationalChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file axiomatizes the relational form of the axiom of choice *) diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 332e2104..e44b39f5 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BinNat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinPos. Unset Boxed Definitions. diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v index 9cfb8893..a8f78df0 100644 --- a/theories/NArith/BinPos.v +++ b/theories/NArith/BinPos.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BinPos.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Unset Boxed Definitions. diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index 9b659750..9d2424bc 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: NArith.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Library for binary natural numbers *) diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index dbea23e3..d6b1e718 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ndec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index e21f1976..5151236f 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ndigits.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Bool. Require Import Bvector. diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v index bbf38794..0e920242 100644 --- a/theories/NArith/Ndist.v +++ b/theories/NArith/Ndist.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ndist.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Arith. Require Import Min. diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index dec7e927..49bbf7b7 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Nnat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Arith_base. Require Import Compare_dec. diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v index 9f995502..1952470d 100644 --- a/theories/NArith/Pnat.v +++ b/theories/NArith/Pnat.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Pnat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinPos. diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index 356cbb26..97b6b077 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BigNumPrelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** * BigNumPrelude *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 669dc741..29186694 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(* $Id$ *) +(* $Id: CyclicAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** * Signature and specification of a bounded integer structure *) diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 3636ebec..e5bc043d 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZCyclic.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NZAxioms. Require Import BigNumPrelude. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index 868b7247..f49201d8 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v index a7985c4f..ba2a1770 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index cbac8723..4a60a10b 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleCyclic.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 48750fa7..5ddadd12 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleDiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index f241cc54..3ada7d40 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleDivn1.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v index 26af1cc8..3989791c 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleLift.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v index fafb7d1d..7ddb0468 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index 4c93d758..d468318d 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleSqrt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v index 7ecec835..7cb97f28 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleSub.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v index dde0c142..e9955c6d 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DoubleType.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Set Implicit Arguments. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index f581657e..8ec359a0 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Cyclic31.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 3c72b785..2485c353 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Int31.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NaryFunctions. Require Import Wf_nat. diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index ff55bc51..2864c81f 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ring31.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped with a ring structure and a ring tactic *) diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index ced812e2..bebc67a0 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ZModulo.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] as defined abstractly in CyclicAxioms. *) diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index 71ca5e11..f120f881 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZBase. diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index 96213eab..2d607010 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZLt. diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v index 13d32304..c52fe299 100644 --- a/theories/Numbers/Integer/Abstract/ZAxioms.v +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NZAxioms. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 244eb92c..a42e8230 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Decidable. Require Export ZAxioms. diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v index 14f2ef62..2e019a57 100644 --- a/theories/Numbers/Integer/Abstract/ZLt.v +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZLt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZMul. diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v index 5856c6d9..5be20268 100644 --- a/theories/Numbers/Integer/Abstract/ZMul.v +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZAdd. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index 69b9c986..d5ec8005 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZAddOrder. diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v index 7cc064d9..09ece42a 100644 --- a/theories/Numbers/Integer/Abstract/ZProperties.v +++ b/theories/Numbers/Integer/Abstract/ZProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZAxioms ZMulOrder ZSgnAbs. diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index 180081d9..7f9e2d91 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BigZ.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export BigN. Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake. diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index 70fe97d9..c61e198d 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZMake.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith. Require Import BigNumPrelude. diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v index a904cdba..9c8f80c9 100644 --- a/theories/Numbers/Integer/Binary/ZBinary.v +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZBinary.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZAxioms ZProperties. diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 45c5db77..830e1ad7 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZNatPairs.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NProperties. (* The most complete file for N *) Require Export ZProperties. (* The most complete file for Z *) diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v index b2c23685..957e1c70 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith Znumtheory. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v index bb8d543e..142e613b 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZSigZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith ZAxioms ZDivFloor ZSig. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 83487d22..b0aad5b5 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -8,7 +8,7 @@ (* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NaryFunctions.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Local Open Scope type_scope. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index ee73a22a..6f1b879c 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms NZBase. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index ca359346..7c06226f 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms NZBase NZMul NZOrder. diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v index bb13d051..389f4eb2 100644 --- a/theories/Numbers/NatInt/NZAxioms.v +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -8,7 +8,7 @@ (** Initial Author : Evgeny Makarov, INRIA, 2007 *) -(*i $Id$ i*) +(*i $Id: NZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Equalities Orders NumPrelude GenericMinMax. diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index f83af8f0..b5df1669 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index d8e45ff5..af3e4861 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZDomain.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NumPrelude NZAxioms. Require Import NZBase NZOrder NZAddOrder Plus Minus. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 14981a22..b55f58cb 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms NZBase NZAdd. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 35922519..dee1a803 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms. Require Import NZAddOrder. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 3f00cd20..5d7bb701 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NZAxioms NZBase Decidable OrdersTac. diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v index 7a7601bd..92dffed3 100644 --- a/theories/Numbers/NatInt/NZProperties.v +++ b/theories/Numbers/NatInt/NZProperties.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NZProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NZAxioms NZMulOrder. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 4ae8b393..305ccfd0 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NBase. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 729618ef..a4b8c759 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NOrder. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v index 309dff8f..1a7c436b 100644 --- a/theories/Numbers/Natural/Abstract/NAxioms.v +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NZAxioms. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index 48bdfabf..5f262a82 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Decidable. Require Export NAxioms. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index ca2b1b7e..238518ba 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NDefOps.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Bool. (* To get the orb and negb function *) Require Import RelationPairs. diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v index c3e5e27c..79516623 100644 --- a/theories/Numbers/Natural/Abstract/NIso.v +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NIso.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import NBase. diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v index 9471ac6c..2b00e893 100644 --- a/theories/Numbers/Natural/Abstract/NMulOrder.v +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NAddOrder. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 766facd5..cebf35a7 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NAdd. diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v index f20c352e..3269972d 100644 --- a/theories/Numbers/Natural/Abstract/NProperties.v +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NAxioms NSub. diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 86e1d93a..f5f47128 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NStrongRec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file defined the strong (course-of-value, well-founded) recursion and proves its properties *) diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index 8df327d6..8d16c516 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NSub.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NMulOrder. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 5bcf5e9a..8f6c59fd 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NMake_gen.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (*S NMake_gen.ml : this file generates NMake.v *) diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index 163712b6..a531b92e 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Nbasic.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith. Require Import BigNumPrelude. diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v index 1fae59eb..b83e5477 100644 --- a/theories/Numbers/Natural/Binary/NBinary.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NBinary.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinPos. Require Export BinNat. diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v index 5b468a90..4a5364fd 100644 --- a/theories/Numbers/Natural/Peano/NPeano.v +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NPeano.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Arith MinMax NAxioms NProperties. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index 6ccbd2f0..89111937 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith Znumtheory. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v index 73e7953f..2c35242a 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NSigNAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith Nnat NAxioms NDiv NSig. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index 69f6e24b..f923a53b 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NumPrelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Setoid Morphisms. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v index 0982226c..10d0c5f7 100644 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: QSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index f4017024..a298032f 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Basics.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Standard functions and combinators. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 39fb4093..e61c7027 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Combinators.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** * Proofs about standard combinators, exports functional extensionality. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 1e139497..2764d1b4 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Equality.v 13359 2010-07-30 08:46:55Z herbelin $ i*) (** Tactics related to (dependent) equality and proof irrelevance. *) @@ -15,6 +15,9 @@ Require Export JMeq. Require Import Coq.Program.Tactics. +Local Notation "'Î ' x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + Ltac is_ground_goal := match goal with |- ?T => is_ground T diff --git a/theories/Program/Program.v b/theories/Program/Program.v index 71be3478..929fc47c 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Program.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Export Coq.Program.Utils. Require Export Coq.Program.Wf. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index ce5f1068..9d82fde8 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Subset.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Tactics related to subsets and proof irrelevance. *) diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 05bf2ea6..0e6b2909 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Syntax.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Custom notations and implicits for Coq prelude definitions. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 91a8edff..333dd7a6 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Tactics.v 13332 2010-07-26 22:12:43Z msozeau $ i*) (** This module implements various tactics used to simplify the goals produced by Program, which are also generally useful. *) @@ -101,7 +101,7 @@ Ltac revert_last := [ H : _ |- _ ] => revert H end. -(** Reapeateadly reverse the last hypothesis, putting everything in the goal. *) +(** Repeatedly reverse the last hypothesis, putting everything in the goal. *) Ltac reverse := repeat revert_last. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index f2aad800..b2b5d4be 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Utils.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Various syntaxic shortands that are useful with [Program]. *) diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index d16e900f..4159f436 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Wf.v 13332 2010-07-26 22:12:43Z msozeau $ *) (** Reformulation of the Wf module using subsets where possible, providing the support for [Program]'s treatment of well-founded definitions. *) @@ -214,7 +214,7 @@ Ltac fold_sub f := match goal with | [ |- ?T ] => match T with - appcontext C [ @Fix_sub _ _ _ _ ?arg ] => + appcontext C [ @Fix_sub _ _ _ _ _ ?arg ] => let app := context C [ f arg ] in change app end @@ -251,6 +251,6 @@ Module WfExtensionality. Ltac unfold_sub f fargs := set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; - rewrite fix_sub_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. + rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig. End WfExtensionality. diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index 1b3ca6d6..c7f41de4 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: QArith.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export QArith_base. Require Export Qring. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 9540968d..6b33c254 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: QArith_base.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export ZArith. Require Export ZArithRing. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index eb1508b3..4a2347d7 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Qcanon.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Field. Require Import QArith. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 00500e31..0cf5413e 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Qfield.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Field. Require Export QArith_base. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 54682197..67bb0ffa 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Qreals.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Rbase. Require Export QArith_base. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 2fa2585d..456d305d 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Qreduction.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Normalisation functions for rational numbers. *) diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index 8943dc31..7f7a2d09 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Qring.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Qfield. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index dbee0b67..212eea7a 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Alembert.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index e17bf53d..de9f8827 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id$ i*) + (*i $Id: AltSeries.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index c0f7e830..84fa8fe1 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id$ i*) + (*i $Id: ArithProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rbasic_fun. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index 9e3ffa6d..ab352910 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id$ i*) + (*i $Id: Binomial.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index 713e2c04..279fd3d1 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id$ i*) + (*i $Id: Cauchy_prod.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 4e4c2b60..e3854afb 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id$ i*) + (*i $Id: Cos_plus.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 54332d83..99e39169 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Cos_rel.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 08b48898..66ee4eb0 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: DiscrR.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import RIneq. Require Import Omega. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 5d46ceae..57198a5e 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Exp_prop.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index 2062db7d..569e122a 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Integration.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export NewtonInt. Require Export RiemannInt_SF. diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v index a4bb5f72..1528ed64 100644 --- a/theories/Reals/LegacyRfield.v +++ b/theories/Reals/LegacyRfield.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: LegacyRfield.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Raxioms. Require Export LegacyField. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index d69e7ed5..87275e7f 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: MVT.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 8828c7eb..cfd5d561 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: NewtonInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index a459fe19..1e882b7a 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: PSeries_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index e658b900..b1c0c4f9 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: PartSum.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 55e14289..5c0cf3e7 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: RIneq.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) (** * Basic lemmas for the classical real numbers *) diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 36d04297..85ad4378 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: RList.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index cf7bdfef..946a8833 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: R_Ifp.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (**********************************************************) (** Complements for the reals.Integer and fractional part *) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index fc8149fb..317f523b 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: R_sqr.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rbasic_fun. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index ccecafc1..6eab48c0 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: R_sqrt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 17c6e90c..885d97ac 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ranalysis.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 5d0a7f5a..def01d6f 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ranalysis1.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 838fbaed..b8610d12 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ranalysis2.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 3925b33c..1848ca52 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ranalysis3.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 78d37a1f..97b6d52b 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Ranalysis4.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index f7278562..dca2782c 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Raxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) (** Axiomatisation of the classical reals *) diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index e3e36b11..ab005daf 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rbase.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Rdefinitions. Require Export Raxioms. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 241232e9..39f2bf6f 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rbasic_fun.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) (** Complements for the real numbers *) diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index af91ae3d..6e66e904 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rcomplete.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 311c7a26..301e0dcf 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rdefinitions.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index 7aa26fca..2b8c95f7 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rderiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) (** Definition of the derivative,continuity *) diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 3621a7da..f0ce1353 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Reals.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** The library REALS is divided in 6 parts : - Rbase: basic lemmas on R diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 2e028411..f56b68c6 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rfunctions.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i Some properties about pow and sum have been made with John Harrison i*) (*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*) diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index 5f96d5e7..703ecfd4 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rgeom.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 53a81ac2..4534a468 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: RiemannInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index cfb991f9..976050f7 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: RiemannInt_SF.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index d2a65f42..72aa9971 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rlimit.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************) (** Definition of the limit *) diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index e8f034b6..60fc4ca9 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Rpow_def.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import Rdefinitions. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 35c90d24..4c3a04f6 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rpower.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i Due to L.Thery i*) (************************************************************) diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 30b62643..e4269eb7 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rprod.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Compare. Require Import Rbase. diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 646b2bc0..f7e05fce 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rseries.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index 54a13e78..4cfca607 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rsigma.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 4c2b423e..9f606fe3 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rsqrt_def.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Sumbool. Require Import Rbase. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index b37de502..9b332eea 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtopology.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 46914093..bdbea3a6 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index d485ad29..9718d20d 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo_alt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index b1d47191..9fd7d37c 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo_calc.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index eb1347a2..b3c4ca23 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo_def.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index e3338c44..2cb5eadd 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo_fun.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index c5ac16ac..7e771444 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Rtrigo_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 0dcb5ccf..f984dc9c 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: SeqProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index e13c366e..35320589 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: SeqSeries.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index 06768612..cf050684 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: SplitAbsolu.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbasic_fun. diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index 7ad0dedc..6eb10370 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: SplitRmult.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index 2f897e73..9eea1c53 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Sqrt_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index a2f4771e..ab431878 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Operators_Properties.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (************************************************************************) (** * Some properties of the operators on relations *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 48e65a1d..71338aa5 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Relation_Definitions.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Section Relation_Definition. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index a4e4b3e6..8aba6275 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Relation_Operators.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (************************************************************************) (** * Bruno Barras, Cristina Cornes *) diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 22d17493..f98db89b 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relation_Definitions. Require Export Relation_Operators. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 3262c7ef..8afaedd6 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$: i*) +(*i $Id: Setoid.v 13323 2010-07-24 15:57:30Z herbelin $: i*) Require Export Coq.Classes.SetoidTactics. diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 824fd036..b20423e0 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Classical_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 8e0ab3b0..bb7235ff 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Constructive_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 0781781a..8591aef1 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Cpo.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index c96c21b4..1fee462d 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Ensembles.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Section Ensembles. Variable U : Type. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index cad440b4..f690e894 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Finite_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Ensembles. diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index cc41a2ea..d351cc74 100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Finite_sets_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index c48c844c..a58e12e6 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Image.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index 210205ed..c85cd8d2 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Infinite_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index 29208d03..37173094 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Integers.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 07fe2721..685a680f 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Multiset.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (* G. Huet 1-9-95 *) diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 95eb5102..671c9690 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Partial_Order.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index e1caff4f..844989c0 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Permut.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (* G. Huet 1-9-95 *) diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index b6df89f3..ae9dbb43 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Powerset.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 93cb653a..f9da4816 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Powerset_Classical_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 7186881a..ab5bbaf9 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Powerset_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 54a5bd01..4677219e 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_1.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Section Relations_1. Variable U : Type. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index a8d8209b..b6c0df25 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_1_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relations_1. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index e9cba979..9f7c831c 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_2.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relations_1. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index cbd596c3..039bae87 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_2_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relations_1. Require Export Relations_1_facts. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 99a68efc..d4a3d87c 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_3.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relations_1. Require Export Relations_2. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index f85128ae..1a22aff9 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id$ i*) +(*i $Id: Relations_3_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Relations_1. Require Export Relations_1_facts. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 9803edc8..78da067d 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Uniset.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Sets as characteristic functions *) diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 2e463120..eb53f061 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Heap.v 13346 2010-07-28 17:17:32Z msozeau $ i*) (** This file is deprecated, for a tree on list, use [Mergesort.v]. *) @@ -136,45 +136,46 @@ Section defs. (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) -> (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) -> merge_lem l1 l2. - + Require Import Morphisms. + + Instance: Equivalence (@meq A). + Proof. constructor; auto with datatypes. red. apply meq_trans. Defined. + + Instance: Proper (@meq A ++> @meq _ ++> @meq _) (@munion A). + Proof. intros x y H x' y' H'. now apply meq_congr. Qed. + Lemma merge : forall l1:list A, Sorted leA l1 -> forall l2:list A, Sorted leA l2 -> merge_lem l1 l2. Proof. - simple induction 1; intros. + fix 1; intros; destruct l1. apply merge_exist with l2; auto with datatypes. - elim H2; intros. - apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes. + rename l1 into l. + revert l2 H0. fix 1. intros. + destruct l2 as [|a0 l0]. + apply merge_exist with (a :: l); simpl; auto with datatypes. elim (leA_dec a a0); intros. (* 1 (leA a a0) *) - cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes. - intros [l3 l3sorted l3contents Hrec]. - apply merge_exist with (a :: l3); simpl in |- *; + apply Sorted_inv in H. destruct H. + destruct (merge l H (a0 :: l0) H0). + apply merge_exist with (a :: l1). clear merge merge0. auto using cons_sort, cons_leA with datatypes. - apply meq_trans with - (munion (singletonBag a) - (munion (list_contents _ eqA_dec l) - (list_contents _ eqA_dec (a0 :: l0)))). - apply meq_right; trivial with datatypes. - apply meq_sym; apply munion_ass. - intros; apply cons_leA. + simpl. rewrite m. now rewrite munion_ass. + intros. apply cons_leA. apply (@HdRel_inv _ leA) with l; trivial with datatypes. (* 2 (leA a0 a) *) - elim X0; simpl in |- *; intros. - apply merge_exist with (a0 :: l3); simpl in |- *; + apply Sorted_inv in H0. destruct H0. + destruct (merge0 l0 H0). clear merge merge0. + apply merge_exist with (a0 :: l1); auto using cons_sort, cons_leA with datatypes. - apply meq_trans with - (munion (singletonBag a0) - (munion (munion (singletonBag a) (list_contents _ eqA_dec l)) - (list_contents _ eqA_dec l0))). - apply meq_right; trivial with datatypes. - apply munion_perm_left. - intros; apply cons_leA; apply HdRel_inv with (l:=l0); trivial with datatypes. + simpl; rewrite m. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm. + repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity. + intros. apply cons_leA. + apply (@HdRel_inv _ leA) with l0; trivial with datatypes. Qed. - (** ** From trees to multisets *) (** contents of a tree as a multiset *) diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index f52a24b4..e576db2b 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Mergesort.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** A modular implementation of mergesort (the complexity is O(n.log n) in the length of the list) *) diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index 1388df6a..00a09051 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: PermutEq.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index f5f91887..e47e2b84 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: PermutSetoid.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Omega Relations Multiset SetoidList. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index f88c29cb..1e145f57 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Permutation.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (*********************************************************************) (** ** List permutations as a composition of adjacent transpositions *) diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 7d75d60a..ab399d40 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Sorted.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Made by Hugo Herbelin *) diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index 85d89441..860e0517 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Sorting.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Sorted. Require Export Mergesort. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index de1684b4..31a18f25 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Ascii.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) diff --git a/theories/Strings/String.v b/theories/Strings/String.v index c2d59679..4b7c1c2d 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: String.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 2c72e30b..18153436 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: DecidableType.v 12641 2010-01-07 15:32:52Z letouzey $ *) Require Export SetoidList. Require Equalities. diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v index 4407ead4..ac1f014b 100644 --- a/theories/Structures/DecidableTypeEx.v +++ b/theories/Structures/DecidableTypeEx.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: DecidableTypeEx.v 12641 2010-01-07 15:32:52Z letouzey $ *) Require Import DecidableType OrderedType OrderedTypeEx. Set Implicit Arguments. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 487b1d0c..d205c0e0 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: Equalities.v 12662 2010-01-13 16:53:01Z letouzey $ *) Require Export RelationClasses. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 72fbe796..57f491d2 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: OrderedType.v 12732 2010-02-10 22:46:59Z letouzey $ *) Require Export SetoidList Morphisms OrdersTac. Set Implicit Arguments. diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v index 23ae4c85..f6c1532b 100644 --- a/theories/Structures/OrderedTypeAlt.v +++ b/theories/Structures/OrderedTypeAlt.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: OrderedTypeAlt.v 12384 2009-10-13 14:39:51Z letouzey $ *) Require Import OrderedType. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index b4dbceba..128cd576 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: OrderedTypeEx.v 13297 2010-07-19 23:32:42Z letouzey $ *) Require Import OrderedType. Require Import ZArith. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index bddd461a..5567b743 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: Orders.v 13276 2010-07-10 14:34:44Z letouzey $ *) Require Export Relations Morphisms Setoid Equalities. Set Implicit Arguments. diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v index d86b02a1..21ef8eb8 100644 --- a/theories/Structures/OrdersAlt.v +++ b/theories/Structures/OrdersAlt.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id$ *) +(* $Id: OrdersAlt.v 12754 2010-02-12 16:21:48Z letouzey $ *) Require Import OrderedType Orders. Set Implicit Arguments. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index 56f1d5de..9f83d82b 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id$ *) +(* $Id: OrdersEx.v 12641 2010-01-07 15:32:52Z letouzey $ *) Require Import Orders NatOrderedType POrderedType NOrderedType ZOrderedType RelationPairs EqualitiesFacts. diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v new file mode 100644 index 00000000..a42de3ab --- /dev/null +++ b/theories/Unicode/Utf8_core.v @@ -0,0 +1,25 @@ +(* -*- coding:utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Logic *) +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. +Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + +Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope. +Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope. +Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope. +Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope. +Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope. +Notation "x ≠y" := (x <> y) (at level 70) : type_scope. + +(* Abstraction *) +Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) + (at level 200, x binder, y binder, right associativity). diff --git a/theories/Unicode/vo.itarget b/theories/Unicode/vo.itarget index 243a40b7..7be1b996 100644 --- a/theories/Unicode/vo.itarget +++ b/theories/Unicode/vo.itarget @@ -1 +1,2 @@ Utf8.vo +Utf8_core.vo diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index 30041b86..7fbddb9e 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Disjoint_Union.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index 80b2e73c..0a72a77a 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Inclusion.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index 762d26a9..6aa7a878 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Inverse_Image.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index f27746c8..db7b106f 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Lexicographic_Exponentiation.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Cristina Cornes diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 8a955c34..29fabbc2 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Lexicographic_Product.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Authors: Bruno Barras, Cristina Cornes *) diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 7c373495..c5cd239a 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Transitive_Closure.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 50777a3e..3bc7470f 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Union.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index 8d298058..0f675cfa 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Well_Ordering.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Author: Cristina Cornes. From: Constructing Recursion Operators in Type Theory diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v index 77d82219..1ab6ac87 100644 --- a/theories/Wellfounded/Wellfounded.v +++ b/theories/Wellfounded/Wellfounded.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Wellfounded.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Export Disjoint_Union. Require Export Inclusion. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 5dbeffa4..2a615311 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: BinInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (***********************************************************) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 30c08fdc..c0123ca8 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(* $Id: Int.v 12363 2009-09-28 15:04:07Z letouzey $ *) (** * An light axiomatization of integers (used in FSetAVL). *) diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index f073463f..d449100c 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Wf_Z.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinInt. Require Import Zcompare. diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index e3937278..96d42077 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZArith.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Library for manipulating integers based on binary encoding *) diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 6a60a021..4af8eb8f 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: ZArith_base.v 13323 2010-07-24 15:57:30Z herbelin $ *) (** Library for manipulating integers based on binary encoding. These are the basic modules, required by [Omega] and [Ring] for instance. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index c4d7cef4..1c5efb07 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ZArith_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Sumbool. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 2c1b8e74..0057c29c 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zabs.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index fcc2f5b8..79cef8f9 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Zbool.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import BinInt. Require Import Zeven. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index d8a5781c..2163e211 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zcomplements.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArithRing. Require Import ZArith_base. diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v index 71466e9e..78a78007 100644 --- a/theories/ZArith/Zdigits.v +++ b/theories/ZArith/Zdigits.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zdigits.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Bit vectors interpreted as integers. Contribution by Jean Duprat (ENS Lyon). *) diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 78dd7050..0f2268cd 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zdiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Contribution by Claude Marché and Xavier Urbain *) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index d4fdaca8..3923d8aa 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zeven.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import BinInt. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index e5767ddd..26c3c0c2 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zgcd_alt.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *) diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index f41e2f01..5dd8c23c 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zhints.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** This file centralizes the lemmas about [Z], classifying them according to the way they can be used in automatic search *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 0666380a..67650b0c 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zlogarithm.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (**********************************************************************) (** The integer logarithms with base 2. diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index 48b9c858..7285ec5a 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zmax.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index f9b23fde..5b1564d6 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zmin.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index 50d4c7f8..f625f762 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zmisc.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Wf_nat. Require Import BinInt. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index cd258af3..0feb4df1 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Znat.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 4347d70c..c3394ed4 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Znumtheory.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith_base. Require Import ZArithRing. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 13112e01..a691d269 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zorder.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 84b49799..226a573c 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zpow_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import ZArith_base. Require Import ZArithRing. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 6e30ca08..e7c2fc57 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Zpower.v 13323 2010-07-24 15:57:30Z herbelin $ i*) Require Import Wf_nat. Require Import ZArith_base. diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v index 1e9db3d1..8d4f70e9 100644 --- a/theories/ZArith/Zsqrt.v +++ b/theories/ZArith/Zsqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Zsqrt.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import ZArithRing. Require Import Omega. diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 03678a27..cc4687ee 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: Zwf.v 13323 2010-07-24 15:57:30Z herbelin $ *) Require Import ZArith_base. Require Export Wf_nat. diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index bd2033b8..f50e7bf7 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: auxiliary.v 13323 2010-07-24 15:57:30Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4 index 6be4d188..e4a3d5a4 100644 --- a/tools/coq_makefile.ml4 +++ b/tools/coq_makefile.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coq_makefile.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) (* créer un Makefile pour un développement Coq automatiquement *) diff --git a/tools/coq_tex.ml4 b/tools/coq_tex.ml4 index f2f7ebc4..647e6d7e 100644 --- a/tools/coq_tex.ml4 +++ b/tools/coq_tex.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coq_tex.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) (* coq-tex * JCF, 16/1/98 diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 08bd8ba0..9bc8965d 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqdep.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Printf open Coqdep_lexer diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index 7de7d395..d50d1604 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqdep_boot.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Coqdep_common diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index a0880d7f..3a2bc4d3 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coqdep_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ i*) { diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index 34b27253..664ead9a 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: alpha.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Cdglobals diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli index cecfe1a6..00b3d11b 100644 --- a/tools/coqdoc/alpha.mli +++ b/tools/coqdoc/alpha.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: alpha.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Alphabetic order. *) diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli index 76d85455..2a0a9091 100644 --- a/tools/coqdoc/cpretty.mli +++ b/tools/coqdoc/cpretty.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cpretty.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Index diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 9367faed..d24093ff 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cpretty.mll 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Utility functions for the scanners *) diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 95950fb0..e8f30853 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: index.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Filename open Lexing diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index bf1d6568..72cd7a9f 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: index.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Cdglobals diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 6b750556..06d57f5e 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: main.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004: * - handling of absolute filenames (function coq_module) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index dda704fa..0b3718ab 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: output.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) open Cdglobals open Index diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index 60408689..dd37c6ad 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: output.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Cdglobals open Index diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 173ed2ed..f95a553a 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -9,7 +9,7 @@ (* coqwc - counts the lines of spec, proof and comments in Coq sources * Copyright (C) 2003 Jean-Christophe Filliâtre *) -(*i $Id$ i*) +(*i $Id: coqwc.mll 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. It assumes the files to be lexically well-formed. *) diff --git a/tools/gallina.ml b/tools/gallina.ml index fe9766ec..a7b7d344 100644 --- a/tools/gallina.ml +++ b/tools/gallina.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: gallina.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Gallina_lexer diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll index 9622beee..d025b8c0 100644 --- a/tools/gallina_lexer.mll +++ b/tools/gallina_lexer.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: gallina_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ *) { open Lexing diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 809af337..6064c3d4 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: auto_ind_decl.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (* This file is about the automatic generation of schemes about decidable equality, created by Vincent Siles, Oct 2007 *) diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 071731ac..5828f12d 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: cerrors.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index e2c42d50..00316007 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: cerrors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/toplevel/class.ml b/toplevel/class.ml index 49b3399c..0ee9dd19 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: class.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/toplevel/class.mli b/toplevel/class.mli index 7410ed32..057d85ac 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: class.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 4c334e0b..435ddb4d 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: classes.ml 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Names @@ -149,7 +149,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, cty, ctx', ctx, len, imps, subst = let (env', ctx), imps = interp_context_evars evars env ctx in - let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in + let c', imps' = interp_type_evars_impls ~evdref:evars ~fail_evar:false env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in diff --git a/toplevel/classes.mli b/toplevel/classes.mli index a19d5dbb..61670e0d 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: classes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/toplevel/command.ml b/toplevel/command.ml index 1f6e7e83..9b18ef27 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: command.ml 13344 2010-07-28 15:04:36Z msozeau $ *) open Pp open Util @@ -69,8 +69,7 @@ let red_constant_entry n ce = function let interp_definition boxed bl red_option c ctypopt = let env = Global.env() in let evdref = ref Evd.empty in - let (env_bl, ctx), imps1 = - interp_context_evars ~fail_anonymous:false evdref env bl in + let (env_bl, ctx), imps1 = interp_context_evars evdref env bl in let imps,ce = match ctypopt with None -> @@ -227,7 +226,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite = let env0 = Global.env() in let evdref = ref Evd.empty in let (env_params, ctx_params), userimpls = - interp_context_evars ~fail_anonymous:false evdref env0 paramsl + interp_context_evars evdref env0 paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in @@ -244,7 +243,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Compute interpretation metadatas *) let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (List.length userimpls) impls) arities in let arities = List.map fst arities in - let impls = compute_full_internalization_env env0 Inductive params indnames fullarities indimpls in + let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = @@ -256,9 +255,9 @@ let interp_mutual_inductive (paramsl,indl) notations finite = () in (* Instantiate evars and check all are resolved *) - let evd,_ = consider_remaining_unif_problems env_params !evdref in + let evd = consider_remaining_unif_problems env_params !evdref in let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in - let sigma = evd in + let sigma = evd in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in let arities = List.map (nf_evar sigma) arities in @@ -448,14 +447,19 @@ let check_mutuality env isfix fixl = type structured_fixpoint_expr = { fix_name : identifier; + fix_annot : identifier located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr } -let interp_fix_context evdref env fix = - interp_context_evars evdref env fix.fix_binders - +let interp_fix_context evdref env isfix fix = + let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in + let (env', ctx), imps = interp_context_evars evdref env before in + let (env'', ctx'), imps' = interp_context_evars evdref env' after in + let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in + ((env'', ctx' @ ctx), imps @ imps', annot) + let interp_fix_ccl evdref (env,_) fix = interp_type_evars evdref env fix.fix_type @@ -487,8 +491,8 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs = (* Jump over let-bindings. *) -let compute_possible_guardness_evidences na fix (ids,_) = - match index_of_annot fix.fix_binders na with +let compute_possible_guardness_evidences (ids,_,na) = + match na with | Some i -> [i] | None -> (* If recursive argument was not given by user, we try all args. @@ -507,15 +511,15 @@ let interp_recursive isfix fixl notations = (* Interp arities allowing for unresolved types *) let evdref = ref Evd.empty in - let fixctxs, fiximps = - List.split (List.map (interp_fix_context evdref env) fixl) in + let fixctxs, fiximps, fixannots = + list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (nf_evar !evdref) fixtypes in let env_rec = push_named_types env fixnames fixtypes in (* Get interpretation metadatas *) - let impls = compute_full_internalization_env env Recursive [] fixnames fixtypes fiximps in + let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in (* Interp bodies with rollback because temp use of notations/implicit *) let fixdefs = @@ -525,7 +529,7 @@ let interp_recursive isfix fixl notations = () in (* Instantiate evars and check all are resolved *) - let evd,_ = consider_remaining_unif_problems env_rec !evdref in + let evd = consider_remaining_unif_problems env_rec !evdref in let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in @@ -538,7 +542,7 @@ let interp_recursive isfix fixl notations = end; (* Build the fix declaration block *) - (fixnames,fixdefs,fixtypes),List.combine fixctxnames fiximps + (fixnames,fixdefs,fixtypes), list_combine3 fixctxnames fiximps fixannots let interp_fixpoint = interp_recursive true let interp_cofixpoint = interp_recursive false @@ -547,7 +551,7 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = - list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in + list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -558,7 +562,7 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in - let fiximps = List.map snd fiximps in + let fiximps = List.map (fun (n,r,p) -> r) fiximps in let fixdecls = list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in ignore (list_map4 (declare_fix boxed Fixpoint) fixnames fixdecls fixtypes fiximps); @@ -572,7 +576,7 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = - list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in + list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -583,7 +587,7 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let fiximps = List.map snd fiximps in + let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames @@ -592,28 +596,28 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = List.iter Metasyntax.add_notation_interpretation ntns let extract_decreasing_argument = function - | (_,(na,CStructRec),_,_,_) -> na + | (na,CStructRec) -> na | _ -> error "Only structural decreasing is supported for a non-Program Fixpoint" let extract_fixpoint_components l = let fixl, ntnl = List.split l in - let wfl = List.map extract_decreasing_argument fixl in - let fixl = List.map (fun ((_,id),_,bl,typ,def) -> - {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in - fixl, List.flatten ntnl, wfl + let fixl = List.map (fun ((_,id),ann,bl,typ,def) -> + let ann = extract_decreasing_argument ann in + {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + fixl, List.flatten ntnl let extract_cofixpoint_components l = let fixl, ntnl = List.split l in List.map (fun ((_,id),bl,typ,def) -> - {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, List.flatten ntnl let do_fixpoint l b = - let fixl,ntns,wfl = extract_fixpoint_components l in + let fixl,ntns = extract_fixpoint_components l in let fix = interp_fixpoint fixl ntns in let possible_indexes = - list_map3 compute_possible_guardness_evidences wfl fixl (snd fix) in + List.map compute_possible_guardness_evidences (snd fix) in declare_fixpoint b fix possible_indexes ntns let do_cofixpoint l b = diff --git a/toplevel/command.mli b/toplevel/command.mli index ab94e7d2..f5996905 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: command.mli 13332 2010-07-26 22:12:43Z msozeau $ i*) (*i*) open Util @@ -102,6 +102,7 @@ val do_mutual_inductive : type structured_fixpoint_expr = { fix_name : identifier; + fix_annot : identifier located option; fix_binders : local_binder list; fix_body : constr_expr option; fix_type : constr_expr @@ -112,8 +113,7 @@ type structured_fixpoint_expr = { val extract_fixpoint_components : (fixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list * - (* possible structural arg: *) lident option list + structured_fixpoint_expr list * decl_notation list val extract_cofixpoint_components : (cofixpoint_expr * decl_notation list) list -> @@ -126,20 +126,20 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (name list * manual_implicits) list + recursive_preentry * (name list * manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (name list * manual_implicits) list + recursive_preentry * (name list * manual_implicits * int option) list (* Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : - bool -> recursive_preentry * (name list * manual_implicits) list -> + bool -> recursive_preentry * (name list * manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : - bool -> recursive_preentry * (name list * manual_implicits) list -> + bool -> recursive_preentry * (name list * manual_implicits * int option) list -> decl_notation list -> unit (* Entry points for the vernacular commands Fixpoint and CoFixpoint *) diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 5f9f96a9..bce38128 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqinit.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open System diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 926ecf8f..c2a535dd 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coqinit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Initialization. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 3d3010dd..f05509a4 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: coqtop.ml 13358 2010-07-29 23:10:17Z herbelin $ *) open Pp open Util @@ -281,7 +281,7 @@ let parse_args is_ide = | "-emacs-U" :: rem -> Flags.print_emacs := true; Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem - | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem + | "-unicode" :: rem -> add_require "Utf8_core"; parse rem | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem | "-coqlib" :: [] -> usage () diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index f5e3a464..e80b3252 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: coqtop.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* The Coq main module. The following function [start] will parse the command line, print the banner, initialize the load path, load the input diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index af02253b..6f74c526 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: discharge.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Names open Util diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index a2cbb6be..dda4c5d7 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: discharge.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Sign open Cooking diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index a97bf9bb..a080442c 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: himsg.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -543,7 +543,7 @@ let explain_unsatisfiable_constraints env evd constr = match constr with | None -> str"Unable to satisfy the following constraints:" ++ fnl() ++ - pr_constraints true env evm + pr_constraints true env undef | Some (ev, k) -> explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++ if List.length (Evd.to_list undef) > 1 then diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 856583d9..a916e87b 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: himsg.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 6f692ced..4e28ccac 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: ind_tables.ml 13323 2010-07-24 15:57:30Z herbelin $ i*) (* File created by Vincent Siles, Oct 2007, extended into a generic support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *) diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index ef3efa47..29d7a12c 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: indschemes.ml 13333 2010-07-27 10:18:30Z vsiles $ *) (* Created by Hugo Herbelin from contents related to inductive schemes initially developed by Christine Paulin (induction schemes), Vincent @@ -54,7 +54,7 @@ let _ = optread = (fun () -> !elim_flag) ; optwrite = (fun b -> elim_flag := b) } -let case_flag = ref true +let case_flag = ref false let _ = declare_bool_option { optsync = true; @@ -63,7 +63,7 @@ let _ = optread = (fun () -> !case_flag) ; optwrite = (fun b -> case_flag := b) } -let eq_flag = ref true +let eq_flag = ref false let _ = declare_bool_option { optsync = true; @@ -292,6 +292,7 @@ let rec split_scheme l = | (Some id,t)::q -> let l1,l2 = split_scheme q in ( match t with | InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 + | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2 | EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2) ) (* @@ -299,38 +300,41 @@ let rec split_scheme l = requested *) | (None,t)::q -> - let l1,l2 = split_scheme q in - ( match t with - | InductionScheme (x,y,z) -> - let ind = smart_global_inductive y in - let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in - let z' = family_of_sort (interp_sort z) in - let suffix = ( - match sort_of_ind with - | InProp -> - if x then (match z' with - | InProp -> "_ind_nodep" - | InSet -> "_rec_nodep" - | InType -> "_rect_nodep") - else ( match z' with - | InProp -> "_ind" - | InSet -> "_rec" - | InType -> "_rect" ) - | _ -> - if x then (match z' with - | InProp -> "_ind" - | InSet -> "_rec" - | InType -> "_rect" ) - else (match z' with - | InProp -> "_ind_dep" - | InSet -> "_rec_dep" - | InType -> "_rect_dep") - ) in - let newid = add_suffix (basename_of_global (IndRef ind)) suffix in - let newref = (dummy_loc,newid) in + let l1,l2 = split_scheme q in + let names inds recs x y z = + let ind = smart_global_inductive y in + let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in + let z' = family_of_sort (interp_sort z) in + let suffix = ( + match sort_of_ind with + | InProp -> + if x then (match z' with + | InProp -> inds ^ "_nodep" + | InSet -> recs ^ "_nodep" + | InType -> recs ^ "t_nodep") + else ( match z' with + | InProp -> inds + | InSet -> recs + | InType -> recs ^ "t" ) + | _ -> + if x then (match z' with + | InProp -> inds + | InSet -> recs + | InType -> recs ^ "t" ) + else (match z' with + | InProp -> inds ^ "_dep" + | InSet -> recs ^ "_dep" + | InType -> recs ^ "t_dep") + ) in + let newid = add_suffix (basename_of_global (IndRef ind)) suffix in + let newref = (dummy_loc,newid) in ((newref,x,ind,z)::l1),l2 - | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) - ) + in + match t with + | CaseScheme (x,y,z) -> names "_case" "_case" x y z + | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z + | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) + let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli index 76a5e4b7..f763e182 100644 --- a/toplevel/indschemes.mli +++ b/toplevel/indschemes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: indschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Util diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml index 89252e54..7af5d0aa 100644 --- a/toplevel/lemmas.ml +++ b/toplevel/lemmas.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: lemmas.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Created by Hugo Herbelin from contents related to lemma proofs in file command.ml, Aug 2009 *) diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli index e0700341..5327f63f 100644 --- a/toplevel/lemmas.mli +++ b/toplevel/lemmas.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: lemmas.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index a297d1d7..6ee00f48 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: metasyntax.ml 13329 2010-07-26 11:05:39Z herbelin $ *) open Pp open Flags @@ -280,7 +280,7 @@ let rec find_pattern nt xl = function | [], NonTerminal x' :: l' -> (out_nt nt,x',List.rev xl),l' | [], Terminal s :: _ | Terminal s :: _, _ -> - error ("The token "^s^" occurs on one side of \"..\" but not on the other side.") + error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.") | [], Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, [] -> @@ -289,23 +289,23 @@ let rec find_pattern nt xl = function anomaly "Only Terminal or Break expected on left, non-SProdList on right" let rec interp_list_parser hd = function - | [] -> [], [], List.rev hd + | [] -> [], List.rev hd | NonTerminal id :: tl when id = ldots_var -> let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in - let yl,xl,tl'' = interp_list_parser [] tl' in + let xyl,tl'' = interp_list_parser [] tl' in (* We remember each pair of variable denoting a recursive part to *) (* remove the second copy of it afterwards *) - (y,x)::yl, x::xl, SProdList (x,sl) :: tl'' + (x,y)::xyl, SProdList (x,sl) :: tl'' | (Terminal _ | Break _) as s :: tl -> if hd = [] then - let yl,xl,tl' = interp_list_parser [] tl in - yl, xl, s :: tl' + let yl,tl' = interp_list_parser [] tl in + yl, s :: tl' else interp_list_parser (s::hd) tl | NonTerminal _ as x :: tl -> - let yl,xl,tl' = interp_list_parser [x] tl in - yl, xl, List.rev_append hd tl' + let xyl,tl' = interp_list_parser [x] tl in + xyl, List.rev_append hd tl' | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser" @@ -345,33 +345,28 @@ let rec get_notation_vars = function | [] -> [] | NonTerminal id :: sl -> let vars = get_notation_vars sl in - if List.mem id vars then - if id <> ldots_var then + if id = ldots_var then vars else + if List.mem id vars then error ("Variable "^string_of_id id^" occurs more than once.") - else - vars - else - id::vars + else + id::vars | (Terminal _ | Break _) :: sl -> get_notation_vars sl | SProdList _ :: _ -> assert false let analyze_notation_tokens l = let l = raw_analyze_notation_tokens l in let vars = get_notation_vars l in - let extrarecvars,recvars,l = interp_list_parser [] l in - (if extrarecvars = [] then [], [], vars, l - else extrarecvars, recvars, list_subtract vars recvars, l) - -let remove_extravars extrarecvars (vars,recvars) = - let vars = - List.fold_right (fun (x,y) l -> - if List.assoc x l <> List.assoc y recvars then - error - "Two end variables of a recursive notation are not in the same scope." - else - List.remove_assoc x l) - extrarecvars (List.remove_assoc ldots_var vars) in - (vars,recvars) + let recvars,l = interp_list_parser [] l in + recvars, list_subtract vars (List.map snd recvars), l + +let error_not_same_scope x y = + error ("Variables "^string_of_id x^" and "^string_of_id y^ + " must be in the same scope.") + +let error_both_bound_and_binding x y = + errorlabstrm "" (strbrk "The recursive variables " ++ pr_id x ++ + strbrk " and " ++ pr_id y ++ strbrk " cannot be used as placeholder + for both terms and binders.") (**********************************************************************) (* Build pretty-printing rules *) @@ -434,6 +429,13 @@ let rec is_non_terminal = function let add_break n l = UnpCut (PpBrk(n,0)) :: l +let check_open_binder isopen sl m = + if isopen & sl <> [] then + errorlabstrm "" (str "as " ++ pr_id m ++ + str " is a non-closed binder, no such \"" ++ + prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl + ++ strbrk "\" is allowed to occur.") + (* Heuristics for building default printing rules *) type previous_prod_status = NoBreak | CanBreak @@ -478,7 +480,7 @@ let make_hunks etyps symbols from = | Terminal s :: prods -> if is_right_bracket s then - UnpTerminal s ::make NoBreak prods + UnpTerminal s :: make NoBreak prods else if ws = CanBreak then add_break 1 (UnpTerminal s :: make NoBreak prods) else @@ -489,14 +491,20 @@ let make_hunks etyps symbols from = | SProdList (m,sl) :: prods -> let i = list_index m vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let typ = List.nth typs (i-1) in + let _,prec = precedence_of_entry_type from typ in let sl' = (* If no separator: add a break *) if sl = [] then add_break 1 [] (* We add NonTerminal for simulation but remove it afterwards *) - else snd (list_sep_last (make NoBreak (sl@[NonTerminal m]))) - in - UnpListMetaVar (i,prec,sl') :: make CanBreak prods + else snd (list_sep_last (make NoBreak (sl@[NonTerminal m]))) in + let hunk = match typ with + | ETConstr _ -> UnpListMetaVar (i,prec,sl') + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,sl') + | _ -> assert false in + hunk :: make CanBreak prods | [] -> [] @@ -559,12 +567,19 @@ let hunks_of_format (from,(vars,typs)) symfmt = let symbs, l = aux (symbs,fmt) in symbs, u :: l | SProdList (m,sl) :: symbs, fmt -> let i = list_index m vars in - let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let typ = List.nth typs (i-1) in + let _,prec = precedence_of_entry_type from typ in let slfmt,fmt = read_recursive_format sl fmt in let sl, slfmt = aux (sl,slfmt) in if sl <> [] then error_format (); let symbs, l = aux (symbs,fmt) in - symbs, UnpListMetaVar (i,prec,slfmt) :: l + let hunk = match typ with + | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,slfmt) + | _ -> assert false in + symbs, hunk :: l | symbs, [] -> symbs, [] | _, _ -> error_format () in @@ -632,11 +647,13 @@ let make_production etyps symbols = (List.map (function Terminal s -> [terminal s] | Break _ -> [] | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in - let typ = match List.assoc x etyps with - | ETConstr x -> x - | _ -> - error "Component of recursive patterns in notation must be constr." in - expand_list_rule typ tkl x 1 0 [] ll) + match List.assoc x etyps with + | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll + | ETBinder o -> + distribute + [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll + | _ -> + error "Components of recursive patterns in notation must be terms or binders.") symbols [[]] in List.map define_keywords prod @@ -682,7 +699,7 @@ let error_incompatible_level ntn oldprec prec = spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") -let cache_one_syntax_extension (prec,ntn,gr,pp) = +let cache_one_syntax_extension (typs,prec,ntn,gr,pp) = try let oldprec = Notation.level_of_notation ntn in if prec <> oldprec then error_incompatible_level ntn oldprec prec @@ -690,7 +707,7 @@ let cache_one_syntax_extension (prec,ntn,gr,pp) = (* Reserve the notation level *) Notation.declare_notation_level ntn prec; (* Declare the parsing rule *) - Egrammar.extend_grammar (Egrammar.Notation (prec,gr)); + Egrammar.extend_grammar (Egrammar.Notation (prec,typs,gr)); (* Declare the printing rule *) Notation.declare_notation_printing_rule ntn (pp,fst prec) @@ -702,8 +719,9 @@ let subst_parsing_rule subst x = x let subst_printing_rule subst x = x let subst_syntax_extension (subst,(local,sy)) = - (local, List.map (fun (prec,ntn,gr,pp) -> - (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy) + (local, List.map (fun (typs,prec,ntn,gr,pp) -> + (typs,prec,ntn,subst_parsing_rule subst gr,subst_printing_rule subst pp)) + sy) let classify_syntax_definition (local,_ as o) = if local then Dispose else Substitute o @@ -768,11 +786,59 @@ let set_entry_type etyps (x,typ) = | ETConstr (n,()), (_,BorderProd (left,_)) -> ETConstr (n,BorderProd (left,None)) | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) - | (ETPattern | ETName | ETBigint | ETOther _ | ETReference as t), _ -> t - | (ETConstrList _, _) -> assert false + | (ETPattern | ETName | ETBigint | ETOther _ | + ETReference | ETBinder _ as t), _ -> t + | (ETBinderList _ |ETConstrList _), _ -> assert false with Not_found -> ETConstr typ in (x,typ) +let join_auxiliary_recursive_types recvars etyps = + List.fold_right (fun (x,y) typs -> + let xtyp = try Some (List.assoc x etyps) with Not_found -> None in + let ytyp = try Some (List.assoc y etyps) with Not_found -> None in + match xtyp,ytyp with + | None, None -> typs + | Some _, None -> typs + | None, Some ytyp -> (x,ytyp)::typs + | Some xtyp, Some ytyp when xtyp = ytyp -> typs + | Some xtyp, Some ytyp -> + errorlabstrm "" + (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++ + strbrk ", both ends have incompatible types.")) + recvars etyps + +let internalization_type_of_entry_type = function + | ETConstr _ -> NtnInternTypeConstr + | ETBigint | ETReference -> NtnInternTypeConstr + | ETBinder _ -> NtnInternTypeBinder + | ETName -> NtnInternTypeIdent + | ETPattern | ETOther _ -> error "Not supported." + | ETBinderList _ | ETConstrList _ -> assert false + +let set_internalization_type typs = + List.map (down_snd internalization_type_of_entry_type) typs + +let make_internalization_vars recvars mainvars typs = + let maintyps = List.combine mainvars typs in + let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in + maintyps@extratyps + +let make_interpretation_type isrec = function + | NtnInternTypeConstr when isrec -> NtnTypeConstrList + | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr + | NtnInternTypeBinder when isrec -> NtnTypeBinderList + | NtnInternTypeBinder -> error "Type not allowed in recursive notation." + +let make_interpretation_vars recvars allvars = + List.iter (fun (x,y) -> + if fst (List.assoc x allvars) <> fst (List.assoc y allvars) then + error_not_same_scope x y) recvars; + let useless_recvars = List.map snd recvars in + let mainvars = + List.filter (fun (x,_) -> not (List.mem x useless_recvars)) allvars in + List.map (fun (x,(sc,typ)) -> + (x,(sc,make_interpretation_type (List.mem_assoc x recvars) typ))) mainvars + let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then error "A notation must include at least one symbol."; @@ -791,29 +857,31 @@ let find_precedence lev etyps symbols = error "The level of the leftmost non-terminal cannot be changed." | ETName | ETBigint | ETReference -> if lev = None then - if_verbose msgnl (str "Setting notation at level 0.") + ([msgnl,str "Setting notation at level 0."],0) else if lev <> Some 0 then - error "A notation starting with an atomic expression must be at level 0."; - 0 - | ETPattern | ETOther _ -> (* Give a default ? *) + error "A notation starting with an atomic expression must be at level 0." + else + ([],0) + | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *) if lev = None then error "Need an explicit level." - else Option.get lev - | ETConstrList _ -> assert false (* internally used in grammar only *) + else [],Option.get lev + | ETConstrList _ | ETBinderList _ -> + assert false (* internally used in grammar only *) with Not_found -> if lev = None then error "A left-recursive notation must have an explicit level." - else Option.get lev) + else [],Option.get lev) | Terminal _ ::l when (match list_last symbols with Terminal _ -> true |_ -> false) -> if lev = None then - (if_verbose msgnl (str "Setting notation at level 0."); 0) - else Option.get lev + ([msgnl,str "Setting notation at level 0."], 0) + else [],Option.get lev | _ -> if lev = None then error "Cannot determine the level."; - Option.get lev + [],Option.get lev let check_curly_brackets_notation_exists () = try let _ = Notation.level_of_notation "{ _ }" in () @@ -849,13 +917,13 @@ let compute_syntax_data (df,modifiers) = (* Notation defaults to NONA *) let assoc = match assoc with None -> Some Gramext.NonA | a -> a in let toks = split_notation_string df in - let (extrarecvars,recvars,vars,symbols) = analyze_notation_tokens toks in + let (recvars,mainvars,symbols) = analyze_notation_tokens toks in let ntn_for_interp = make_notation_key symbols in let symbols' = remove_curly_brackets symbols in let need_squash = (symbols <> symbols') in let ntn_for_grammar = make_notation_key symbols' in check_rule_productivity symbols'; - let n = find_precedence n etyps symbols' in + let msgs,n = find_precedence n etyps symbols' in let innerlevel = NumLevel 200 in let typs = find_symbols @@ -864,12 +932,25 @@ let compute_syntax_data (df,modifiers) = (NumLevel n,BorderProd(Right,assoc)) symbols' in (* To globalize... *) - let typs = List.map (set_entry_type etyps) typs in - let prec = (n,List.map (assoc_of_type n) typs) in - let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in + let etyps = join_auxiliary_recursive_types recvars etyps in + let sy_typs = List.map (set_entry_type etyps) typs in + let prec = (n,List.map (assoc_of_type n) sy_typs) in + let i_typs = set_internalization_type sy_typs in + let sy_data = (n,sy_typs,symbols',fmt) in + let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in - let i_data = (onlyparse,extrarecvars,recvars,vars,(ntn_for_interp,df')) in - (i_data,sy_data) + let i_data = (onlyparse,recvars,mainvars,(ntn_for_interp,df')) in + (* Return relevant data for interpretation and for parsing/printing *) + (msgs,i_data,i_typs,sy_fulldata) + +let compute_pure_syntax_data (df,mods) = + let (msgs,(onlyparse,_,_,_),_,sy_data) = compute_syntax_data (df,mods) in + let msgs = + if onlyparse then + (msg_warning, + str "The only parsing modifier has no effect in Reserved Notation.")::msgs + else msgs in + msgs, sy_data (**********************************************************************) (* Registration of notations interpretation *) @@ -925,9 +1006,9 @@ exception NoSyntaxRule let recover_syntax ntn = try let prec = Notation.level_of_notation ntn in - let pprule,_ = Notation.find_notation_printing_rule ntn in - let gr = Egrammar.recover_notation_grammar ntn prec in - (prec,ntn,gr,pprule) + let pp_rule,_ = Notation.find_notation_printing_rule ntn in + let typs,pa_rule = Egrammar.recover_notation_grammar ntn prec in + (typs,prec,ntn,pa_rule,pp_rule) with Not_found -> raise NoSyntaxRule @@ -935,9 +1016,9 @@ let recover_squash_syntax () = recover_syntax "{ _ }" let recover_notation_syntax rawntn = let ntn = contract_notation rawntn in - let sy_rule = recover_syntax ntn in + let (typs,_,_,_,_ as sy_rule) = recover_syntax ntn in let need_squash = ntn<>rawntn in - if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule] + typs,if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule] (**********************************************************************) (* Main entry point for building parsing and printing rules *) @@ -952,10 +1033,10 @@ let make_pp_rule (n,typs,symbols,fmt) = | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)] | Some fmt -> hunks_of_format (n,List.split typs) (symbols,parse_format fmt) -let make_syntax_rules (ntn,prec,need_squash,sy_data) = +let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) = let pa_rule = make_pa_rule sy_data ntn in let pp_rule = make_pp_rule sy_data in - let sy_rule = (prec,ntn,pa_rule,pp_rule) in + let sy_rule = (i_typs,prec,ntn,pa_rule,pp_rule) in (* By construction, the rule for "{ _ }" is declared, but we need to redeclare it because the file where it is declared needs not be open when the current file opens (especially in presence of -nois) *) @@ -965,31 +1046,35 @@ let make_syntax_rules (ntn,prec,need_squash,sy_data) = (* Main functions about notations *) let add_notation_in_scope local df c mods scope = - let (i_data,sy_data) = compute_syntax_data (df,mods) in - (* Declare the parsing and printing rules *) + let (msgs,i_data,i_typs,sy_data) = compute_syntax_data (df,mods) in + (* Prepare the parsing and printing rules *) let sy_rules = make_syntax_rules sy_data in - Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)); - (* Declare interpretation *) - let (onlyparse,extrarecvars,recvars,vars,df') = i_data in - let (acvars,ac) = interp_aconstr (vars,recvars) c in - let a = (remove_extravars extrarecvars acvars,ac) in + (* Prepare the interpretation *) + let (onlyparse,recvars,mainvars,df') = i_data in + let i_vars = make_internalization_vars recvars mainvars i_typs in + let (acvars,ac) = interp_aconstr i_vars recvars c in + let a = (make_interpretation_vars recvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in + (* Ready to change the global state *) + Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; + Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)); Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); df' let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse = let dfs = split_notation_string df in - let (extrarecvars,recvars,vars,symbs) = analyze_notation_tokens dfs in - (* Redeclare pa/pp rules *) - if not (is_numeral symbs) then begin - let sy_rules = recover_notation_syntax (make_notation_key symbs) in - Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) - end; + let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in + (* Recover types of variables and pa/pp rules; redeclare them if needed *) + let i_typs = if not (is_numeral symbs) then begin + let i_typs,sy_rules = recover_notation_syntax (make_notation_key symbs) in + Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)); i_typs + end else [] in (* Declare interpretation *) let path = (Lib.library_dp(),Lib.current_dirpath true) in let df' = (make_notation_key symbs,(path,df)) in - let (acvars,ac) = interp_aconstr ~impls (vars,recvars) c in - let a = (remove_extravars extrarecvars acvars,ac) in + let i_vars = make_internalization_vars recvars mainvars i_typs in + let (acvars,ac) = interp_aconstr ~impls i_vars recvars c in + let a = (make_interpretation_vars recvars acvars,ac) in let onlyparse = onlyparse or is_not_printable ac in Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df')); df' @@ -997,8 +1082,9 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) (* Notations without interpretation (Reserved Notation) *) let add_syntax_extension local ((loc,df),mods) = - let (_,sy_data) = compute_syntax_data (df,mods) in + let msgs,sy_data = compute_pure_syntax_data (df,mods) in let sy_rules = make_syntax_rules sy_data in + Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) @@ -1090,7 +1176,10 @@ let try_interp_name_alias = function let add_syntactic_definition ident (vars,c) local onlyparse = let vars,pat = try [], ARef (try_interp_name_alias (vars,c)) - with Not_found -> let (vars,_),pat = interp_aconstr (vars,[]) c in vars,pat + with Not_found -> + let i_vars = List.map (fun id -> (id,NtnInternTypeConstr)) vars in + let vars,pat = interp_aconstr i_vars [] c in + List.map (fun (id,(sc,kind)) -> (id,sc)) vars, pat in let onlyparse = onlyparse or is_not_printable pat in Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 2fd7749d..d8dd0d52 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: metasyntax.mli 13328 2010-07-26 11:05:30Z herbelin $ i*) (*i*) open Util @@ -47,7 +47,7 @@ val add_notation_interpretation : (* Add a notation interpretation for supporting the "where" clause *) -val set_notation_for_interpretation : Constrintern.full_internalization_env -> +val set_notation_for_interpretation : Constrintern.internalization_env -> (lstring * constr_expr * scope_name option) -> unit (* Add only the parsing/printing rule of a notation *) diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 5cefe263..e8c06d13 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -11,7 +11,7 @@ * camlp4deps will not work for this file unless Makefile system enhanced. *) -(* $Id$ *) +(* $Id: mltop.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Util open Pp diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index c2d65493..12b6f78f 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: mltop.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* If there is a toplevel under Coq, it is described by the following record. *) diff --git a/toplevel/record.ml b/toplevel/record.ml index ae53b0cf..cd569178 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: record.ml 13332 2010-07-26 22:12:43Z msozeau $ *) open Pp open Util @@ -32,7 +32,6 @@ open Topconstr (********** definition d'un record (structure) **************) let interp_evars evdref env impls k typ = - let impls = set_internalization_env_params impls [] in let typ' = intern_gen true ~impls !evdref env typ in let imps = Implicit_quantifiers.implicits_of_rawterm typ' in imps, Pretyping.Default.understand_tcc_evars evdref env k typ' @@ -48,8 +47,7 @@ let interp_fields_evars evars env nots l = | Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls in let d = (i,b',t') in - let impls' = set_internalization_env_params impls [] in - List.iter (Metasyntax.set_notation_for_interpretation impls') no; + List.iter (Metasyntax.set_notation_for_interpretation impls) no; (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], []) nots l @@ -62,13 +60,13 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields id t ps nots fs = let env0 = Global.env () in let evars = ref Evd.empty in - let (env1,newps), imps = interp_context_evars ~fail_anonymous:false evars env0 ps in + let (env1,newps), imps = interp_context_evars evars env0 ps in let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = interp_fields_evars evars env_ar nots (binders_of_decls fs) in - let evars,_ = Evarconv.consider_remaining_unif_problems env_ar !evars in + let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in let evars = Typeclasses.resolve_typeclasses env_ar evars in let sigma = evars in let newps = Evarutil.nf_rel_context_evar sigma newps in diff --git a/toplevel/record.mli b/toplevel/record.mli index eae279f3..ea4a3b7e 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: record.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/toplevel/search.ml b/toplevel/search.ml index a358f687..0bd552af 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: search.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/toplevel/search.mli b/toplevel/search.mli index b4b971a7..a73052f2 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: search.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) open Pp open Names diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 64096152..9594c988 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: toplevel.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli index 92c8ddc4..a614c1da 100644 --- a/toplevel/toplevel.mli +++ b/toplevel/toplevel.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: toplevel.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Pp diff --git a/toplevel/usage.ml b/toplevel/usage.ml index dcee9921..22588f2c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: usage.ml 13323 2010-07-24 15:57:30Z herbelin $ *) let version () = Printf.printf "The Coq Proof Assistant, version %s (%s)\n" diff --git a/toplevel/usage.mli b/toplevel/usage.mli index 662f56ad..1167750b 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: usage.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*s Prints the version number on the standard output and exits (with 0). *) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 17792579..7f8bcb9e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: vernac.ml 13323 2010-07-24 15:57:30Z herbelin $ *) (* Parsing of vernacular. *) diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index d925614c..dc4d9e2f 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vernac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Parsing of vernacular. *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 3a5e1da8..254f690c 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vernacentries.ml 13329 2010-07-26 11:05:39Z herbelin $ i*) (* Concrete syntax of the mathematical vernacular MV V2.6 *) @@ -626,7 +626,6 @@ let vernac_instance abst glob sup inst props pri = ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri) let vernac_context l = - List.iter (fun x -> Dumpglob.dump_local_binder x true "var") l; Classes.context l let vernac_declare_instance glob id = @@ -1079,7 +1078,7 @@ let vernac_global_check c = let vernac_print = function | PrintTables -> print_tables () - | PrintFullContext -> msg (print_full_context_typ ()) + | PrintFullContext-> msg (print_full_context_typ ()) | PrintSectionContext qid -> msg (print_sec_context_typ qid) | PrintInspect n -> msg (inspect n) | PrintGrammar ent -> Metasyntax.print_grammar ent diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 031864fd..10ed35a7 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vernacentries.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Names diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 1f3261e1..5eb220cb 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vernacexpr.ml 13332 2010-07-26 22:12:43Z msozeau $ i*) open Util open Names @@ -197,6 +197,7 @@ type proof_end = type scheme = | InductionScheme of bool * reference or_by_notation * sort_expr + | CaseScheme of bool * reference or_by_notation * sort_expr | EqualityScheme of reference or_by_notation type vernac_expr = diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 90d8d9dd..f3d2e7a5 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id: vernacinterp.ml 13323 2010-07-24 15:57:30Z herbelin $ *) open Pp open Util diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli index 8bcbe5f3..ce64188c 100644 --- a/toplevel/vernacinterp.mli +++ b/toplevel/vernacinterp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: vernacinterp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (*i*) open Tacexpr diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 20928cbe..15caaddd 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id$ *) +(* $Id: whelp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *) open Flags open Pp diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli index d6beeca1..27c36239 100644 --- a/toplevel/whelp.mli +++ b/toplevel/whelp.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: whelp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*) (* Coq interface to the Whelp query engine developed at the University of Bologna *) |