diff options
| author |  herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2005-12-26 13:51:24 +0000 |
|---|---|---|
| committer | herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2005-12-26 13:51:24 +0000 |
| commit | e0f9487be5ce770117a9c9c815af8c7010ff357b (patch) | |
| tree | bbbde42b0a40803a0c5f5bdb5aaf09248d9aedc0 | |
| parent | 98d60ce261e7252379ced07d2934647c77efebfd (diff) | |
Suppression des parseurs et printeurs v7; suppression du traducteur (mécanismes de renommage des noms de constantes, de module, de ltac et de certaines variables liées de lemmes et de tactiques, mécanisme d'ajout d'arguments implicites, etc.)
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@7732 85f007b7-540e-0410-9357-904b9bb8a0f7
107 files changed, 1043 insertions, 8176 deletions
@@ -37,13 +37,9 @@ NOARG: @echo "For make to be verbose, add VERBOSE=1" # build and install the three subsystems: coq, coqide, pcoq -world: coq coqide pcoq -world8: coq8 coqide pcoq -world7: coq7 coqide pcoq +world: coq coqide # pcoq install: install-coq install-coqide install-pcoq -install8: install-coq8 install-coqide install-pcoq -install7: install-coq7 install-coqide install-pcoq #install-manpages: install-coq-manpages install-pcoq-manpages ########################################################################### @@ -172,16 +168,15 @@ PROOFS=\ proofs/clenvtac.cmo PARSING=\ - parsing/coqast.cmo parsing/ast.cmo \ - parsing/termast.cmo parsing/extend.cmo parsing/esyntax.cmo \ - parsing/pcoq.cmo parsing/egrammar.cmo parsing/g_xml.cmo \ - parsing/ppconstr.cmo translate/ppconstrnew.cmo parsing/printer.cmo \ + parsing/extend.cmo \ + parsing/pcoq.cmo parsing/egrammar.cmo parsing/g_xml.cmo parsing/ppconstr.cmo \ + translate/ppconstrnew.cmo parsing/printer.cmo \ parsing/pptactic.cmo translate/pptacticnew.cmo parsing/tactic_printer.cmo \ parsing/printmod.cmo parsing/prettyp.cmo parsing/search.cmo HIGHPARSING=\ parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \ - parsing/g_prim.cmo # parsing/g_proofs.cmo parsing/g_basevernac.cmo \ +# parsing/g_prim.cmo # parsing/g_proofs.cmo parsing/g_basevernac.cmo \ # parsing/g_vernac.cmo parsing/g_tactic.cmo \ # parsing/g_ltac.cmo parsing/g_constr.cmo parsing/g_cases.cmo \ # parsing/g_module.cmo \ @@ -396,17 +391,11 @@ COQBINARIES= $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(BESTCOQTOP) $(COQTOP) coqbinaries:: ${COQBINARIES} coq: coqlib tools coqbinaries -coq8: coqlib tools coqbinaries -coq7: coqlib7 tools coqbinaries coqlib:: newtheories newcontrib -coqlib7: theories7 contrib7 - coqlight: theories-light tools coqbinaries -states7:: states7/initial.coq - states:: states/initial.coq $(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(USERTACCMX) @@ -763,14 +752,6 @@ INTERFACERC= contrib/interface/vernacrc pcoq-files:: $(INTERFACEVO) $(INTERFACERC) -# Centaur grammar rules now in centaur.ml4 -contrib7/interface/Centaur.vo: contrib7/interface/Centaur.v $(INTERFACE) - $(BESTCOQTOP) $(TRANSLATE) -boot -byte $(COQOPTS) -compile $* - -# Move the grammar rules to dad.ml ? -contrib7/interface/AddDad.vo: contrib7/interface/AddDad.v $(INTERFACE) states7/initial.coq - $(BESTCOQTOP) $(TRANSLATE) -boot -byte $(COQOPTS) -compile $* - clean:: rm -f bin/parser$(EXE) bin/parser.opt$(EXE) bin/coq-interface$(EXE) bin/coq-interface.opt$(EXE) @@ -949,7 +930,6 @@ REALS_all=\ REALSVO=$(REALSBASEVO) $(REALS_$(REALS)) ALLREALS=$(REALSBASEVO) $(REALS_all) -ALLOLDREALS=$(REALSBASEVO:theories%.vo:theories7%.vo) $(REALS_all:theories%.vo:theories7%.vo) SETOIDSVO=theories/Setoids/Setoid.vo @@ -1085,7 +1065,6 @@ contrib7:: $(OLDCONTRIBVO) translation:: $(NEWTHEORIESV) $(NEWCONTRIBV) ALLNEWVO = $(INITVO) $(THEORIESVO) $(CONTRIBVO) -ALLOLDVO = $(OLDINITVO) $(OLDTHEORIESVO) $(OLDCONTRIBVO) ########################################################################### # rules to make theories, contrib and states @@ -1093,24 +1072,9 @@ ALLOLDVO = $(OLDINITVO) $(OLDTHEORIESVO) $(OLDCONTRIBVO) SYNTAXPP=syntax/PPConstr.v syntax/PPCases.v -states7/barestate.coq: $(SYNTAXPP) $(BESTCOQTOP) - $(BESTCOQTOP) -v7 -boot -batch -notop -silent -nois -I syntax -load-vernac-source syntax/MakeBare.v -outputstate $@ - -states7/initial.coq: states7/barestate.coq states7/MakeInitial.v $(OLDINITVO) $(BESTCOQTOP) - $(BOOTCOQTOP) -v7 -batch -notop -silent -is states7/barestate.coq -load-vernac-source states7/MakeInitial.v -outputstate states7/initial.coq - states/initial.coq: states/MakeInitial.v $(NEWINITVO) $(BOOTCOQTOP) -batch -notop -silent -nois -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq -theories7/Init/%.vo: $(BESTCOQTOP) theories7/Init/%.v - $(BOOTCOQTOP) $(TRANSLATE) -nois -compile theories7/Init/$* - -theories7/%.vo: theories7/%.v states7/initial.coq - $(BOOTCOQTOP) $(TRANSLATE) -compile theories7/$* - -contrib7/%.vo: contrib7/%.v states7/initial.coq - $(BOOTCOQTOP) $(TRANSLATE) -compile contrib7/$* - theories/Init/%.vo: $(BESTCOQTOP) theories/Init/%.v $(BOOTCOQTOP) -nois -compile theories/Init/$* @@ -1123,17 +1087,14 @@ contrib/%.vo: contrib/%.v contrib/extraction/%.vo: contrib/extraction/%.v states/barestate.coq $(COQC) $(BOOTCOQTOP) -is states/barestate.coq -compile $* -contrib7/extraction/%.vo: contrib7/extraction/%.v states/barestate.coq $(COQC) - $(BOOTCOQTOP) $(TRANSLATE) -is states7/barestate.coq -compile $* - cleantheories: - rm -f states/*.coq states7/*.coq - rm -f theories/*/*.vo theories7/*/*.vo + rm -f states/*.coq + rm -f theories/*/*.vo clean :: cleantheories clean :: - rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo contrib7/*/*.vo + rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo archclean:: rm -f contrib/*/*.cmx contrib/*.cmxa contrib/*.a contrib/*/*.[so] @@ -1245,8 +1206,6 @@ FULLEMACSLIB=$(COQINSTALLPREFIX)$(EMACSLIB) FULLCOQDOCDIR=$(COQINSTALLPREFIX)$(COQDOCDIR) install-coq: install-binaries install-library install-coq-info -install-coq8: install-binaries install-library8 install-coq-info -install-coq7: install-binaries install-library7 install-coq-info install-coqlight: install-binaries install-library-light install-binaries:: install-$(BEST) install-tools @@ -1271,9 +1230,7 @@ LIBFILESLIGHT=$(OLDTHEORIESLIGHTVO) NEWLIBFILES=$(NEWTHEORIESVO) $(NEWCONTRIBVO) NEWLIBFILESLIGHT=$(NEWTHEORIESLIGHTVO) -install-library: install-library7 install-library8 - -install-library8: +install-library: $(MKDIR) $(FULLCOQLIB) for f in $(NEWLIBFILES); do \ $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \ @@ -1283,15 +1240,6 @@ install-library8: cp states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib -install-library7: - $(MKDIR) $(FULLCOQLIB) - for f in $(LIBFILES); do \ - $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \ - cp $$f $(FULLCOQLIB)/`dirname $$f`; \ - done - $(MKDIR) $(FULLCOQLIB)/states7 - cp states7/*.coq $(FULLCOQLIB)/states7 - install-library-light: $(MKDIR) $(FULLCOQLIB) for f in $(LIBFILESLIGHT) $(NEWLIBFILESLIGHT); do \ @@ -1300,8 +1248,6 @@ install-library-light: done $(MKDIR) $(FULLCOQLIB)/states cp states/*.coq $(FULLCOQLIB)/states - $(MKDIR) $(FULLCOQLIB)/states7 - cp states7/*.coq $(FULLCOQLIB)/states7 install-allreals:: for f in $(ALLREALS); do \ @@ -1391,8 +1337,8 @@ otags: # grammar modules with camlp4 -ML4FILES += parsing/lexer.ml4 parsing/q_util.ml4 parsing/q_coqast.ml4 \ - parsing/g_prim.ml4 parsing/pcoq.ml4 +ML4FILES += parsing/lexer.ml4 parsing/pcoq.ml4 parsing/q_util.ml4 \ + # parsing/q_coqast.ml4 parsing/g_prim.ml4 GRAMMARNEEDEDCMO=\ lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bigint.cmo \ @@ -1417,18 +1363,19 @@ GRAMMARNEEDEDCMO=\ pretyping/pattern.cmo \ interp/topconstr.cmo interp/genarg.cmo interp/ppextend.cmo \ proofs/tacexpr.cmo \ - parsing/coqast.cmo parsing/ast.cmo \ - parsing/ast.cmo parsing/lexer.cmo parsing/q_util.cmo parsing/extend.cmo \ - toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_coqast.cmo + parsing/lexer.cmo parsing/extend.cmo \ + toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_util.cmo \ + parsing/q_coqast.cmo +# parsing/coqast.cmo parsing/ast.cmo \ CAMLP4EXTENSIONSCMO=\ parsing/argextend.cmo parsing/tacextend.cmo parsing/vernacextend.cmo GRAMMARSCMO=\ - parsing/g_prim.cmo parsing/g_tactic.cmo \ - parsing/g_ltac.cmo parsing/g_constr.cmo \ parsing/g_primnew.cmo parsing/g_tacticnew.cmo \ - parsing/g_ltacnew.cmo parsing/g_constrnew.cmo + parsing/g_ltacnew.cmo parsing/g_constrnew.cmo +# parsing/g_prim.cmo parsing/g_tactic.cmo \ +# parsing/g_ltac.cmo parsing/g_constr.cmo \ GRAMMARCMO=$(GRAMMARNEEDEDCMO) $(CAMLP4EXTENSIONSCMO) $(GRAMMARSCMO) @@ -1461,8 +1408,7 @@ PRINTERSCMO=\ interp/constrextern.cmo interp/syntax_def.cmo interp/constrintern.cmo \ proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \ proofs/evar_refiner.cmo proofs/pfedit.cmo proofs/tactic_debug.cmo \ - parsing/ppconstr.cmo parsing/coqast.cmo parsing/ast.cmo \ - parsing/termast.cmo parsing/extend.cmo parsing/esyntax.cmo \ + parsing/ppconstr.cmo parsing/extend.cmo \ translate/ppconstrnew.cmo parsing/printer.cmo parsing/pptactic.cmo \ translate/pptacticnew.cmo parsing/tactic_printer.cmo \ dev/top_printers.cmo @@ -1705,8 +1651,6 @@ alldepend: depend dependcoq dependcoq:: beforedepend $(COQDEP) -coqlib . -R theories Coq -R contrib Coq $(COQINCLUDES) \ $(ALLREALS:.vo=.v) $(ALLNEWVO:.vo=.v) > .depend.coq - $(COQDEP) -coqlib . -R theories7 Coq -R contrib7 Coq $(COQINCLUDES) \ - $(ALLOLDREALS:.vo=.v) $(ALLOLDVO:.vo=.v) > .depend.coq7 # Build dependencies ignoring failures in building ml files from ml4 files # This is useful to rebuild dependencies when they are strongly corrupted: @@ -1773,10 +1717,8 @@ devel: -include .depend -include .depend.coq --include .depend.coq7 clean:: - rm -fr *.v8 syntax/*.v8 ide/*.v8 theories7/*/*.v8 contrib7/*/*.v8 find . -name "\.#*" -exec rm -f {} \; find . -name "*~" -exec rm -f {} \; diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7c91eca25..5b448efef 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -69,13 +69,6 @@ let with_universes f = Options.with_option print_universes f let without_symbols f = Options.with_option print_no_symbol f let with_meta_as_hole f = Options.with_option print_meta_as_hole f -(* For the translator *) -let temporary_implicits_out = ref [] -let set_temporary_implicits_out l = temporary_implicits_out := l -let get_temporary_implicits_out id = - try List.assoc id !temporary_implicits_out - with Not_found -> [] - (**********************************************************************) (* Various externalisation functions *) @@ -96,8 +89,7 @@ let ids_of_ctxt ctxt = (function c -> match kind_of_term c with | Var id -> id | _ -> - error - "Termast: arbitrary substitution of references not yet implemented") + error "arbitrary substitution of references not implemented") ctxt) let idopt_of_name = function @@ -123,863 +115,8 @@ let raw_string_of_ref = function | VarRef id -> "SECVAR("^(string_of_id id)^")" -(* v7->v8 translation *) - -let name_app f = function - | Name id -> Name (f id) - | Anonymous -> Anonymous - -let rec translate_ident_string = function - (* translate keyword *) - | ("at" | "IF" | "forall" | "fun" | "match" | "fix" | "cofix" | "for" | "let" - | "if" | "then" | "else" | "return" | "mod" | "where" - | "exists" | "exists2" | "using" as s) -> - let s' = s^"_" in - msgerrnl - (str ("Warning: '"^ - s^"' is now a keyword; it has been translated to '"^s'^"'")); - s' -(* Le conflit est en fait surtout avec Eval dans Definition et c'est gere dans - Ppconstrnew - | "eval" as s -> - let s' = s^"_" in - msgerrnl - (str ("Warning: '"^ - s^"' is a conflicting ident; it has been translated to '"^s'^"'")); - s' -*) - - (* avoid _ *) - | "_" -> - msgerrnl (str - "Warning: '_' is no longer an ident; it has been translated to 'x_'"); - "x_" - (* avoid @ *) - | s when String.contains s '@' -> - let n = String.index s '@' in - translate_ident_string - (String.sub s 0 n ^ "'at'" ^ String.sub s (n+1) (String.length s -n-1)) - | s -> s - -let translate_ident id = - id_of_string (translate_ident_string (string_of_id id)) - -let is_coq_root d = - let d = repr_dirpath d in d <> [] & string_of_id (list_last d) = "Coq" - -let is_dir dir s = - let d = repr_dirpath dir in - d <> [] & string_of_id (List.hd d) = s - -let is_module m = is_dir (Lib.library_dp()) m - -let bp = ["BinPos"] -let bz = ["BinInt"] -let bn = ["BinNat"] -let pn = ["nat"] -let zc = ["Zcompare"] -let lo = ["Logic"] -let da = ["Datatypes"] -let zabs = ["Zabs"] -let zo = ["Zorder"] -let zn = ["Znat"] -let wz = ["Wf_Z"] -let mu = ["Mult"] -let pl = ["Plus"] -let mi = ["Minus"] -let le = ["Le"] -let gt = ["Gt"] -let lt = ["Lt"] -let be = ["Between"] -let bo = ["Bool"] -let c dir = - let d = repr_dirpath dir in - if d = [] then [] else [string_of_id (List.hd d)] - -let translation_table = [ - (* ZArith *) -"double_moins_un", (bp,"Pdouble_minus_one"); -"double_moins_deux", (bp,"Pdouble_minus_two"); -"is_double_moins_un", (bp,"Psucc_o_double_minus_one_eq_xO"); -"double_moins_un_add_un_xI", (bp,"Pdouble_minus_one_o_succ_eq_xI"); -"add_un_Zs", (bz,"Zpos_succ_morphism"); -"entier", (bn,"N"); -"entier_of_Z", (bz,"Zabs_N"); -"Z_of_entier", (bz,"Z_of_N"); -"SUPERIEUR", (da,"Gt"); -"EGAL", (da,"Eq"); -"INFERIEUR", (da,"Lt"); -"add", (bp,"Pplus"); -"add_carry", (bp,"Pplus_carry"); -"add_assoc", (bp,"Pplus_assoc"); -"add_sym", (bp,"Pplus_comm"); -"add_x_x", (bp,"Pplus_diag"); -"add_carry_add", (bp,"Pplus_carry_plus"); -"simpl_add_r", (bp,"Pplus_reg_r"); -"simpl_add_l", (bp,"Pplus_reg_l"); -"simpl_add_carry_r", (bp,"Pplus_carry_reg_r"); -"simpl_add_carry_l", (bp,"Pplus_carry_reg_l"); -"simpl_times_r", (bp,"Pmult_reg_r"); -"simpl_times_l", (bp,"Pmult_reg_l"); -(* -"xO_xI_add_double_moins_un", (bp,"xO_xI_plus_double_minus_one"); -*) -"double_moins_un_plus_xO_double_moins_un", - (bp,"Pdouble_minus_one_plus_xO_double_minus_one"); -"add_xI_double_moins_un", (bp,"Pplus_xI_double_minus_one"); -"add_xO_double_moins_un", (bp,"Pplus_xO_double_minus_one"); -"iter_pos_add", (bp,"iter_pos_plus"); -"add_no_neutral", (bp,"Pplus_no_neutral"); -"add_carry_not_add_un", (bp,"Pplus_carry_no_neutral"); -"times_add_distr", (bp,"Pmult_plus_distr_l"); -"times_add_distr_l", (bp,"Pmult_plus_distr_r"); -"times_true_sub_distr", (bp,"Pmult_minus_distr_l"); -"times_sym", (bp,"Pmult_comm"); -"times_assoc", (bp,"Pmult_assoc"); -"times_convert", (bp,"nat_of_P_mult_morphism"); -"true_sub", (bp,"Pminus"); -"times_x_1", (bp,"Pmult_1_r"); -"times_x_double", (bp,"Pmult_xO_permute_r"); - (* Changer en Pmult_xO_distrib_r_reverse *) -"times_x_double_plus_one", (bp,"Pmult_xI_permute_r"); (* Changer ? *) -"times_discr_xO_xI", (bp,"Pmult_xI_mult_xO_discr"); -"times_discr_xO", (bp,"Pmult_xO_discr"); -"times_one_inversion_l", (bp,"Pmult_1_inversion_l"); -"true_sub_convert", (bp,"nat_of_P_minus_morphism"); -"compare_true_sub_right", (bp,"Pcompare_minus_r"); -"compare_true_sub_left", (bp,"Pcompare_minus_l"); -"sub_add", (bp,"Pplus_minus" (* similar to le_plus_minus in Arith *)); -"sub_add_one", (bp,"Ppred_succ"); -"add_sub_one", (bp,"Psucc_pred"); -"add_un", (bp,"Psucc"); -"add_un_discr", (bp,"Psucc_discr"); -"add_un_not_un", (bp,"Psucc_not_one"); -"add_un_inj", (bp,"Psucc_inj"); -"xI_add_un_xO", (bp,"xI_succ_xO"); -"ZL12", (bp,"Pplus_one_succ_r"); -"ZL12bis", (bp,"Pplus_one_succ_l"); -"ZL13", (bp,"Pplus_carry_spec"); - (* Changer en Pplus_succ_distrib_r_reverse ? *) -"ZL14", (bp,"Pplus_succ_permute_r"); - (* Changer en Plus_succ_distrib_l_reverse *) -"ZL14bis", (bp,"Pplus_succ_permute_l"); -"sub_un", (bp,"Ppred"); -"sub_pos", (bp,"Pminus_mask"); -"sub_pos_x_x", (bp,"Pminus_mask_diag"); -(*"sub_pos_x_x", (bp,"Pminus_mask_diag");*) -"sub_pos_SUPERIEUR", (bp,"Pminus_mask_Gt"); -"sub_neg", (bp,"Pminus_mask_carry"); -"Zdiv2_pos", (bp,"Pdiv2"); -"Pdiv2", (["Zbinary"],"Zdiv2_ge_compat"); -"ZERO", (bz,"Z0"); -"POS", (bz,"Zpos"); -"NEG", (bz,"Zneg"); -"Nul", (bn,"N0"); -"Pos", (bn,"Npos"); -"Un_suivi_de", (bn,"Ndouble_plus_one"); -"Zero_suivi_de", (bn,"Ndouble"); -"Un_suivi_de_mask", (bp,"Pdouble_plus_one_mask"); -"Zero_suivi_de_mask", (bp,"Pdouble_mask"); -"ZS", (bp,"double_eq_zero_inversion"); -"US", (bp,"double_plus_one_zero_discr"); -"USH", (bp,"double_plus_one_eq_one_inversion"); -"ZSH", (bp,"double_eq_one_discr"); -"ZPminus_add_un_permute", (bz,"ZPminus_succ_permute"); -"ZPminus_add_un_permute_Zopp", (bz,"ZPminus_succ_permute_opp"); -"ZPminus_double_moins_un_xO_add_un", (bz,"ZPminus_double_minus_one_xO_succ"); -"ZL1", (bp,"xO_succ_permute"); (* ?? *) -"Zplus_assoc_r", (bz,"Zplus_assoc_reverse"); -"Zplus_sym", (bz,"Zplus_comm"); -"Zero_left", (bz,"Zplus_0_l"); -"Zero_right", (bz,"Zplus_0_r"); -"Zplus_n_O", (bz,"Zplus_0_r_reverse"); -"Zplus_unit_left", (bz,"Zplus_0_simpl_l"); -"Zplus_unit_right", (bz,"Zplus_0_simpl_l_reverse"); -"Zplus_Zopp_expand", (bz,"Zplus_opp_expand"); -"Zn_Sn", (bz,"Zsucc_discr"); -"Zs", (bz,"Zsucc"); -"Psucc_Zs", (bz,"Zpos_succ_permute"); -"Zs_pred", (bz,"Zsucc_pred"); -"Zpred_Sn", (bz,"Zpred_succ"); -"Zminus_n_O", (bz,"Zminus_0_l_reverse"); -"Zminus_n_n", (bz,"Zminus_diag_reverse"); -"Zminus_Sn_m", (bz,"Zminus_succ_l"); -"Zeq_Zminus", (bz,"Zeq_minus"); -"Zminus_Zeq", (bz,"Zminus_eq"); -"Zplus_minus", (bz,"Zplus_minus_eq"); -"Zminus_plus", (bz,"Zminus_plus"); -"Zminus_plus_simpl", (bz,"Zminus_plus_simpl_l_reverse"); -"Zminus_Zplus_compatible", (bz,"Zminus_plus_simpl_r"); -"Zle_plus_minus", (bz,"Zplus_minus"); -"Zopp_Zplus", (bz,"Zopp_plus_distr"); -"Zopp_Zopp", (bz,"Zopp_involutive"); -"Zopp_NEG", (bz,"Zopp_neg"); -"Zopp_Zdouble", (bz,"Zopp_double"); -"Zopp_Zdouble_plus_one", (bz,"Zopp_double_plus_one"); -"Zopp_Zdouble_minus_one", (bz,"Zopp_double_minus_one"); -"Zplus_inverse_r", (bz,"Zplus_opp_r"); -"Zplus_inverse_l", (bz,"Zplus_opp_l"); -"Zplus_S_n", (bz,"Zplus_succ_l"); -"Zplus_n_Sm", (bz,"Zplus_succ_r"); -"Zplus_Snm_nSm", (bz,"Zplus_succ_comm"); -"Zmult_assoc_r", (bz,"Zmult_assoc_reverse"); -"Zmult_sym", (bz,"Zmult_comm"); -"Zmult_eq", (bz,"Zmult_integral_l"); -"Zmult_zero", (bz,"Zmult_integral"); -"Zero_mult_left", (bz,"Zmult_0_l"); -"Zero_mult_right", (bz,"Zmult_0_r"); -"Zmult_1_n", (bz,"Zmult_1_l"); -"Zmult_n_1", (bz,"Zmult_1_r"); -"Zmult_n_O", (bz,"Zmult_0_r_reverse"); -"Zopp_one", (bz,"Zopp_eq_mult_neg_1"); -"Zopp_Zmult", (bz,"Zopp_mult_distr_l_reverse"); -"Zopp_Zmult_r", (bz,"Zopp_mult_distr_r"); -"Zopp_Zmult_l", (bz,"Zopp_mult_distr_l"); -"Zmult_Zopp_Zopp", (bz,"Zmult_opp_opp"); -"Zmult_Zopp_left", (bz,"Zmult_opp_comm"); -"Zmult_Zplus_distr", (bz,"Zmult_plus_distr_r"); -"Zmult_plus_distr", (bz,"Zmult_plus_distr_r"); -"Zmult_Zminus_distr_r", (bz,"Zmult_minus_distr_l"); -"Zmult_Zminus_distr_l", (bz,"Zmult_minus_distr_r"); -"Zcompare_Zplus_compatible", (zc,"Zcompare_plus_compat"); -"Zcompare_Zplus_compatible2", (zc,"Zplus_compare_compat"); -"Zcompare_Zmult_compatible", (zc,"Zcompare_mult_compat"); -"inject_nat", (bz,"Z_of_nat"); -"inject_nat_complete", (wz,"Z_of_nat_complete"); -"inject_nat_complete_inf", (wz,"Z_of_nat_complete_inf"); -"inject_nat_prop", (wz,"Z_of_nat_prop"); -"inject_nat_set", (wz,"Z_of_nat_set"); -"convert", (bp,"nat_of_P"); -"anti_convert", (bp,"P_of_succ_nat"); -"positive_to_nat", (bp,"Pmult_nat"); -"Zopp_intro", (bz,"Zopp_inj"); -"plus_iter_add", (bp,"plus_iter_eq_plus"); -"compare", (bp,"Pcompare"); -"iter_convert", (["Zmisc"],"iter_nat_of_P"); -"ZLSI", (bp,"Pcompare_Gt_Lt"); -"ZLIS", (bp,"Pcompare_Lt_Gt"); -"ZLII", (bp,"Pcompare_Lt_Lt"); -"ZLSS", (bp,"Pcompare_Gt_Gt"); - (* Pnat *) -"convert_intro", (pn,"nat_of_P_inj"); -"convert_add", (pn,"nat_of_P_plus_morphism"); -"convert_add_un", (pn,"Pmult_nat_succ_morphism"); -"cvt_add_un", (pn,"nat_of_P_succ_morphism"); -"convert_add_carry", (pn,"Pmult_nat_plus_carry_morphism"); -"compare_convert_O", (pn,"lt_O_nat_of_P"); -"add_verif", (pn,"Pmult_nat_l_plus_morphism"); -"ZL2", (pn,"Pmult_nat_r_plus_morphism"); -"compare_positive_to_nat_O", (pn,"le_Pmult_nat"); -(* Trop spécifique ? -"ZL6", (pn,"Pmult_nat_plus_shift_morphism"); -*) -"ZL15", (pn,"Pplus_carry_pred_eq_plus"); -"cvt_carry", (pn,"nat_of_P_plus_carry_morphism"); -"compare_convert1", (pn,"Pcompare_not_Eq"); -"compare_convert_INFERIEUR", (pn,"nat_of_P_lt_Lt_compare_morphism"); -"compare_convert_SUPERIEUR", (pn,"nat_of_P_gt_Gt_compare_morphism"); -"compare_convert_EGAL", (pn,"Pcompare_Eq_eq"); -"convert_compare_INFERIEUR", (pn,"nat_of_P_lt_Lt_compare_complement_morphism"); -"convert_compare_SUPERIEUR", (pn,"nat_of_P_gt_Gt_compare_complement_morphism"); -"convert_compare_EGAL", (pn,"Pcompare_refl"); -"bij1", (pn,"nat_of_P_o_P_of_succ_nat_eq_succ"); -"bij2", (pn,"P_of_succ_nat_o_nat_of_P_eq_succ"); -"bij3", (pn,"pred_o_P_of_succ_nat_o_nat_of_P_eq_id"); - (* Zcompare *) -"Zcompare_EGAL", (zc,"Zcompare_Eq_iff_eq"); -"Zcompare_EGAL_eq", (zc,"Zcompare_Eq_eq"); -"Zcompare_x_x", (zc,"Zcompare_refl"); -"Zcompare_et_un", (zc,"Zcompare_Gt_not_Lt"); -"Zcompare_trans_SUPERIEUR", (zc,"Zcompare_Gt_trans"); -"Zcompare_n_S", (zc,"Zcompare_succ_compat"); -"SUPERIEUR_POS", (zc,"Zcompare_Gt_spec"); -"Zcompare_ANTISYM", (zc,"Zcompare_Gt_Lt_antisym"); -"Zcompare_Zs_SUPERIEUR", (zc,"Zcompare_succ_Gt"); -"Zcompare_Zopp", (zc,"Zcompare_opp"); -"POS_inject", (zn,"Zpos_eq_Z_of_nat_o_nat_of_P"); -"absolu", (bz,"Zabs_nat"); -"absolu_lt", (zabs,"Zabs_nat_lt" (* "Zabs_nat_lt_morphism_pos" ? *)); -"Zeq_add_S", (bz,"Zsucc_inj"); -"Znot_eq_S", (bz,"Zsucc_inj_contrapositive"); -"Zeq_S", (bz,"Zsucc_eq_compat"); -"Zsimpl_plus_l", (bz,"Zplus_reg_l"); -"Zplus_simpl", (bz,"Zplus_eq_compat"); -"POS_gt_ZERO", (zo,"Zgt_pos_0"); -"ZERO_le_POS", (zo,"Zle_0_pos"); -"ZERO_le_inj", (zo,"Zle_0_nat"); -"NEG_lt_ZERO", (zo,"Zlt_neg_0"); -"Zlt_ZERO_pred_le_ZERO", (zo,"Zlt_0_le_0_pred"); -"POS_xI", (bz,"Zpos_xI"); -"POS_xO", (bz,"Zpos_xO"); -"NEG_xI", (bz,"Zneg_xI"); -"NEG_xO", (bz,"Zneg_xO"); -"POS_add", (bz,"Zpos_plus_distr"); -"NEG_add", (bz,"Zneg_plus_distr"); - (* Z Orders *) -"not_Zge", (zo,"Znot_ge_lt"); -"not_Zlt", (zo,"Znot_lt_ge"); -"not_Zle", (zo,"Znot_le_gt"); -"not_Zgt", (zo,"Znot_gt_le"); -"Zgt_not_sym", (zo,"Zgt_asym"); -"Zlt_not_sym", (zo,"Zlt_asym"); -"Zlt_n_n", (zo,"Zlt_irrefl"); -"Zgt_antirefl", (zo,"Zgt_irrefl"); -"Zgt_reg_l", (zo,"Zplus_gt_compat_l"); -"Zgt_reg_r", (zo,"Zplus_gt_compat_r"); -"Zlt_reg_l", (zo,"Zplus_lt_compat_l"); -"Zlt_reg_r", (zo,"Zplus_lt_compat_r"); -"Zle_reg_l", (zo,"Zplus_le_compat_l"); -"Zle_reg_r", (zo,"Zplus_le_compat_r"); -"Zlt_le_reg", (zo,"Zplus_lt_le_compat"); -"Zle_lt_reg", (zo,"Zplus_le_lt_compat"); -"Zle_plus_plus", (zo,"Zplus_le_compat"); -"Zlt_Zplus", (zo,"Zplus_lt_compat"); -"Zle_O_plus", (zo,"Zplus_le_0_compat"); -"Zle_mult_simpl", (zo,"Zmult_le_reg_r"); -"Zge_mult_simpl", (zo,"Zmult_ge_reg_r"); -"Zgt_mult_simpl", (zo,"Zmult_gt_reg_r"); -"Zsimpl_gt_plus_l", (zo,"Zplus_gt_reg_l"); -"Zsimpl_gt_plus_r", (zo,"Zplus_gt_reg_r"); -"Zsimpl_le_plus_l", (zo,"Zplus_le_reg_l"); -"Zsimpl_le_plus_r", (zo,"Zplus_le_reg_r"); -"Zsimpl_lt_plus_l", (zo,"Zplus_lt_reg_l"); -"Zsimpl_lt_plus_r", (zo,"Zplus_lt_reg_r"); -"Zlt_Zmult_right2", (zo,"Zmult_gt_0_lt_reg_r"); -"Zlt_Zmult_right", (zo,"Zmult_gt_0_lt_compat_r"); -"Zle_Zmult_right2", (zo,"Zmult_gt_0_le_reg_r"); -"Zle_Zmult_right", (zo,"Zmult_gt_0_le_compat_r"); -"Zgt_Zmult_right", (zo,"Zmult_gt_compat_r"); -"Zgt_Zmult_left", (zo,"Zmult_gt_compat_l"); -"Zlt_Zmult_left", (zo,"Zmult_gt_0_lt_compat_l"); -"Zcompare_Zmult_right", (zc,"Zmult_compare_compat_r"); -"Zcompare_Zmult_left", (zc,"Zmult_compare_compat_l"); -"Zplus_Zmult_2", (bz,"Zplus_diag_eq_mult_2"); -"Zmult_Sm_n", (bz,"Zmult_succ_l_reverse"); -"Zmult_n_Sm", (bz,"Zmult_succ_r_reverse"); -"Zmult_le", (zo,"Zmult_le_0_reg_r"); -"Zmult_reg_left", (bz,"Zmult_reg_l"); -"Zmult_reg_right", (bz,"Zmult_reg_r"); -"Zle_ZERO_mult", (zo,"Zmult_le_0_compat"); -"Zgt_ZERO_mult", (zo,"Zmult_gt_0_compat"); -"Zle_mult", (zo,"Zmult_gt_0_le_0_compat"); -"Zmult_lt", (zo,"Zmult_gt_0_lt_0_reg_r"); -"Zmult_gt", (zo,"Zmult_gt_0_reg_l"); -"Zle_Zmult_pos_right", (zo,"Zmult_le_compat_r"); -"Zle_Zmult_pos_left", (zo,"Zmult_le_compat_l"); -"Zge_Zmult_pos_right", (zo,"Zmult_ge_compat_r"); -"Zge_Zmult_pos_left", (zo,"Zmult_ge_compat_l"); -"Zge_Zmult_pos_compat", (zo,"Zmult_ge_compat"); -"Zlt_Zcompare", (zo,"Zlt_compare"); -"Zle_Zcompare", (zo,"Zle_compare"); -"Zgt_Zcompare", (zo,"Zgt_compare"); -"Zge_Zcompare", (zo,"Zge_compare"); - (* ex-IntMap *) -"convert_xH", (pn,"nat_of_P_xH"); -"convert_xO", (pn,"nat_of_P_xO"); -"convert_xI", (pn,"nat_of_P_xI"); -"positive_to_nat_mult", (pn,"Pmult_nat_mult_permute"); -"positive_to_nat_2", (pn,"Pmult_nat_2_mult_2_permute"); -"positive_to_nat_4", (pn,"Pmult_nat_4_mult_2_permute"); - (* ZArith and Arith orders *) -"Zle_refl", (zo,"Zeq_le"); -"Zle_n", (zo,"Zle_refl"); -"Zle_trans_S", (zo,"Zle_succ_le"); -"Zgt_trans_S", (zo,"Zge_trans_succ"); -"Zgt_S", (zo,"Zgt_succ_gt_or_eq"); -"Zle_Sn_n", (zo,"Znot_le_succ"); -"Zlt_n_Sn", (zo,"Zlt_succ"); -"Zlt_S", (zo,"Zlt_lt_succ"); -"Zlt_n_S", (zo,"Zsucc_lt_compat"); -"Zle_n_S", (zo,"Zsucc_le_compat"); -"Zgt_n_S", (zo,"Zsucc_gt_compat"); -"Zlt_S_n", (zo,"Zsucc_lt_reg"); -"Zgt_S_n", (zo,"Zsucc_gt_reg"); -"Zle_S_n", (zo,"Zsucc_le_reg"); -"Zle_0_plus", (zo,"Zplus_le_0_compat"); -"Zgt_Sn_n", (zo,"Zgt_succ"); -"Zgt_le_S", (zo,"Zgt_le_succ"); -"Zgt_S_le", (zo,"Zgt_succ_le"); -"Zle_S_gt", (zo,"Zlt_succ_gt"); -"Zle_gt_S", (zo,"Zlt_gt_succ"); -"Zgt_pred", (zo,"Zgt_succ_pred"); -"Zlt_pred", (zo,"Zlt_succ_pred"); -"Zgt0_le_pred", (zo,"Zgt_0_le_0_pred"); -"Z_O_1", (zo,"Zlt_0_1"); -"Zle_NEG_POS", (zo,"Zle_neg_pos"); -"Zle_n_Sn", (zo,"Zle_succ"); -"Zle_pred_n", (zo,"Zle_pred"); -"Zlt_pred_n_n", (zo,"Zlt_pred"); -"Zlt_le_S", (zo,"Zlt_le_succ"); -"Zlt_n_Sm_le", (zo,"Zlt_succ_le"); -"Zle_lt_n_Sm", (zo,"Zle_lt_succ"); -"Zle_le_S", (zo,"Zle_le_succ"); -"Zlt_minus", (zo,"Zlt_minus_simpl_swap"); -"le_trans_S", (le,"le_Sn_le"); -(* Znumtheory *) -"Zdivide_Zmod", ([],"Zdivide_mod"); -"Zmod_Zdivide", ([],"Zmod_divide"); -"Zdivide_mult_left", ([],"Zmult_divide_compat_l"); -"Zdivide_mult_right", ([],"Zmult_divide_compat_r"); -"Zdivide_opp", ([],"Zdivide_opp_r"); -"Zdivide_opp_rev", ([],"Zdivide_opp_r_rev"); -"Zdivide_opp_left", ([],"Zdivide_opp_l"); -"Zdivide_opp_left_rev", ([],"Zdivide_opp_l_rev"); -"Zdivide_right", ([],"Zdivide_mult_r"); -"Zdivide_left", ([],"Zdivide_mult_l"); -"Zdivide_plus", ([],"Zdivide_plus_r"); -"Zdivide_minus", ([],"Zdivide_minus_l"); -"Zdivide_a_ab", ([],"Zdivide_factor_r"); -"Zdivide_a_ba", ([],"Zdivide_factor_l"); -(* Arith *) -(* Peano.v -"plus_n_O", ("plus_0_r_reverse"); -"plus_O_n", ("plus_0_l"); -*) -"plus_assoc_l", (pl,"plus_assoc"); -"plus_assoc_r", (pl,"plus_assoc_reverse"); -"plus_sym", (pl,"plus_comm"); -"mult_sym", (mu,"mult_comm"); -"max_sym", (["Max"],"max_comm"); -"min_sym", (["Min"],"min_comm"); -"gt_not_sym", (gt,"gt_asym"); -"lt_not_sym", (lt,"lt_asym"); -"gt_antirefl", (gt,"gt_irrefl"); -"lt_n_n", (lt,"lt_irrefl"); -(* Trop utilisé dans CoqBook | "le_n" -> "le_refl"*) -"simpl_plus_l", (pl,"plus_reg_l"); -"simpl_plus_r", (pl,"plus_reg_r"); -"fact_growing", (["Factorial"],"fact_le"); -"mult_assoc_l", (mu,"mult_assoc"); -"mult_assoc_r", (mu,"mult_assoc_reverse"); -"mult_plus_distr", (mu,"mult_plus_distr_r"); -"mult_plus_distr_r", (mu,"mult_plus_distr_l"); -"mult_minus_distr", (mu,"mult_minus_distr_r"); -"mult_1_n", (mu,"mult_1_l"); -"mult_n_1", (mu,"mult_1_r"); -(* Peano.v -"mult_n_O", ("mult_O_r_reverse"); -"mult_n_Sm", ("mult_S_r_reverse"); -*) -"mult_le", (mu,"mult_le_compat_l"); -"le_mult_right", (mu,"mult_le_compat_r"); -"le_mult_mult", (mu,"mult_le_compat"); -"mult_lt", (mu,"mult_S_lt_compat_l"); -"lt_mult_right", (mu,"mult_lt_compat_r"); -"mult_le_conv_1", (mu,"mult_S_le_reg_l"); -"exists", (be,"exists_between"); -"IHexists", ([],"IHexists_between"); -(* Peano.v -"pred_Sn", ("pred_S"); -*) -"inj_minus_aux", (mi,"not_le_minus_0"); -"minus_x_x", (mi,"minus_diag"); -"minus_plus_simpl", (mi,"minus_plus_simpl_l_reverse"); -"gt_reg_l", (gt,"plus_gt_compat_l"); -"le_reg_l", (pl,"plus_le_compat_l"); -"le_reg_r", (pl,"plus_le_compat_r"); -"lt_reg_l", (pl,"plus_lt_compat_l"); -"lt_reg_r", (pl,"plus_lt_compat_r"); -"le_plus_plus", (pl,"plus_le_compat"); -"le_lt_plus_plus", (pl,"plus_le_lt_compat"); -"lt_le_plus_plus", (pl,"plus_lt_le_compat"); -"lt_plus_plus", (pl,"plus_lt_compat"); -"plus_simpl_l", (pl,"plus_reg_l"); -"simpl_gt_plus_l", (pl,"plus_gt_reg_l"); -"simpl_le_plus_l", (pl,"plus_le_reg_l"); -"simpl_lt_plus_l", (pl,"plus_lt_reg_l"); -(* Noms sur le principe de ceux de Z -"le_n_S", ("S_le_compat"); -"le_n_Sn", ("le_S"); -(*"le_O_n", ("??" *)); -"le_pred_n", ("le_pred"); -"le_trans_S", ("le_S_le"); -"le_S_n", ("S_le_reg"); -"le_Sn_O", ("not_le_S_O"); -"le_Sn_n", ("not_le_S"); -*) - (* Init *) -"IF", (lo,"IF_then_else"); - (* Lists *) -"idempot_rev", (["List"],"rev_involutive"); -"forall", (["Streams"],"HereAndFurther"); - (* Bool *) -"orb_sym", (bo,"orb_comm"); -"andb_sym", (bo,"andb_comm"); - (* Ring *) -"SR_plus_sym", (["Ring_theory"],"SR_plus_comm"); -"SR_mult_sym", (["Ring_theory"],"SR_mult_comm"); -"Th_plus_sym", (["Ring_theory"],"Th_plus_comm"); -"Th_mul_sym", (["Ring_theory"],"Th_mult_comm"); -"SSR_plus_sym", (["Setoid_ring_theory"],"SSR_plus_comm"); -"SSR_mult_sym", (["Setoid_ring_theory"],"SSR_mult_comm"); -"STh_plus_sym", (["Setoid_ring_theory"],"STh_plus_comm"); -"STh_mul_sym", (["Setoid_ring_theory"],"STh_mult_comm"); - (* Reals *) -(* -"Rabsolu", ("Rabs"); -"Rabsolu_pos_lt", ("Rabs_pos_lt"); -"Rabsolu_no_R0", ("Rabs_no_R0"); -"Rabsolu_Rabsolu", ("Rabs_Rabs"); -"Rabsolu_mult", ("Rabs_mult"); -"Rabsolu_triang", ("Rabs_triang"); -"Rabsolu_Ropp", ("Rabs_Ropp"); -"Rabsolu_right", ("Rabs_right"); -... -"case_Rabsolu", ("case_Rabs"); -"Pow_Rabsolu", ("Pow_Rabs"); -... -*) -(* Raxioms *) -"complet", ([],"completeness"); -"complet_weak", ([],"completeness_weak"); -"Rle_sym1", ([],"Rle_ge"); -"Rmin_sym", ([],"Rmin_comm"); -"Rplus_sym", ([],"Rplus_comm"); -"Rmult_sym", ([],"Rmult_comm"); -"Rsqr_times", ([],"Rsqr_mult"); -"sqrt_times", ([],"sqrt_mult"); -"Rmult_1l", ([],"Rmult_1_l"); -"Rplus_Ol", ([],"Rplus_0_l"); -"Rplus_Ropp_r", ([],"Rplus_opp_r"); -"Rmult_Rplus_distr", ([],"Rmult_plus_distr_l"); -"Rlt_antisym", ([],"Rlt_asym"); -(* RIneq *) -"Rlt_antirefl", ([],"Rlt_irrefl"); -"Rlt_compatibility", ([],"Rplus_lt_compat_l"); -"Rgt_plus_plus_r", ([],"Rplus_gt_compat_l"); -"Rgt_r_plus_plus", ([],"Rplus_gt_reg_l"); -"Rge_plus_plus_r", ([],"Rplus_ge_compat_l"); -"Rge_r_plus_plus", ([],"Rplus_ge_reg_l"); -(* Si on en change un, il faut changer tous les autres R*_monotony *) -"Rlt_monotony", ([],"Rmult_lt_compat_l"); -"Rlt_monotony_r", ([],"Rmult_lt_compat_r"); -"Rlt_monotony_contra", ([],"Rmult_lt_reg_l"); -(*"Rlt_monotony_rev", ([],"Rmult_lt_reg_l");*) -"Rlt_anti_monotony", ([],"Rmult_lt_gt_compat_neg_l"); -"Rle_monotony", ([],"Rmult_le_compat_l"); -"Rle_monotony_r", ([],"Rmult_le_compat_r"); -"Rle_monotony_contra", ([],"Rmult_le_reg_l"); -"Rle_anti_monotony1", ([],"Rmult_le_compat_neg_l"); -"Rle_anti_monotony", ([],"Rmult_le_ge_compat_neg_l"); -"Rge_monotony", ([],"Rmult_ge_compat_r"); -"Rge_ge_eq", ([],"Rge_antisym"); -(* Le reste de RIneq *) -"imp_not_Req", ([],"Rlt_dichotomy_converse"); -"Req_EM", ([],"Req_dec"); -"total_order", ([],"Rtotal_order"); -"not_Req", ([],"Rdichotomy"); -(* "Rlt_le" -> c dir,"Rlt_le_weak" ? *) -"not_Rle", ([],"Rnot_le_lt"); -"not_Rge", ([],"Rnot_ge_lt"); -"Rlt_le_not", ([],"Rlt_not_le"); -"Rle_not", ([],"Rgt_not_le"); -"Rle_not_lt", ([],"Rle_not_lt"); -"Rlt_ge_not", ([],"Rlt_not_ge"); -"eq_Rle", ([],"Req_le"); -"eq_Rge", ([],"Req_ge"); -"eq_Rle_sym", ([],"Req_le_sym"); -"eq_Rge_sym", ([],"Req_ge_sym"); -(* "Rle_le_eq" -> ? x<=y/\y<=x <-> x=y *) -"Rlt_rew", ([],"Rlt_eq_compat"); -"total_order_Rlt", ([],"Rlt_dec"); -"total_order_Rle", ([],"Rle_dec"); -"total_order_Rgt", ([],"Rgt_dec"); -"total_order_Rge", ([],"Rge_dec"); -"total_order_Rlt_Rle", ([],"Rlt_le_dec"); -(* "Rle_or_lt" -> c dir,"Rle_or_lt"*) -"total_order_Rle_Rlt_eq", ([],"Rle_lt_or_eq_dec"); -(* "inser_trans_R" -> c dir,"Rle_lt_inser_trans" ?*) -(* "Rplus_ne" -> c dir,"Rplus_0_r_l" ? *) -"Rplus_Or", ([],"Rplus_0_r"); -"Rplus_Ropp_l", ([],"Rplus_opp_l"); -"Rplus_Ropp", ([],"Rplus_opp_r_uniq"); -"Rplus_plus_r", ([],"Rplus_eq_compat_l"); -"r_Rplus_plus", ([],"Rplus_eq_reg_l"); -"Rplus_ne_i", ([],"Rplus_0_r_uniq"); -"Rmult_Or", ([],"Rmult_0_r"); -"Rmult_Ol", ([],"Rmult_0_l"); -(* "Rmult_ne" -> c dir,"Rmult_1_l_r" ? *) -"Rmult_1r", ([],"Rmult_1_r"); -"Rmult_mult_r", ([],"Rmult_eq_compat_l"); -"r_Rmult_mult", ([],"Rmult_eq_reg_l"); -"without_div_Od", ([],"Rmult_integral"); -"without_div_Oi", ([],"Rmult_eq_0_compat"); -"without_div_Oi1", ([],"Rmult_eq_0_compat_r"); -"without_div_Oi2", ([],"Rmult_eq_0_compat_l"); -"without_div_O_contr", ([],"Rmult_neq_0_reg"); -"mult_non_zero", ([],"Rmult_integral_contrapositive"); -"Rmult_Rplus_distrl", ([],"Rmult_plus_distr_r"); -"Rsqr_O", ([],"Rsqr_0"); -"Rsqr_r_R0", ([],"Rsqr_0_uniq"); -"eq_Ropp", ([],"Ropp_eq_compat"); -"Ropp_O", ([],"Ropp_0"); -"eq_RoppO", ([],"Ropp_eq_0_compat"); -"Ropp_Ropp", ([],"Ropp_involutive"); -"Ropp_neq", ([],"Ropp_neq_0_compat"); -"Ropp_distr1", ([],"Ropp_plus_distr"); -"Ropp_mul1", ([],"Ropp_mult_distr_l_reverse"); -"Ropp_mul2", ([],"Rmult_opp_opp"); -"Ropp_mul3", ([],"Ropp_mult_distr_r_reverse"); -"minus_R0", ([],"Rminus_0_r"); -"Rminus_Ropp", ([],"Rminus_0_l"); -"Ropp_distr2", ([],"Ropp_minus_distr"); -"Ropp_distr3", ([],"Ropp_minus_distr'"); -"eq_Rminus", ([],"Rminus_diag_eq"); -"Rminus_eq", ([],"Rminus_diag_uniq"); -"Rminus_eq_right", ([],"Rminus_diag_uniq_sym"); -"Rplus_Rminus", ([],"Rplus_minus"); -(* -"Rminus_eq_contra", ([],"Rminus_diag_neq"); -"Rminus_not_eq", ([],"Rminus_neq_diag_sym"); - "Rminus_not_eq_right" -> ? -*) -"Rminus_distr", ([],"Rmult_minus_distr_l"); -"Rinv_R1", ([],"Rinv_1"); -"Rinv_neq_R0", ([],"Rinv_neq_0_compat"); -"Rinv_Rinv", ([],"Rinv_involutive"); -"Rinv_Rmult", ([],"Rinv_mult_distr"); -"Ropp_Rinv", ([],"Ropp_inv_permute"); -(* "Rinv_r_simpl_r" -> OK ? *) -(* "Rinv_r_simpl_l" -> OK ? *) -(* "Rinv_r_simpl_m" -> OK ? *) -"Rinv_Rmult_simpl", ([],"Rinv_mult_simpl"); (* ? *) -"Rlt_compatibility_r", ([],"Rplus_lt_compat_r"); -"Rlt_anti_compatibility", ([],"Rplus_lt_reg_r"); -"Rle_compatibility", ([],"Rplus_le_compat_l"); -"Rle_compatibility_r", ([],"Rplus_le_compat_r"); -"Rle_anti_compatibility", ([],"Rplus_le_reg_l"); -(* "sum_inequa_Rle_lt" -> ? *) -"Rplus_lt", ([],"Rplus_lt_compat"); -"Rplus_le", ([],"Rplus_le_compat"); -"Rplus_lt_le_lt", ([],"Rplus_lt_le_compat"); -"Rplus_le_lt_lt", ([],"Rplus_le_lt_compat"); -"Rgt_Ropp", ([],"Ropp_gt_lt_contravar"); -"Rlt_Ropp", ([],"Ropp_lt_gt_contravar"); -"Ropp_Rlt", ([],"Ropp_lt_cancel"); (* ?? *) -"Rlt_Ropp1", ([],"Ropp_lt_contravar"); -"Rle_Ropp", ([],"Ropp_le_ge_contravar"); -"Ropp_Rle", ([],"Ropp_le_cancel"); -"Rle_Ropp1", ([],"Ropp_le_contravar"); -"Rge_Ropp", ([],"Ropp_ge_le_contravar"); -"Rlt_RO_Ropp", ([],"Ropp_0_lt_gt_contravar"); -"Rgt_RO_Ropp", ([],"Ropp_0_gt_lt_contravar"); -"Rle_RO_Ropp", ([],"Ropp_0_le_ge_contravar"); -"Rge_RO_Ropp", ([],"Ropp_0_ge_le_contravar"); -(* ... cf plus haut pour les lemmes intermediaires *) -"Rle_Rmult_comp", ([],"Rmult_le_compat"); - (* Expliciter que la contrainte est r2>0 dans r1<r2 et non 0<r1 ce - qui est plus général mais différent de Rmult_le_compat ? *) -"Rmult_lt", ([],"Rmult_gt_0_lt_compat"); (* Hybride aussi *) -"Rmult_lt_0", ([],"Rmult_ge_0_gt_0_lt_compat"); (* Un truc hybride *) -(* - "Rlt_minus" -> - "Rle_minus" -> - "Rminus_lt" -> - "Rminus_le" -> - "tech_Rplus" -> -*) -"pos_Rsqr", ([],"Rle_0_sqr"); -"pos_Rsqr1", ([],"Rlt_0_sqr"); -"Rlt_R0_R1", ([],"Rlt_0_1"); -"Rle_R0_R1", ([],"Rle_0_1"); -"Rlt_Rinv", ([],"Rinv_0_lt_compat"); -"Rlt_Rinv2", ([],"Rinv_lt_0_compat"); -"Rinv_lt", ([],"Rinv_lt_contravar"); -"Rlt_Rinv_R1", ([],"Rinv_1_lt_contravar"); -"Rlt_not_ge", ([],"Rnot_lt_ge"); -"Rgt_not_le", ([],"Rnot_gt_le"); -(* - "Rgt_ge" -> "Rgt_ge_weak" ? -*) -"Rlt_sym", ([],"Rlt_gt_iff"); -(* | "Rle_sym1" -> c dir,"Rle_ge" OK *) -"Rle_sym2", ([],"Rge_le"); -"Rle_sym", ([],"Rle_ge_iff"); -(* - "Rge_gt_trans" -> OK - "Rgt_ge_trans" -> OK - "Rgt_trans" -> OK - "Rge_trans" -> OK -*) -"Rgt_RoppO", ([],"Ropp_lt_gt_0_contravar"); -"Rlt_RoppO", ([],"Ropp_gt_lt_0_contravar"); -"Rlt_r_plus_R1", ([],"Rle_lt_0_plus_1"); -"Rlt_r_r_plus_R1", ([],"Rlt_plus_1"); -(* "tech_Rgt_minus" -> ? *) -(* OK, cf plus haut -"Rgt_r_plus_plus", ([],"Rplus_gt_reg_l"); -"Rgt_plus_plus_r", ([],"Rplus_gt_compat_l"); -"Rge_plus_plus_r", ([],"Rplus_ge_compat_l"); -"Rge_r_plus_plus", ([],"Rplus_ge_reg_l"); -"Rge_monotony" -> *) -(* - "Rgt_minus" -> - "minus_Rgt" -> - "Rge_minus" -> - "minus_Rge" -> -*) -"Rmult_gt", ([],"Rmult_gt_0_compat"); -"Rmult_lt_pos", ([],"Rmult_lt_0_compat"); (* lt_0 ou 0_lt ?? *) -"Rplus_eq_R0_l", ([],"Rplus_eq_0_l"); (* ? *) -"Rplus_eq_R0", ([],"Rplus_eq_R0"); -"Rplus_Rsr_eq_R0_l", ([],"Rplus_sqr_eq_0_l"); -"Rplus_Rsr_eq_R0", ([],"Rplus_sqr_eq_0"); -(* - "S_INR" -> - "S_O_plus_INR" -> - "plus_INR" -> - "minus_INR" -> - "mult_INR" -> - "lt_INR_0" -> - "lt_INR" -> - "INR_lt_1" -> - "INR_pos" -> - "pos_INR" -> - "INR_lt" -> - "le_INR" -> - "not_INR_O" -> - "not_O_INR" -> - "not_nm_INR" -> - "INR_eq" -> - "INR_le" -> - "not_1_INR" -> - "IZN" -> - "INR_IZR_INZ" -> - "plus_IZR_NEG_POS" -> - "plus_IZR" -> - "mult_IZR" -> - "Ropp_Ropp_IZR" -> - "Z_R_minus" -> - "lt_O_IZR" -> - "lt_IZR" -> - "eq_IZR_R0" -> - "eq_IZR" -> - "not_O_IZR" -> - "le_O_IZR" -> - "le_IZR" -> - "le_IZR_R1" -> - "IZR_ge" -> - "IZR_le" -> - "IZR_lt" -> - "one_IZR_lt1" -> - "one_IZR_r_R1" -> - "single_z_r_R1" -> - "tech_single_z_r_R1" -> - "prod_neq_R0" -> - "Rmult_le_pos" -> - "double" -> - "double_var" -> -*) -"gt0_plus_gt0_is_gt0", ([],"Rplus_lt_0_compat"); -"ge0_plus_gt0_is_gt0", ([],"Rplus_le_lt_0_compat"); -"gt0_plus_ge0_is_gt0", ([],"Rplus_lt_le_0_compat"); -"ge0_plus_ge0_is_ge0", ([],"Rplus_le_le_0_compat"); -(* - "plus_le_is_le" -> ? - "plus_lt_is_lt" -> ? -*) -"Rmult_lt2", ([],"Rmult_le_0_lt_compat"); -(* "Rge_ge_eq" -> c dir,"Rge_antisym" OK *) -] - -let translate_v7_string dir s = - try - let d,s' = List.assoc s translation_table in - (if d=[] then c dir else d),s' - with Not_found -> - (* Special cases *) - match s with - (* Init *) - | "relation" when is_module "Datatypes" or is_dir dir "Datatypes" - -> da,"comparison" - | "Op" when is_module "Datatypes" or is_dir dir "Datatypes" - -> da,"CompOpp" - (* BinPos *) - | "times" when not (is_module "Mapfold") -> bp,"Pmult" - (* Reals *) - | s when String.length s >= 7 & (String.sub s 0 7 = "Rabsolu") -> - c dir, - "Rabs"^(String.sub s 7 (String.length s - 7)) - | s when String.length s >= 7 & - (String.sub s (String.length s - 7) 7 = "Rabsolu") -> c dir, - "R"^(String.sub s 0 (String.length s - 7))^"abs" - | s when String.length s >= 7 & - let s' = String.sub s 0 7 in - (s' = "unicite" or s' = "unicity") -> c dir, - "uniqueness"^(String.sub s 7 (String.length s - 7)) - | s when String.length s >= 3 & - let s' = String.sub s 0 3 in - s' = "gcd" -> c dir, "Zis_gcd"^(String.sub s 3 (String.length s - 3)) - (* Default *) - | x -> [],x - - -let id_of_v7_string s = - id_of_string (if !Options.v7 then s else snd (translate_v7_string empty_dirpath s)) - -let v7_to_v8_dir_id dir id = - if Options.do_translate() then - let s = string_of_id id in - let dir',s = - if (is_coq_root (Lib.library_dp()) or is_coq_root dir) - then translate_v7_string dir s else [], s in - dir',id_of_string (translate_ident_string s) - else [],id - -let v7_to_v8_id id = snd (v7_to_v8_dir_id empty_dirpath id) - -let short_names = - List.map (fun x -> snd (snd x)) translation_table - -let is_new_name s = - Options.do_translate () & - (List.mem s short_names or - s = "comparison" or s = "CompOpp" or s = "Pmult" or - (String.length s >= 4 & String.sub s 0 4 = "Rabs") or - (String.length s >= 4 & String.sub s (String.length s - 3) 3 = "abs" - & s.[0] = 'R') or - (String.length s >= 10 & String.sub s 0 10 = "uniqueness")) - -let v7_to_v8_dir fulldir dir = - if Options.do_translate () & dir <> empty_dirpath then - let update s = - let l = List.map string_of_id (repr_dirpath dir) in - make_dirpath (List.map id_of_string (s :: List.tl l)) - in - let l = List.map string_of_id (repr_dirpath fulldir) in - if l = [ "List"; "Lists"; "Coq" ] then update "MonoList" - else if l = [ "PolyList"; "Lists"; "Coq" ] then update "List" - else dir - else dir - -let shortest_qualid_of_v7_global ctx ref = - let fulldir,_ = repr_path (sp_of_global ref) in - let dir,id = repr_qualid (shortest_qualid_of_global ctx ref) in - let dir',id = v7_to_v8_dir_id fulldir id in - let dir'' = - if dir' = [] then - (* A name that is not renamed *) - if dir = empty_dirpath & is_new_name (string_of_id id) - then - (* An unqualified name that is not renamed but which coincides *) - (* with a new name: force qualification unless it is a variable *) - if fulldir <> empty_dirpath & not (is_coq_root fulldir) - then make_dirpath [List.hd (repr_dirpath fulldir)] - else empty_dirpath - else v7_to_v8_dir fulldir dir - else - (* A stdlib name that has been renamed *) - try - let d,_ = repr_path (Nametab.full_name_cci (make_short_qualid id)) in - if not (is_coq_root d) then - (* The user has defined id, then we qualify the new name *) - v7_to_v8_dir fulldir (make_dirpath (List.map id_of_string dir')) - else empty_dirpath - with Not_found -> v7_to_v8_dir fulldir dir in - make_qualid dir'' id - let extern_reference loc vars r = - try Qualid (loc,shortest_qualid_of_v7_global vars r) + try Qualid (loc,shortest_qualid_of_global vars r) with Not_found -> (* happens in debugger *) Ident (loc,id_of_string (raw_string_of_ref r)) @@ -1046,9 +183,6 @@ let rec check_same_type ty1 ty2 = List.iter2 (fun (_,pl1,r1) (_,pl2,r2) -> List.iter2 check_same_pattern pl1 pl2; check_same_type r1 r2) brl1 brl2 - | COrderedCase(_,_,_,a1,bl1), COrderedCase(_,_,_,a2,bl2) -> - check_same_type a1 a2; - List.iter2 check_same_type bl1 bl2 | CHole _, CHole _ -> () | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> () | CSort(_,s1), CSort(_,s2) when s1=s2 -> () @@ -1118,7 +252,7 @@ let rec same_raw c d = same_raw t1 t2; same_raw m1 m2 | RCases(_,_,c1,b1), RCases(_,_,c2,b2) -> List.iter2 - (fun (t1,{contents=(al1,oind1)}) (t2,{contents=(al2,oind2)}) -> + (fun (t1,(al1,oind1)) (t2,(al2,oind2)) -> same_raw t1 t2; if al1 <> al2 then failwith "RCases"; option_iter2(fun (_,i1,nl1) (_,i2,nl2) -> @@ -1126,9 +260,6 @@ let rec same_raw c d = List.iter2 (fun (_,_,pl1,b1) (_,_,pl2,b2) -> List.iter2 same_patt pl1 pl2; same_raw b1 b2) b1 b2 - | ROrderedCase(_,_,_,c1,v1,_), ROrderedCase(_,_,_,c2,v2,_) -> - same_raw c1 c2; - array_iter2 same_raw v1 v2 | RLetTuple(_,nl1,_,b1,c1), RLetTuple(_,nl2,_,b2,c2) -> if nl1<>nl2 then failwith "RLetTuple"; same_raw b1 b2; @@ -1213,33 +344,6 @@ let make_pat_notation loc ntn l = | _ -> CPatNotation (loc,ntn,l) -(* -let rec cases_pattern_expr_of_constr_expr = function - | CRef r -> CPatAtom (dummy_loc,Some r) - | CHole loc -> CPatAtom (loc,None) - | CApp (loc,(proj,CRef c),l) when proj = None -> - let l,e = List.split l in - if not (List.for_all ((=) None) e) then - anomaly "Unexpected explicitation in pattern"; - CPatCstr (loc,c,List.map cases_pattern_expr_of_constr_expr l) - | CNotation (loc,ntn,l) -> - CPatNotation (loc,ntn,List.map cases_pattern_expr_of_constr_expr l) - | CNumeral (loc,n) -> CPatNumeral (loc,n) - | CDelimiters (loc,s,e) -> - CPatDelimiters (loc,s,cases_pattern_expr_of_constr_expr e) - | _ -> anomaly "Constrextern: not a pattern" - -let rec rawconstr_of_cases_pattern = function - | PatVar (loc,Name id) -> RVar (loc,id) - | PatVar (loc,Anonymous) -> RHole (loc,Evd.InternalHole) - | PatCstr (loc,(ind,_ as c),args,_) -> - let nparams = (snd (Global.lookup_inductive ind)).Declarations.mind_nparams in - let params = list_tabulate (fun _ -> RHole (loc,Evd.InternalHole)) nparams in - let args = params @ List.map rawconstr_of_cases_pattern args in - let f = RRef (loc,ConstructRef c) in - if args = [] then f else RApp (loc,f,args) -*) - let bind_env sigma var v = try let vvar = List.assoc var sigma in @@ -1294,14 +398,14 @@ let rec extern_cases_pattern_in_scope scopes vars pat = (Notation.uninterp_cases_pattern_notations pat) with No_match -> match pat with - | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,v7_to_v8_id id))) + | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) | PatVar (loc,Anonymous) -> CPatAtom (loc, None) | PatCstr(loc,cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope scopes vars) args in let p = CPatCstr (loc,extern_reference loc vars (ConstructRef cstrsp),args) in (match na with - | Name id -> CPatAlias (loc,p,v7_to_v8_id id) + | Name id -> CPatAlias (loc,p,id) | Anonymous -> p) and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function @@ -1354,24 +458,6 @@ let is_projection nargs = function with Not_found -> None) | _ -> None -let is_nil = function - | [CRef ref] -> snd (repr_qualid (snd (qualid_of_reference ref))) = id_of_string "nil" - | _ -> false - -let stdlib_but_length args = function - | Some r -> - let dir,id = repr_path (sp_of_global r) in - (is_coq_root (Lib.library_dp()) or is_coq_root dir) - && not (List.mem (string_of_id id) ["Zlength";"length"] && is_nil args) - && not (List.mem (string_of_id id) ["In"] && List.length args >= 2 - && is_nil (List.tl args)) - | None -> false - -let explicit_code imp q = - dummy_loc, - if !Options.v7 & not (Options.do_translate()) then ExplByPos q - else ExplByName (name_of_implicit imp) - let is_hole = function CHole _ -> true | _ -> false let is_significant_implicit a impl tail = @@ -1388,10 +474,12 @@ let explicitize loc inctx impl (cf,f) args = !Options.raw_print or (!print_implicits & !print_implicits_explicit_args) or (is_significant_implicit a impl tail & - (not (is_inferable_implicit inctx n imp) or - (Options.do_translate() & not (stdlib_but_length args cf)))) + (not (is_inferable_implicit inctx n imp))) in - if visible then (a,Some (explicit_code imp q)) :: tail else tail + if visible then + (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail + else + tail | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) | [], _ -> [] in @@ -1511,10 +599,10 @@ let rec extern inctx scopes vars r = extern_symbol scopes vars r (Notation.uninterp_notations r) with No_match -> match r with | RRef (loc,ref) -> - extern_global loc (implicits_of_global_out ref) + extern_global loc (implicits_of_global ref) (extern_reference loc vars ref) - | RVar (loc,id) -> CRef (Ident (loc,v7_to_v8_id id)) + | RVar (loc,id) -> CRef (Ident (loc,id)) | REvar (loc,n,_) -> (* we drop args *) extern_evar loc n @@ -1526,14 +614,9 @@ let rec extern inctx scopes vars r = let subscopes = Notation.find_arguments_scope ref in let args = extern_args (extern true) (snd scopes) vars args subscopes in - extern_app loc inctx (implicits_of_global_out ref) + extern_app loc inctx (implicits_of_global ref) (Some ref,extern_reference rloc vars ref) args - | RVar (rloc,id) -> (* useful for translation of inductive *) - let args = List.map (sub_extern true scopes vars) args in - extern_app loc inctx (get_temporary_implicits_out id) - (None,Ident (rloc,v7_to_v8_id id)) - args | _ -> explicitize loc inctx [] (None,sub_extern false scopes vars f) (List.map (sub_extern true scopes vars) args)) @@ -1543,7 +626,6 @@ let rec extern inctx scopes vars r = CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c) | RLetIn (loc,na,t,c) -> - let na = name_app translate_ident na in CLetIn (loc,(loc,na),sub_extern false scopes vars t, extern inctx scopes (add_vname vars na) c) @@ -1557,16 +639,15 @@ let rec extern inctx scopes vars r = let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) t c in CLambdaN (loc,[(dummy_loc,na)::idl,t],c) - | RCases (loc,(typopt,rtntypopt),tml,eqns) -> - let pred = option_app (extern_typ scopes vars) typopt in + | RCases (loc,rtntypopt,tml,eqns) -> let vars' = List.fold_right (name_fold Idset.add) (cases_predicate_names tml) vars in - let rtntypopt' = option_app (extern_typ scopes vars') !rtntypopt in - let tml = List.map (fun (tm,{contents=(na,x)}) -> + let rtntypopt' = option_app (extern_typ scopes vars') rtntypopt in + let tml = List.map (fun (tm,(na,x)) -> let na' = match na,tm with Anonymous, RVar (_,id) when - !rtntypopt<>None & occur_rawconstr id (out_some !rtntypopt) + rtntypopt<>None & occur_rawconstr id (out_some rtntypopt) -> Some Anonymous | Anonymous, _ -> None | Name id, RVar (_,id') when id=id' -> None @@ -1578,31 +659,8 @@ let rec extern inctx scopes vars r = | Name id -> RVar (dummy_loc,id)) nal in let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),args) in (extern_typ scopes vars t)) x))) tml in - let eqns = List.map (extern_eqn (typopt<>None) scopes vars) eqns in - CCases (loc,(pred,rtntypopt'),tml,eqns) - - | ROrderedCase (loc,cs,typopt,tm,bv,{contents = Some x}) -> - extern false scopes vars x - - | ROrderedCase (loc,IfStyle,typopt,tm,bv,_) when Options.do_translate () -> - let rec strip_branches = function - | (RLambda (_,_,_,c1), RLambda (_,_,_,c2)) -> strip_branches (c1,c2) - | x -> x in - let c1,c2 = strip_branches (bv.(0),bv.(1)) in - msgerrnl (str "Warning: unable to ensure the correctness of the translation of an if-then-else"); - let bv = Array.map (sub_extern (typopt<>None) scopes vars) [|c1;c2|] in - COrderedCase - (loc,IfStyle,option_app (extern_typ scopes vars) typopt, - sub_extern false scopes vars tm,Array.to_list bv) - (* We failed type-checking If and to translate it to CIf *) - (* try to remove the dependances in branches anyway *) - - - | ROrderedCase (loc,cs,typopt,tm,bv,_) -> - let bv = Array.map (sub_extern (typopt<>None) scopes vars) bv in - COrderedCase - (loc,cs,option_app (extern_typ scopes vars) typopt, - sub_extern false scopes vars tm,Array.to_list bv) + let eqns = List.map (extern_eqn (rtntypopt<>None) scopes vars) eqns in + CCases (loc,rtntypopt',tml,eqns) | RLetTuple (loc,nal,(na,typopt),tm,b) -> CLetTuple (loc,nal, @@ -1670,8 +728,7 @@ and factorize_prod scopes vars aty = function | RProd (loc,(Name id as na),ty,c) when same aty (extern_typ scopes vars (anonymize_if_reserved na ty)) & not (occur_var_constr_expr id aty) (* avoid na in ty escapes scope *) - -> let id = translate_ident id in - let (nal,c) = factorize_prod scopes (Idset.add id vars) aty c in + -> let (nal,c) = factorize_prod scopes (Idset.add id vars) aty c in ((loc,Name id)::nal,c) | c -> ([],extern_typ scopes vars c) @@ -1679,8 +736,7 @@ and factorize_lambda inctx scopes vars aty = function | RLambda (loc,na,ty,c) when same aty (extern_typ scopes vars (anonymize_if_reserved na ty)) & not (occur_name na aty) (* To avoid na in ty' escapes scope *) - -> let na = name_app translate_ident na in - let (nal,c) = + -> let (nal,c) = factorize_lambda inctx scopes (add_vname vars na) aty c in ((loc,na)::nal,c) | c -> ([],sub_extern inctx scopes vars c) @@ -1688,14 +744,12 @@ and factorize_lambda inctx scopes vars aty = function and extern_local_binder scopes vars = function [] -> ([],[]) | (na,Some bd,ty)::l -> - let na = name_app translate_ident na in let (ids,l) = extern_local_binder scopes (name_fold Idset.add na vars) l in (na::ids, LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l) | (na,None,ty)::l -> - let na = name_app translate_ident na in let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in (match extern_local_binder scopes (name_fold Idset.add na vars) l with (ids,LocalRawAssum(nal,ty')::l) @@ -1815,12 +869,10 @@ let rec raw_of_pat tenv env = function RLetIn (loc,na,raw_of_pat tenv env t, raw_of_pat tenv (na::env) c) | PLambda (na,t,c) -> RLambda (loc,na,raw_of_pat tenv env t, raw_of_pat tenv (na::env) c) - | PCase ((_,(IfStyle|LetStyle as cs)),typopt,tm,bv) -> - ROrderedCase (loc,cs,option_app (raw_of_pat tenv env) typopt, - raw_of_pat tenv env tm,Array.map (raw_of_pat tenv env) bv, ref None) | PCase ((_,cs),typopt,tm,[||]) -> - RCases (loc,(option_app (raw_of_pat tenv env) typopt,ref None (* TODO *)), - [raw_of_pat tenv env tm,ref (Anonymous,None)],[]) + if typopt <> None then failwith "TODO: PCase to RCases"; + RCases (loc,(*(option_app (raw_of_pat tenv env) typopt,*)None, + [raw_of_pat tenv env tm,(Anonymous,None)],[]) | PCase ((Some ind,cs),typopt,tm,bv) -> let avoid = List.fold_right (name_fold (fun x l -> x::l)) env [] in let k = (snd (lookup_mind_specif (Global.env()) ind)).Declarations.mind_nrealargs in diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 059b13c57..e97d778c3 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -24,9 +24,6 @@ open Notation (*i*) (* v7->v8 translation *) -val id_of_v7_string : string -> identifier -val v7_to_v8_id : identifier -> identifier (* v7->v8 translation *) -val shortest_qualid_of_v7_global : Idset.t -> global_reference -> qualid val check_same_type : constr_expr -> constr_expr -> unit (* Translation of pattern, cases pattern, rawterm and term into syntax @@ -72,7 +69,3 @@ val without_symbols : ('a -> 'b) -> 'a -> 'b (* This prints metas as anonymous holes *) val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b - -(* For v8 translation *) -val set_temporary_implicits_out : - (identifier * Impargs.implicits_list) list -> unit diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 0795009b6..e81295214 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -42,10 +42,6 @@ let for_grammar f x = let variables_bind = ref false -(* For the translator *) -let temporary_implicits_in = ref [] -let set_temporary_implicits_in l = temporary_implicits_in := l - (**********************************************************************) (* Internalisation errors *) @@ -254,8 +250,7 @@ let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id = let l,impl,argsc = List.assoc id impls in let l = List.map (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in - RVar (loc,id), impl, argsc, - (if !Options.v7 & !interning_grammar then [] else l) + RVar (loc,id), impl, argsc, l 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 @@ -318,13 +313,6 @@ let intern_reference env lvar = function | Qualid (loc, qid) -> find_appl_head_data lvar (intern_qualid loc qid) | Ident (loc, id) -> - (* For old ast syntax compatibility *) - if (string_of_id id).[0] = '$' then RVar (loc,id),[],[],[] else - (* End old ast syntax compatibility *) - (* Pour traduction des implicites d'inductifs et points-fixes *) - try RVar (loc,id), List.assoc id !temporary_implicits_in, [], [] - with Not_found -> - (* Fin pour traduction *) try intern_var env lvar loc id with Not_found -> try find_appl_head_data lvar (intern_qualid loc (make_short_qualid id)) @@ -665,8 +653,7 @@ let check_projection isproj nargs r = | _, None -> () let get_implicit_name n imps = - if !Options.v7 then None - else Some (Impargs.name_of_implicit (List.nth imps (n-1))) + Some (Impargs.name_of_implicit (List.nth imps (n-1))) let set_hole_implicit i = function | RRef (loc,r) -> (loc,Evd.ImplicitArg (r,i)) @@ -884,21 +871,15 @@ let internalise sigma env allow_soapp lvar c = (* Now compact "(f args') args" *) | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args) | _ -> RApp (loc, c, args)) - | CCases (loc, (po,rtnpo), tms, eqns) -> + | CCases (loc, rtnpo, tms, eqns) -> let tms,env' = List.fold_right (fun citm (inds,env) -> let (tm,ind),nal = intern_case_item env citm in - (tm,ref ind)::inds,List.fold_left (push_name_env lvar) env nal) + (tm,ind)::inds,List.fold_left (push_name_env lvar) env nal) tms ([],env) in let rtnpo = option_app (intern_type env') rtnpo in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in - RCases (loc, (option_app (intern_type env) po, ref rtnpo), tms, - List.flatten eqns') - | COrderedCase (loc, tag, po, c, cl) -> - let env = reset_tmp_scope env in - ROrderedCase (loc, tag, option_app (intern_type env) po, - intern env c, - Array.of_list (List.map (intern env) cl),ref None) + RCases (loc, rtnpo, tms, List.flatten eqns') | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in @@ -916,13 +897,8 @@ let internalise sigma env allow_soapp lvar c = RHole (loc, Evd.QuestionMark) | CPatVar (loc, n) when allow_soapp -> RPatVar (loc, n) - | CPatVar (loc, (false,n)) when Options.do_translate () -> - RVar (loc, n) | CPatVar (loc, (false,n)) -> - if List.mem n (fst (let (a,_,_,_) = lvar in a)) & !Options.v7 then - RVar (loc, n) - else - error_unbound_patvar loc n + error_unbound_patvar loc n | CPatVar (loc, _) -> raise (InternalisationError (loc,NegativeMetavariable)) | CEvar (loc, n) -> @@ -986,7 +962,7 @@ let internalise sigma env allow_soapp lvar c = | None -> [], None in let na = match tm', na with - | RVar (_,id), None when Idset.mem id vars & not !Options.v7 -> Name id + | RVar (_,id), None when Idset.mem id vars -> Name id | _, None -> Anonymous | _, Some na -> na in (tm',(na,typ)), na::ids diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 08de85d87..70af93885 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -17,7 +17,6 @@ open Environ open Libnames open Rawterm open Pattern -open Coqast open Topconstr open Termops open Pretyping @@ -116,7 +115,3 @@ val for_grammar : ('a -> 'b) -> 'a -> 'b type coqdoc_state val coqdoc_freeze : unit -> coqdoc_state val coqdoc_unfreeze : coqdoc_state -> unit - -(* For v8 translation *) -val set_temporary_implicits_in : - (identifier * Impargs.implicits_list) list -> unit diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 3a0a5047b..ba3b3d872 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -23,8 +23,7 @@ let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) let gen_reference locstr dir s = let dir = make_dir ("Coq"::dir) in - let id = Constrextern.id_of_v7_string s in - let sp = Libnames.make_path dir id in + let sp = Libnames.make_path dir (id_of_string s) in try Nametab.absolute_reference sp with Not_found -> @@ -46,7 +45,7 @@ let has_suffix_in_dirs dirs ref = let gen_constant_in_modules locstr dirs s = let dirs = List.map make_dir dirs in - let id = Constrextern.id_of_v7_string s in + let id = id_of_string s in let all = Nametab.locate_all (make_short_qualid id) in let these = List.filter (has_suffix_in_dirs dirs) all in match these with @@ -181,9 +180,10 @@ let build_coq_eq_data () = { rrec = Some (Lazy.force coq_eq_rec); rect = Some (Lazy.force coq_eq_rect); congr = Lazy.force coq_eq_congr; - sym = Lazy.force coq_eq_sym } + sym = Lazy.force coq_eq_sym } let build_coq_eq () = Lazy.force coq_eq_eq +let build_coq_sym_eq () = Lazy.force coq_eq_sym let build_coq_f_equal2 () = Lazy.force coq_f_equal2 (* Specif *) @@ -191,56 +191,23 @@ let coq_sumbool = lazy_init_constant ["Specif"] "sumbool" let build_coq_sumbool () = Lazy.force coq_sumbool -(* Equality on Type *) - -let coq_eqT_eq = lazy_init_constant ["Logic"] "eq" -let coq_eqT_refl = lazy_init_constant ["Logic"] "refl_equal" -let coq_eqT_ind = lazy_init_constant ["Logic"] "eq_ind" -let coq_eqT_congr =lazy_init_constant ["Logic"] "f_equal" -let coq_eqT_sym = lazy_init_constant ["Logic"] "sym_eq" - -let build_coq_eqT_data () = { - eq = Lazy.force coq_eqT_eq; - refl = Lazy.force coq_eqT_refl; - ind = Lazy.force coq_eqT_ind; - rrec = None; - rect = None; - congr = Lazy.force coq_eqT_congr; - sym = Lazy.force coq_eqT_sym } - -let build_coq_eqT () = Lazy.force coq_eqT_eq -let build_coq_sym_eqT () = Lazy.force coq_eqT_sym - (* Equality on Type as a Type *) -let coq_idT_eq = lazy_init_constant ["Datatypes"] "identity" -let coq_idT_refl = lazy_init_constant ["Datatypes"] "refl_identity" -let coq_idT_ind = lazy_init_constant ["Datatypes"] "identity_ind" -let coq_idT_rec = lazy_init_constant ["Datatypes"] "identity_rec" -let coq_idT_rect = lazy_init_constant ["Datatypes"] "identity_rect" -let coq_idT_congr = lazy_init_constant ["Logic_Type"] "congr_id" -let coq_idT_sym = lazy_init_constant ["Logic_Type"] "sym_id" - -let build_coq_idT_data () = { - eq = Lazy.force coq_idT_eq; - refl = Lazy.force coq_idT_refl; - ind = Lazy.force coq_idT_ind; - rrec = Some (Lazy.force coq_idT_rec); - rect = Some (Lazy.force coq_idT_rect); - congr = Lazy.force coq_idT_congr; - sym = Lazy.force coq_idT_sym } - -let lazy_init_constant_v7 d id id7 = - if !Options.v7 then lazy_init_constant d id else - lazy (anomaly - (id7^" does no longer exist in V8 new syntax, use "^id - ^" instead (probably an error in ML contributed code)")) - -(* Empty Type *) -let coq_EmptyT = lazy_init_constant_v7 ["Logic"] "False" "EmptyT" - -(* Unit Type and its unique inhabitant *) -let coq_UnitT = lazy_init_constant_v7 ["Datatypes"] "unit" "UnitT" -let coq_IT = lazy_init_constant_v7 ["Datatypes"] "tt" "IT" +let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity" +let coq_identity_refl = lazy_init_constant ["Datatypes"] "refl_identity" +let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind" +let coq_identity_rec = lazy_init_constant ["Datatypes"] "identity_rec" +let coq_identity_rect = lazy_init_constant ["Datatypes"] "identity_rect" +let coq_identity_congr = lazy_init_constant ["Logic_Type"] "congr_id" +let coq_identity_sym = lazy_init_constant ["Logic_Type"] "sym_id" + +let build_coq_identity_data () = { + eq = Lazy.force coq_identity_eq; + refl = Lazy.force coq_identity_refl; + ind = Lazy.force coq_identity_ind; + rrec = Some (Lazy.force coq_identity_rec); + rect = Some (Lazy.force coq_identity_rect); + congr = Lazy.force coq_identity_congr; + sym = Lazy.force coq_identity_sym } (* The False proposition *) let coq_False = lazy_init_constant ["Logic"] "False" @@ -256,10 +223,6 @@ let coq_or = lazy_init_constant ["Logic"] "or" let coq_ex = lazy_init_constant ["Logic"] "ex" (* Runtime part *) -let build_coq_EmptyT () = Lazy.force coq_EmptyT -let build_coq_UnitT () = Lazy.force coq_UnitT -let build_coq_IT () = Lazy.force coq_IT - let build_coq_True () = Lazy.force coq_True let build_coq_I () = Lazy.force coq_I @@ -285,8 +248,8 @@ let coq_eq_pattern = lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)")) let coq_eqT_pattern = lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)")) -let coq_idT_pattern = - lazy (snd (parse_pattern "(Coq.Init.Logic_Type.identityT ?1 ?2 ?3)")) +let coq_identity_pattern = + lazy (snd (parse_pattern "(Coq.Init.Logic_Type.identity ?1 ?2 ?3)")) let coq_existS_pattern = lazy (snd (parse_pattern "(Coq.Init.Specif.existS ?1 ?2 ?3 ?4)")) let coq_existT_pattern = @@ -305,8 +268,7 @@ let coq_eqdec_pattern = (* The following is less readable but does not depend on parsing *) let coq_eq_ref = lazy (init_reference ["Logic"] "eq") -let coq_eqT_ref = coq_eq_ref -let coq_idT_ref = lazy (init_reference ["Datatypes"] "identity") +let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") let coq_existS_ref = lazy (init_reference ["Specif"] "existS") let coq_existT_ref = lazy (init_reference ["Specif"] "existT") let coq_not_ref = lazy (init_reference ["Logic"] "not") diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 64c83d7eb..f74190a0e 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -80,20 +80,11 @@ type coq_leibniz_eq_data = { sym : constr } val build_coq_eq_data : coq_leibniz_eq_data delayed -val build_coq_eqT_data : coq_leibniz_eq_data delayed -val build_coq_idT_data : coq_leibniz_eq_data delayed +val build_coq_identity_data : coq_leibniz_eq_data delayed -val build_coq_eq : constr delayed (* = [(build_coq_eq_data()).eq] *) +val build_coq_eq : constr delayed (* = [(build_coq_eq_data()).eq] *) +val build_coq_sym_eq : constr delayed (* = [(build_coq_eq_data()).sym] *) val build_coq_f_equal2 : constr delayed -val build_coq_eqT : constr delayed -val build_coq_sym_eqT : constr delayed - -(* Empty Type *) -val build_coq_EmptyT : constr delayed - -(* Unit Type and its unique inhabitant *) -val build_coq_UnitT : constr delayed -val build_coq_IT : constr delayed (* Specif *) val build_coq_sumbool : constr delayed @@ -119,8 +110,7 @@ val build_coq_or : constr delayed val build_coq_ex : constr delayed val coq_eq_ref : global_reference lazy_t -val coq_eqT_ref : global_reference lazy_t -val coq_idT_ref : global_reference lazy_t +val coq_identity_ref : global_reference lazy_t val coq_existS_ref : global_reference lazy_t val coq_existT_ref : global_reference lazy_t val coq_not_ref : global_reference lazy_t diff --git a/interp/genarg.ml b/interp/genarg.ml index d9afc146b..1b2f48f95 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -26,13 +26,13 @@ type argument_type = | PreIdentArgType | IntroPatternArgType | IdentArgType - | HypArgType + | VarArgType | RefArgType (* Specific types *) | SortArgType | ConstrArgType | ConstrMayEvalArgType - | QuantHypArgType + | QuantVarArgType | TacticArgType of int | OpenConstrArgType of bool | ConstrWithBindingsArgType @@ -116,17 +116,17 @@ let rawwit_ident = IdentArgType let globwit_ident = IdentArgType let wit_ident = IdentArgType -let rawwit_var = HypArgType -let globwit_var = HypArgType -let wit_var = HypArgType +let rawwit_var = VarArgType +let globwit_var = VarArgType +let wit_var = VarArgType let rawwit_ref = RefArgType let globwit_ref = RefArgType let wit_ref = RefArgType -let rawwit_quant_hyp = QuantHypArgType -let globwit_quant_hyp = QuantHypArgType -let wit_quant_hyp = QuantHypArgType +let rawwit_quant_hyp = QuantVarArgType +let globwit_quant_hyp = QuantVarArgType +let wit_quant_hyp = QuantVarArgType let rawwit_sort = SortArgType let globwit_sort = SortArgType diff --git a/interp/genarg.mli b/interp/genarg.mli index 9609576a4..50c8ab3e0 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -71,7 +71,7 @@ VarArgType identifier constr RefArgType reference global_reference ConstrArgType constr_expr constr ConstrMayEvalArgType constr_expr may_eval constr -QuantHypArgType quantified_hypothesis quantified_hypothesis +QuantVarArgType quantified_hypothesis quantified_hypothesis TacticArgType raw_tactic_expr tactic OpenConstrArgType constr_expr open_constr ConstrBindingsArgType constr_expr with_bindings constr with_bindings @@ -114,7 +114,7 @@ val wit_ident : (identifier,'co,'ta) abstract_argument_type val rawwit_var : (identifier located,'co,'ta) abstract_argument_type val globwit_var : (identifier located,'co,'ta) abstract_argument_type -val wit_var : ('co,'co,'ta) abstract_argument_type +val wit_var : (identifier,'co,'ta) abstract_argument_type val rawwit_ref : (reference,constr_expr,'ta) abstract_argument_type val globwit_ref : (global_reference located or_var,rawconstr_and_expr,'ta) abstract_argument_type @@ -231,13 +231,13 @@ type argument_type = | PreIdentArgType | IntroPatternArgType | IdentArgType - | HypArgType + | VarArgType | RefArgType (* Specific types *) | SortArgType | ConstrArgType | ConstrMayEvalArgType - | QuantHypArgType + | QuantVarArgType | TacticArgType of int | OpenConstrArgType of bool | ConstrWithBindingsArgType @@ -271,4 +271,3 @@ val in_gen : ('a,'co,'ta) abstract_argument_type -> 'a -> ('co,'ta) generic_argument val out_gen : ('a,'co,'ta) abstract_argument_type -> ('co,'ta) generic_argument -> 'a - diff --git a/interp/notation.ml b/interp/notation.ml index f116f292c..570981aff 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -31,7 +31,7 @@ open Ppextend terms and patterns can be set; these interpreters are in permanent table [numeral_interpreter_tab] - a set of ML printers for expressions denoting numbers parsable in - this scope (permanently declared in [Esyntax.primitive_printer_tab]) + this scope - a set of interpretations for infix (more generally distfix) notations - an optional pair of delimiters which, when occurring in a syntactic expression, set this scope to be the current scope @@ -261,7 +261,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function (* Uninterpreted notation levels *) let declare_notation_level ntn level = - if not !Options.v7 & Stringmap.mem ntn !notation_level_map then + if Stringmap.mem ntn !notation_level_map then error ("Notation "^ntn^" is already assigned a level"); notation_level_map := Stringmap.add ntn level !notation_level_map diff --git a/interp/reserve.ml b/interp/reserve.ml index 917f9f4ad..834587f8d 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -57,14 +57,11 @@ let rec unloc = function | RLambda (_,na,ty,c) -> RLambda (dummy_loc,na,unloc ty,unloc c) | RProd (_,na,ty,c) -> RProd (dummy_loc,na,unloc ty,unloc c) | RLetIn (_,na,b,c) -> RLetIn (dummy_loc,na,unloc b,unloc c) - | RCases (_,(tyopt,rtntypopt),tml,pl) -> + | RCases (_,rtntypopt,tml,pl) -> RCases (dummy_loc, - (option_app unloc tyopt,ref (option_app unloc !rtntypopt)), + (option_app unloc rtntypopt), List.map (fun (tm,x) -> (unloc tm,x)) tml, List.map (fun (_,idl,p,c) -> (dummy_loc,idl,p,unloc c)) pl) - | ROrderedCase (_,b,tyopt,tm,bv,x) -> - ROrderedCase - (dummy_loc,b,option_app unloc tyopt,unloc tm, Array.map unloc bv,x) | RLetTuple (_,nal,(na,po),b,c) -> RLetTuple (dummy_loc,nal,(na,option_app unloc po),unloc b,unloc c) | RIf (_,c,(na,po),b1,b2) -> @@ -86,7 +83,6 @@ let rec unloc = function let anonymize_if_reserved na t = match na with | Name id as na -> - if !Options.v7 & id = id_of_string "_" then t else (try if unloc t = find_reserved_type id then RHole (dummy_loc,Evd.BinderType na) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index ae6bcd10c..c75cc8575 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -37,10 +37,9 @@ type aconstr = | ALambda of name * aconstr * aconstr | AProd of name * aconstr * aconstr | ALetIn of name * aconstr * aconstr - | ACases of aconstr option * aconstr option * + | ACases of aconstr option * (aconstr * (name * (inductive * name list) option)) list * (identifier list * cases_pattern list * aconstr) list - | AOrderedCase of case_style * aconstr option * aconstr * aconstr array | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr | AIf of aconstr * (name * aconstr option) * aconstr * aconstr | ASort of rawsort @@ -73,7 +72,7 @@ let rawconstr_of_aconstr_with_binders loc g f e = function let e,na = name_app g e na in RProd (loc,na,f e ty,f e c) | ALetIn (na,b,c) -> let e,na = name_app g e na in RLetIn (loc,na,f e b,f e c) - | ACases (tyopt,rtntypopt,tml,eqnl) -> + | ACases (rtntypopt,tml,eqnl) -> let cases_predicate_names tml = List.flatten (List.map (function | (tm,(na,None)) -> [na] @@ -84,11 +83,9 @@ let rawconstr_of_aconstr_with_binders loc g f e = function let fold id (idl,e) = let (id,e) = g id e in (id::idl,e) in let eqnl = List.map (fun (idl,pat,rhs) -> let (idl,e) = List.fold_right fold idl ([],e) in (loc,idl,pat,f e rhs)) eqnl in - RCases (loc,(option_app (f e) tyopt, ref (option_app (f e') rtntypopt)), + RCases (loc,option_app (f e') rtntypopt, List.map (fun (tm,(na,x)) -> - (f e tm,ref (na,option_app (fun (x,y) -> (loc,x,y)) x))) tml,eqnl) - | AOrderedCase (b,tyopt,tm,bv) -> - ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv,ref None) + (f e tm,(na,option_app (fun (x,y) -> (loc,x,y)) x))) tml,eqnl) | ALetTuple (nal,(na,po),b,c) -> let e,nal = list_fold_map (name_app g) e nal in let e,na = name_app g e na in @@ -129,9 +126,9 @@ let compare_rawconstr f t1 t2 = match t1,t2 with f ty1 ty2 & f c1 c2 | RHole _, RHole _ -> true | RSort (_,s1), RSort (_,s2) -> s1 = s2 - | (RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _ + | (RLetIn _ | RCases _ | RRec _ | RDynamic _ | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_ - | _,(RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _ + | _,(RLetIn _ | RCases _ | RRec _ | RDynamic _ | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _) -> error "Unsupported construction in recursive notations" | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ | RHole _ | RSort _), _ @@ -175,20 +172,17 @@ let aconstr_and_vars_of_rawconstr a = | RLambda (_,na,ty,c) -> add_name found na; ALambda (na,aux ty,aux c) | RProd (_,na,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 (_,(tyopt,rtntypopt),tml,eqnl) -> + | RCases (_,rtntypopt,tml,eqnl) -> let f (_,idl,pat,rhs) = found := idl@(!found); (idl,pat,aux rhs) in - ACases (option_app aux tyopt, - option_app aux !rtntypopt, - List.map (fun (tm,{contents = (na,x)}) -> + ACases (option_app aux rtntypopt, + List.map (fun (tm,(na,x)) -> add_name found na; option_iter (fun (_,_,nl) -> List.iter (add_name found) nl) x; (aux tm,(na,option_app (fun (_,ind,nal) -> (ind,nal)) x))) tml, List.map f eqnl) - | ROrderedCase (_,b,tyopt,tm,bv,_) -> - AOrderedCase (b,option_app aux tyopt,aux tm, Array.map aux bv) | RLetTuple (loc,nal,(na,po),b,c) -> add_name found na; List.iter (add_name found) nal; @@ -284,9 +278,8 @@ let rec subst_aconstr subst bound raw = if r1' == r1 && r2' == r2 then raw else ALetIn (n,r1',r2') - | ACases (ro,rtntypopt,rl,branches) -> - let ro' = option_smartmap (subst_aconstr subst bound) ro - and rtntypopt' = option_smartmap (subst_aconstr subst bound) rtntypopt + | ACases (rtntypopt,rl,branches) -> + let rtntypopt' = option_smartmap (subst_aconstr subst bound) rtntypopt and rl' = list_smartmap (fun (a,(n,signopt) as x) -> let a' = subst_aconstr subst bound a in @@ -303,16 +296,9 @@ let rec subst_aconstr subst bound raw = (idl,cpl',r')) branches in - if ro' == ro && rtntypopt == rtntypopt' & + if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' & rl' == rl && branches' == branches then raw else - ACases (ro',rtntypopt',rl',branches') - - | AOrderedCase (b,ro,r,ra) -> - let ro' = option_smartmap (subst_aconstr subst bound) ro - and r' = subst_aconstr subst bound r - and ra' = array_smartmap (subst_aconstr subst bound) ra in - if ro' == ro && r' == r && ra' == ra then raw else - AOrderedCase (b,ro',r',ra') + ACases (rtntypopt',rl',branches') | ALetTuple (nal,(na,po),b,c) -> let po' = option_smartmap (subst_aconstr subst bound) po @@ -402,17 +388,13 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 | RLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) -> match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 - | RCases (_,(po1,rtno1),tml1,eqnl1), ACases (po2,rtno2,tml2,eqnl2) + | RCases (_,rtno1,tml1,eqnl1), ACases (rtno2,tml2,eqnl2) when List.length tml1 = List.length tml2 -> - let sigma = option_fold_left2 (match_ alp metas) sigma po1 po2 in + let sigma = option_fold_left2 (match_ alp metas) sigma rtno1 rtno2 in (* TODO: match rtno' with their contexts *) let sigma = List.fold_left2 (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2 - | ROrderedCase (_,st,po1,c1,bl1,_), AOrderedCase (st2,po2,c2,bl2) - when Array.length bl1 = Array.length bl2 -> - let sigma = option_fold_left2 (match_ alp metas) sigma po1 po2 in - array_fold_left2 (match_ alp metas) (match_ alp metas sigma c1 c2) bl1 bl2 | RIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) -> let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in List.fold_left2 (match_ alp metas) sigma [a1;b1;c1] [a2;b2;c2] @@ -507,11 +489,9 @@ type constr_expr = | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list - | CCases of loc * (constr_expr option * constr_expr option) * + | CCases of loc * constr_expr option * (constr_expr * (name option * constr_expr option)) list * (loc * cases_pattern_expr list * constr_expr) list - | COrderedCase of loc * case_style * constr_expr option * constr_expr - * constr_expr list | CLetTuple of loc * name list * (name option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name option * constr_expr option) @@ -562,7 +542,6 @@ let constr_loc = function | CAppExpl (loc,_,_) -> loc | CApp (loc,_,_) -> loc | CCases (loc,_,_,_) -> loc - | COrderedCase (loc,_,_,_,_) -> loc | CLetTuple (loc,_,_,_,_) -> loc | CIf (loc,_,_,_,_) -> loc | CHole loc -> loc @@ -605,7 +584,6 @@ let rec occur_var_constr_expr id = function | CDelimiters (loc,_,a) -> occur_var_constr_expr id a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CNumeral _ | CDynamic _ -> false | CCases (loc,_,_,_) - | COrderedCase (loc,_,_,_,_) | CLetTuple (loc,_,_,_,_) | CIf (loc,_,_,_,_) | CFix (loc,_,_) @@ -676,7 +654,7 @@ let map_constr_expr_with_binders f g e = function | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CNumeral _ | CDynamic _ | CRef _ as x -> x - | CCases (loc,(po,rtnpo),a,bl) -> + | CCases (loc,rtnpo,a,bl) -> (* TODO: apply g on the binding variables in pat... *) let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in let e' = @@ -689,10 +667,8 @@ let map_constr_expr_with_binders f g e = function indnal (option_fold_right (name_fold g) na e)) a e in - CCases (loc,(option_app (f e) po, option_app (f e') rtnpo), + CCases (loc,option_app (f e') rtnpo, List.map (fun (tm,x) -> (f e tm,x)) a,bl) - | COrderedCase (loc,s,po,a,bl) -> - COrderedCase (loc,s,option_app (f e) po,f e a,List.map (f e) 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 diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 0a073c435..e0f5ad577 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -33,10 +33,9 @@ type aconstr = | ALambda of name * aconstr * aconstr | AProd of name * aconstr * aconstr | ALetIn of name * aconstr * aconstr - | ACases of aconstr option * aconstr option * + | ACases of aconstr option * (aconstr * (name * (inductive * name list) option)) list * (identifier list * cases_pattern list * aconstr) list - | AOrderedCase of case_style * aconstr option * aconstr * aconstr array | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr | AIf of aconstr * (name * aconstr option) * aconstr * aconstr | ASort of rawsort @@ -91,11 +90,9 @@ type constr_expr = | CAppExpl of loc * (proj_flag * reference) * constr_expr list | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list - | CCases of loc * (constr_expr option * constr_expr option) * + | CCases of loc * constr_expr option * (constr_expr * (name option * constr_expr option)) list * (loc * cases_pattern_expr list * constr_expr) list - | COrderedCase of loc * case_style * constr_expr option * constr_expr - * constr_expr list | CLetTuple of loc * name list * (name option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name option * constr_expr option) diff --git a/lib/options.ml b/lib/options.ml index 38c6e91a1..854e302f8 100644 --- a/lib/options.ml +++ b/lib/options.ml @@ -31,19 +31,9 @@ let dont_load_proofs = ref false let raw_print = ref false -let v7 = - let transl = array_exists ((=) "-translate") Sys.argv in - let v7 = array_exists ((=) "-v7") Sys.argv in - let v8 = array_exists ((=) "-v8") Sys.argv in - if v8 & transl then error "Options -translate and -v8 are incompatible"; - if v8 & v7 then error "Options -v7 and -v8 are incompatible"; - ref (v7 or transl) - -let v7_only = ref false - (* Translate *) let translate = ref false -let make_translate f = translate := f; v7 := f; () +let make_translate f = translate := f let do_translate () = !translate let translate_file = ref false let translate_strict_impargs = ref true diff --git a/lib/options.mli b/lib/options.mli index d415f93d0..9eea81ed3 100644 --- a/lib/options.mli +++ b/lib/options.mli @@ -26,9 +26,6 @@ val dont_load_proofs : bool ref val raw_print : bool ref -val v7 : bool ref -val v7_only : bool ref - val translate : bool ref val make_translate : bool -> unit val do_translate : unit -> bool diff --git a/library/impargs.ml b/library/impargs.ml index abf583d99..fe0e2cca4 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -27,71 +27,44 @@ open Topconstr (* les implicites sont stricts par défaut en v8 *) let implicit_args = ref false -let strict_implicit_args = ref (not !Options.v7) +let strict_implicit_args = ref true let contextual_implicit_args = ref false -let implicit_args_out = ref false -let strict_implicit_args_out = ref true -let contextual_implicit_args_out = ref false - let make_implicit_args flag = - implicit_args := flag; - if not !Options.v7_only then implicit_args_out := flag; - if !Options.translate_strict_impargs then - strict_implicit_args_out := not flag + implicit_args := flag let make_strict_implicit_args flag = - strict_implicit_args := flag; - if not !Options.v7_only then strict_implicit_args_out := flag + strict_implicit_args := flag let make_contextual_implicit_args flag = - contextual_implicit_args := flag; - if not !Options.v7_only then contextual_implicit_args_out := flag + contextual_implicit_args := flag let is_implicit_args () = !implicit_args -let is_implicit_args_out () = !implicit_args_out let is_strict_implicit_args () = !strict_implicit_args let is_contextual_implicit_args () = !contextual_implicit_args -type implicits_flags = (bool * bool * bool) * (bool * bool * bool) +type implicits_flags = bool * bool * bool let implicits_flags () = - (!implicit_args, - !strict_implicit_args, - !contextual_implicit_args), - (!implicit_args_out, - !strict_implicit_args_out, - !contextual_implicit_args_out) - -let with_implicits ((a,b,c),(d,e,g)) f x = + (!implicit_args, !strict_implicit_args, !contextual_implicit_args) + +let with_implicits (a,b,c) f x = let oa = !implicit_args in let ob = !strict_implicit_args in let oc = !contextual_implicit_args in - let od = !implicit_args_out in - let oe = !strict_implicit_args_out in - let og = !contextual_implicit_args_out in try implicit_args := a; strict_implicit_args := b; contextual_implicit_args := c; - implicit_args_out := d; - strict_implicit_args_out := e; - contextual_implicit_args_out := g; let rslt = f x in implicit_args := oa; strict_implicit_args := ob; contextual_implicit_args := oc; - implicit_args_out := od; - strict_implicit_args_out := oe; - contextual_implicit_args_out := og; rslt with e -> begin implicit_args := oa; strict_implicit_args := ob; contextual_implicit_args := oc; - implicit_args_out := od; - strict_implicit_args_out := oe; - contextual_implicit_args_out := og; raise e end @@ -221,13 +194,9 @@ let compute_implicits_gen strict contextual env t = Array.to_list v | _ -> [] -let compute_implicits output env t = - let strict = - (not output & !strict_implicit_args) or - (output & !strict_implicit_args_out) in - let contextual = - (not output & !contextual_implicit_args) or - (output & !contextual_implicit_args_out) in +let compute_implicits env t = + let strict = !strict_implicit_args in + let contextual = !contextual_implicit_args in let l = compute_implicits_gen strict contextual env t in List.map (function | (Name id, Some imp) -> Some (id,imp) @@ -275,20 +244,11 @@ type implicits = | No_impl let auto_implicits env ty = - let impl = - if !implicit_args then - let l = compute_implicits false env ty in - Impl_auto (!strict_implicit_args,!contextual_implicit_args,l) - else - No_impl in - if Options.do_translate () then - impl, - if !implicit_args_out then - (let l = compute_implicits true env ty in - Impl_auto (!strict_implicit_args_out,!contextual_implicit_args_out,l)) - else No_impl - else - impl, impl + if !implicit_args then + let l = compute_implicits env ty in + Impl_auto (!strict_implicit_args,!contextual_implicit_args,l) + else + No_impl let list_of_implicits = function | Impl_auto (_,_,l) -> l @@ -305,7 +265,7 @@ let compute_constant_implicits kn = auto_implicits env (body_of_type cb.const_type) let constant_implicits sp = - try Cmap.find sp !constants_table with Not_found -> No_impl,No_impl + try Cmap.find sp !constants_table with Not_found -> No_impl (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where @@ -334,10 +294,11 @@ let compute_mib_implicits kn = Array.mapi imps_one_inductive mib.mind_packets let inductive_implicits indp = - try Indmap.find indp !inductives_table with Not_found -> No_impl,No_impl + try Indmap.find indp !inductives_table with Not_found -> No_impl let constructor_implicits consp = - try Constrmap.find consp !constructors_table with Not_found -> No_impl,No_impl + try Constrmap.find consp !constructors_table with Not_found -> No_impl + (*s Variables. *) let var_table = ref Idmap.empty @@ -348,7 +309,7 @@ let compute_var_implicits id = auto_implicits env ty let var_implicits id = - try Idmap.find id !var_table with Not_found -> No_impl,No_impl + try Idmap.find id !var_table with Not_found -> No_impl (* Implicits of a global reference. *) @@ -378,11 +339,6 @@ let load_implicits _ (_,l) = List.iter cache_implicits_decl l let cache_implicits o = load_implicits 1 o -(* -let discharge_implicits (_,(r,imps)) = - match r with VarRef _ -> None | _ -> Some (r,compute_global_implicits r) -*) - let subst_implicits_decl subst (r,imps as o) = let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) @@ -402,20 +358,17 @@ let declare_implicits_gen r = let declare_implicits r = with_implicits - ((true,!strict_implicit_args,!contextual_implicit_args), - (true,!strict_implicit_args_out,!contextual_implicit_args_out)) + (true,!strict_implicit_args,!contextual_implicit_args) declare_implicits_gen r let declare_var_implicits id = - if !implicit_args or !implicit_args_out then - declare_implicits_gen (VarRef id) + if !implicit_args then declare_implicits_gen (VarRef id) let declare_constant_implicits kn = - if !implicit_args or !implicit_args_out then - declare_implicits_gen (ConstRef kn) + if !implicit_args then declare_implicits_gen (ConstRef kn) let declare_mib_implicits kn = - if !implicit_args or !implicit_args_out then + if !implicit_args then let imps = compute_mib_implicits kn in let imps = array_map_to_list (fun (ind,cstrs) -> ind::(Array.to_list cstrs)) imps in @@ -428,23 +381,10 @@ let implicits_of_global_gen = function | ConstructRef csp -> constructor_implicits csp let implicits_of_global r = - let (imp_in,imp_out) = implicits_of_global_gen r in - list_of_implicits imp_in - -let implicits_of_global_out r = - let (imp_in,imp_out) = implicits_of_global_gen r in - list_of_implicits imp_out + list_of_implicits (implicits_of_global_gen r) (* Declare manual implicits *) -(* -let check_range n = function - | loc,ExplByPos i -> - if i<1 or i>n then error ("Bad argument number: "^(string_of_int i)) - | loc,ExplByName id -> -() -*) - let rec list_remove a = function | b::l when a = b -> l | b::l -> b::list_remove a l @@ -459,8 +399,6 @@ let declare_manual_implicits r l = let n = List.length autoimps in if not (list_distinct l) then error ("Some parameters are referred more than once"); -(* List.iter (check_range n) l;*) -(* let l = List.sort (-) l in*) (* Compare with automatic implicits to recover printing data and names *) let rec merge k l = function | (Name id,imp)::imps -> @@ -486,8 +424,6 @@ let declare_manual_implicits r l = (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name") in let l = Impl_manual (merge 1 l autoimps) in - let (_,oimp_out) = implicits_of_global_gen r in - let l = l, if !Options.v7_only then oimp_out else l in add_anonymous_leaf (in_implicits [r,l]) (* Tests if declared implicit *) @@ -497,8 +433,8 @@ let test = function | Impl_auto (s,c,_) -> true,s,c let test_if_implicit find a = - try let b,c = find a in test b, test c - with Not_found -> (false,false,false),(false,false,false) + try let b = find a in test b + with Not_found -> (false,false,false) let is_implicit_constant sp = test_if_implicit (Cmap.find sp) !constants_table @@ -534,34 +470,3 @@ let _ = Summary.init_function = init; Summary.survive_module = false; Summary.survive_section = false } - -(* Remark: flags implicit_args, contextual_implicit_args - are synchronized by the general options mechanism - see Vernacentries *) - -let init () = - (* strict_implicit_args_out must be not !Options.v7 - but init is done before parsing *) - strict_implicit_args:=not !Options.v7; - implicit_args_out:=false; - (* strict_implicit_args_out needs to be not !Options.v7 or - Options.do_translate() but init is done before parsing *) - strict_implicit_args_out:=true; - contextual_implicit_args_out:=false - -let freeze () = - (!strict_implicit_args, - !implicit_args_out,!strict_implicit_args_out,!contextual_implicit_args_out) - -let unfreeze (b,d,e,f) = - strict_implicit_args := b; - implicit_args_out := d; - strict_implicit_args_out := e; - contextual_implicit_args_out := f - -let _ = - Summary.declare_summary "implicits-out-options" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = true } diff --git a/library/impargs.mli b/library/impargs.mli index 212a93a0f..23ed327ba 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -43,7 +43,7 @@ val positions_of_implicits : implicits_list -> int list (* Computation of the positions of arguments automatically inferable for an object of the given type in the given env *) -val compute_implicits : bool -> env -> types -> implicits_list +val compute_implicits : env -> types -> implicits_list (*s Computation of implicits (done using the global environment). *) @@ -65,7 +65,3 @@ val is_implicit_var : variable -> implicits_flags val implicits_of_global : global_reference -> implicits_list val implicits_flags : unit -> implicits_flags - -(* For translator *) -val implicits_of_global_out : global_reference -> implicits_list -val is_implicit_args_out : unit -> bool diff --git a/library/library.ml b/library/library.ml index fbd2b9b53..51fbbeddb 100644 --- a/library/library.ml +++ b/library/library.ml @@ -295,30 +295,10 @@ let (in_import, out_import) = (*s Loading from disk to cache (preparation phase) *) -let vo_magic_number7 = 07992 (* V8.0 final old syntax *) -(* let vo_magic_number8 = 08002 (* V8.0 final new syntax *) *) -let vo_magic_number8 = 08003 (* V8.0 final new syntax + new params in ind *) - -let (raw_extern_library7, raw_intern_library7) = - System.raw_extern_intern vo_magic_number7 ".vo" - -let (raw_extern_library8, raw_intern_library8) = - System.raw_extern_intern vo_magic_number8 ".vo" - -let raw_intern_library a = - if !Options.v7 then - try raw_intern_library7 a - with System.Bad_magic_number fname -> - let _= raw_intern_library8 a in - error "Inconsistent compiled files: you probably want to use Coq in new syntax and remove the option -v7 or -translate" - else - try raw_intern_library8 a - with System.Bad_magic_number fname -> - let _= raw_intern_library7 a in - error "Inconsistent compiled files: you probably want to use Coq in old syntax by setting options -v7 or -translate" +let vo_magic_number = 08003 (* V8.0 final new syntax + new params in ind *) -let raw_extern_library = - if !Options.v7 then raw_extern_library7 else raw_extern_library8 +let (raw_extern_library, raw_intern_library) = + System.raw_extern_intern vo_magic_number ".vo" let with_magic_number_check f a = try f a diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 66c2d3bf0..331df4c70 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -11,7 +11,6 @@ open Genarg open Q_util open Q_coqast -open Ast let join_loc (deb1,_) (_,fin2) = (deb1,fin2) let loc = Util.dummy_loc @@ -25,12 +24,12 @@ let rec make_rawwit loc = function | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >> | IdentArgType -> <:expr< Genarg.rawwit_ident >> - | HypArgType -> <:expr< Genarg.rawwit_var >> + | VarArgType -> <:expr< Genarg.rawwit_var >> | RefArgType -> <:expr< Genarg.rawwit_ref >> | SortArgType -> <:expr< Genarg.rawwit_sort >> | ConstrArgType -> <:expr< Genarg.rawwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >> - | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >> + | QuantVarArgType -> <:expr< Genarg.rawwit_quant_hyp >> | TacticArgType n -> <:expr< Genarg.rawwit_tactic $mlexpr_of_int n$ >> | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >> | OpenConstrArgType b -> <:expr< Genarg.rawwit_open_constr_gen $mlexpr_of_bool b$ >> @@ -51,9 +50,9 @@ let rec make_globwit loc = function | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >> | IdentArgType -> <:expr< Genarg.globwit_ident >> - | HypArgType -> <:expr< Genarg.globwit_var >> + | VarArgType -> <:expr< Genarg.globwit_var >> | RefArgType -> <:expr< Genarg.globwit_ref >> - | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >> + | QuantVarArgType -> <:expr< Genarg.globwit_quant_hyp >> | SortArgType -> <:expr< Genarg.globwit_sort >> | ConstrArgType -> <:expr< Genarg.globwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >> @@ -77,9 +76,9 @@ let rec make_wit loc = function | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >> | IdentArgType -> <:expr< Genarg.wit_ident >> - | HypArgType -> <:expr< Genarg.wit_var >> + | VarArgType -> <:expr< Genarg.wit_var >> | RefArgType -> <:expr< Genarg.wit_ref >> - | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> + | QuantVarArgType -> <:expr< Genarg.wit_quant_hyp >> | SortArgType -> <:expr< Genarg.wit_sort >> | ConstrArgType -> <:expr< Genarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >> @@ -111,7 +110,7 @@ let make_rule loc (prods,act) = let (symbs,pil) = List.split prods in <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >> -let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl = +let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = let rawtyp, rawpr = match rawtyppr with | None -> typ,pr | Some (t,p) -> t,p in @@ -159,14 +158,13 @@ let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl = Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None [(None, None, $rules$)]; Pptactic.declare_extra_genarg_pprule - $mlexpr_of_bool for_v8$ ($rawwit$, $lid:rawpr$) ($globwit$, $lid:globpr$) ($wit$, $lid:pr$); end >> -let declare_vernac_argument for_v8 loc s cl = +let declare_vernac_argument loc s cl = let se = mlexpr_of_string s in let rawwit = <:expr< $lid:"rawwit_"^s$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in @@ -235,36 +233,13 @@ EXTEND "END" -> if String.capitalize s = s then failwith "Argument entry names must be lowercase"; - declare_tactic_argument true loc s typ pr f g h rawtyppr globtyppr l + declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> if String.capitalize s = s then failwith "Argument entry names must be lowercase"; - declare_vernac_argument true loc s l - | "V7"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; - "TYPED"; "AS"; typ = argtype; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - rawtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; - "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; - globtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; - "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; - declare_tactic_argument false loc s typ pr f g h rawtyppr globtyppr l - | "V7"; "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - if String.capitalize s = s then - failwith "Argument entry names must be lowercase"; - declare_vernac_argument false loc s l ] ] + declare_vernac_argument loc s l ] ] ; argtype: [ "2" @@ -285,7 +260,7 @@ EXTEND | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Pcoq.lexer.Token.using ("", s); - (<:expr< (Gramext.Stoken (Extend.terminal $str:s$)) >>, None) + (<:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>, None) ] ] ; END diff --git a/parsing/ast.ml b/parsing/ast.ml deleted file mode 100755 index eef1ca4b7..000000000 --- a/parsing/ast.ml +++ /dev/null @@ -1,590 +0,0 @@ -(************************************************************************) -(* 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$ *) - -open Pp -open Util -open Names -open Libnames -open Coqast -open Topconstr -open Genarg - -let isMeta s = String.length s <> 0 & s.[0]='$' - -let loc = function - | Node (loc,_,_) -> loc - | Nvar (loc,_) -> loc - | Nmeta (loc,_) -> loc - | Slam (loc,_,_) -> loc - | Smetalam (loc,_,_) -> loc - | Num (loc,_) -> loc - | Id (loc,_) -> loc - | Str (loc,_) -> loc - | Path (loc,_) -> loc - | ConPath (loc,_) -> loc - | Dynamic (loc,_) -> loc - -(* patterns of ast *) -type astpat = - | Pquote of t - | Pmeta of string * tok_kind - | Pnode of string * patlist - | Pslam of identifier option * astpat - | Pmeta_slam of string * astpat - -and patlist = - | Pcons of astpat * patlist - | Plmeta of string - | Pnil - -and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist - -type pat = - | AstListPat of patlist - | PureAstPat of astpat - -(* building a node with dummy location *) - -let ope(op,l) = Node(dummy_loc,op,l) -let slam(idl,b) = Slam(dummy_loc,idl,b) -let ide s = Id(dummy_loc,s) -let nvar s = Nvar(dummy_loc,s) -let num n = Num(dummy_loc,n) -let string s = Str(dummy_loc,s) -let path sl = Path(dummy_loc,sl) -let conpath sl = ConPath(dummy_loc,sl) -let dynamic d = Dynamic(dummy_loc,d) - -let rec set_loc loc = function - | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al) - | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b) - | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b) - | Nvar(_,s) -> Nvar(loc,s) - | Nmeta(_,s) -> Nmeta(loc,s) - | Id(_,s) -> Id(loc,s) - | Str(_,s) -> Str(loc,s) - | Num(_,s) -> Num(loc,s) - | Path(_,sl) -> Path(loc,sl) - | ConPath(_,sl) -> ConPath(loc,sl) - | Dynamic(_,d) -> Dynamic(loc,d) - -let path_section loc sp = Coqast.Path(loc, sp) -let conpath_section loc sp = Coqast.ConPath(loc, sp) - -(* ast destructors *) -let num_of_ast = function - | Num(_,n) -> n - | ast -> invalid_arg_loc (loc ast, "Ast.num_of_ast") - -let nvar_of_ast = function - | Nvar(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -let meta_of_ast = function - | Nmeta(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -let id_of_ast = function - | Id(_,s) -> s - | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast") - -(* semantic actions of grammar rules *) -type act = - | Act of constr_expr - | ActCase of act * (pat * act) list - | ActCaseList of act * (pat * act) list - -(* values associated to variables *) -(* -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t -*) -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t - -type ast_action_type = ETast | ETastl - -type dynamic_grammar = - | ConstrNode of constr_expr - | CasesPatternNode of cases_pattern_expr - -type grammar_action = - | SimpleAction of loc * dynamic_grammar - | CaseAction of - loc * grammar_action * ast_action_type * (t list * grammar_action) list - -type env = (string * typed_ast) list - -let string_of_dirpath = function - | [] -> "<empty>" - | sl -> - String.concat "." (List.map string_of_id (List.rev sl)) - -let pr_id id = str (string_of_id id) - -let print_kn_or_con repr kn = - let (mp,dp,l) = repr kn in - let dpl = repr_dirpath dp in - str (string_of_mp mp) ++ str "." ++ - prlist_with_sep (fun _ -> str".") pr_id dpl ++ - str (string_of_label l) - -let print_kn = print_kn_or_con repr_kn -let print_con = print_kn_or_con repr_con - -(* Pretty-printing *) -let rec print_ast ast = - match ast with - | Num(_,n) -> int n - | Str(_,s) -> qs s - | Path(_,sl) -> print_kn sl - | ConPath(_,sl) -> print_con sl - | Id (_,s) -> str "{" ++ str s ++ str "}" - | Nvar(_,s) -> pr_id s - | Nmeta(_,s) -> str s - | Node(_,op,l) -> - hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")") - | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast) - | Slam(_,Some x,ast) -> - hov 1 - (str "[" ++ pr_id x ++ str "]" ++ cut () ++ - print_ast ast) - | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast) - | Dynamic(_,d) -> - hov 0 (str "<dynamic: " ++ str (Dyn.tag d) ++ str ">") - -and print_astl astl = - prlist_with_sep pr_spc print_ast astl - -let print_ast_cast = function - | Tany -> (mt ()) - | Tvar -> (str":var") - | Tid -> (str":id") - | Tstr -> (str":str") - | Tpath -> (str":path") - | Tnum -> (str":num") - | Tlist -> (str":list") - -let rec print_astpat = function - | Pquote ast -> - str"'" ++ print_ast ast - | Pmeta(s,tk) -> - str s ++ print_ast_cast tk - | Pmeta_slam(s,b) -> - hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b) - | Pnode(op,al) -> - hov 2 (str"(" ++ str op ++ spc () ++ print_astlpat al ++ str")" ) - | Pslam(None,b) -> - hov 1 (str"[<" ++ cut () ++ print_astpat b) - | Pslam(Some id,b) -> - hov 1 - (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b) - -and print_astlpat = function - | Pnil -> mt () - | Pcons(h,Pnil) -> hov 1 (print_astpat h) - | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t) - | Plmeta(s) -> str"| " ++ str s - - -let print_val = function - | PureAstNode a -> print_ast a - | AstListNode al -> - hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]") - -(* Ast values environments *) - -let grammar_type_error (loc,s) = - anomaly_loc (loc,s,(str"grammar type error: " ++ str s)) - - -(* Coercions enforced by the user *) -let check_cast loc a k = - match (k,a) with - | (Tany, _) -> () - | (Tid, Id _) -> () - | (Tvar, Nvar _) -> () - | (Tpath, Path _) -> () - | (Tpath, ConPath _) -> () - | (Tstr, Str _) -> () - | (Tnum, Num _) -> () - | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val") - | _ -> user_err_loc (loc,"Ast.cast_val", - (str"cast _" ++ print_ast_cast k ++ str"failed")) - -let rec coerce_to_var = function - | Nvar(_,id) as var -> var - | Nmeta(_,id) as var -> var - | Node(_,"QUALID",[Nvar(_,id) as var]) -> var - | ast -> user_err_loc - (loc ast,"Ast.coerce_to_var", - (str"This expression should be a simple identifier")) - -let coerce_to_id_ast a = match coerce_to_var a with - | Nvar (_,id) -> id - | ast -> user_err_loc - (loc ast,"Ast.coerce_to_id", - str"This expression should be a simple identifier") - -let coerce_to_id = function - | CRef (Ident (loc,id)) -> (loc,id) - | a -> user_err_loc - (constr_loc a,"Ast.coerce_to_id", - str"This expression should be a simple identifier") - -let coerce_reference_to_id = function - | Ident (_,id) -> id - | Qualid (loc,_) -> - user_err_loc (loc, "Ast.coerce_reference_to_id", - str"This expression should be a simple identifier") - -let coerce_global_to_id = coerce_reference_to_id - -(* Pattern-matching on ast *) - -let env_assoc_value loc v env = - try - List.assoc v env - with Not_found -> - anomaly_loc - (loc,"Ast.env_assoc_value", - (str"metavariable " ++ str v ++ str" is unbound")) - -let env_assoc_list sigma (loc,v) = - match env_assoc_value loc v sigma with - | AstListNode al -> al - | PureAstNode a -> [a] - -let env_assoc sigma k (loc,v) = - match env_assoc_value loc v sigma with - | PureAstNode a -> check_cast loc a k; a - | _ -> grammar_type_error (loc,"Ast.env_assoc: "^v^" is an ast list") - -let env_assoc_nvars sigma (dloc,v) = - match env_assoc_value dloc v sigma with - | AstListNode al -> List.map coerce_to_id_ast al - | PureAstNode ast -> [coerce_to_id_ast ast] - -let build_lams dloc idl ast = - List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast - -(* Alpha-conversion *) - -let rec alpha_var id1 id2 = function - | (i1,i2)::_ when i1=id1 -> i2 = id2 - | (i1,i2)::_ when i2=id2 -> i1 = id1 - | _::idl -> alpha_var id1 id2 idl - | [] -> id1 = id2 - -let rec alpha alp a1 a2 = - match (a1,a2) with - | (Node(_,op1,tl1),Node(_,op2,tl2)) -> - (op1 = op2) & (List.length tl1 = List.length tl2) - & (List.for_all2 (alpha alp) tl1 tl2) - | (Nvar(_,id1),Nvar(_,id2)) -> alpha_var id1 id2 alp - | (Slam(_,None,body1),Slam(_,None,body2)) -> alpha alp body1 body2 - | (Slam(_,Some s1,body1),Slam(_,Some s2,body2)) -> - alpha ((s1,s2)::alp) body1 body2 - | (Id(_,s1),Id(_,s2)) -> s1=s2 - | (Str(_,s1),Str(_,s2)) -> s1=s2 - | (Num(_,n1),Num(_,n2)) -> n1=n2 - | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2 - | (ConPath(_,sl1),ConPath(_,sl2)) -> sl1=sl2 - | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false - | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false - | _ -> false - -let alpha_eq (a1,a2)= alpha [] a1 a2 - -let alpha_eq_val (x,y) = x = y -(* -let alpha_eq_val = function - | (Vast a1, Vast a2) -> alpha_eq (a1,a2) - | (Vastlist al1, Vastlist al2) -> - (List.length al1 = List.length al2) - & List.for_all2 (fun x y -> alpha_eq (x,y)) al1 al2 - | _ -> false -*) - -exception No_match of string - -let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s) - -(* Binds value v to variable var. If var is already bound, checks if - its value is alpha convertible with v. This allows non-linear patterns. - - Important note: The Metavariable $_ is a special case; it cannot be - bound, which is like _ in the ML matching. *) - -let bind_env sigma var v = - if var = "$_" then - sigma - else - try - let vvar = List.assoc var sigma in - if alpha_eq_val (v,vvar) then sigma - else raise (No_match "Ast.bind_env: values do not match") - with Not_found -> - (var,v)::sigma - -let bind_env_ast sigma var ast = - try - bind_env sigma var (PureAstNode ast) - with e -> - Stdpp.raise_with_loc (loc ast) e - -let alpha_define sigma loc ps s = - try - let _ = List.assoc ps sigma in sigma - with Not_found -> - if ps = "$_" then sigma else (ps, PureAstNode(Nvar(loc,s)))::sigma - - -(* Match an ast with an ast pattern. Returns the new environnement. *) - -let rec amatch alp sigma spat ast = - match (spat,ast) with - | (Pquote a, _) -> - if alpha alp a ast then - sigma - else - no_match_loc (loc ast,"quote does not match") - | (Pmeta(pv,Tany), _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tvar), Nvar _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tid), Id _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tnum), Num _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tstr), Str _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tpath), Path _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tpath), ConPath _) -> bind_env_ast sigma pv ast - | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch") - | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) -> - amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b - | (Pmeta_slam(pv,pb), Slam(loc, None, b)) -> - amatch alp (bind_env_ast sigma pv (Nvar(loc,id_of_string "_"))) pb b - | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) -> - anomaly "amatch: match a pattern with an open ast" - | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op -> - (try amatchl alp sigma argp args - with e -> Stdpp.raise_with_loc loc e) - | (Pslam(None,bp), Slam(_,None,b)) -> amatch alp sigma bp b - | (Pslam(Some ps,bp), Slam(_,Some s,b)) -> amatch ((ps,s)::alp) sigma bp b - | _ -> no_match_loc (loc ast, "Ast.amatch") - -and amatchl alp sigma spatl astl = - match (spatl,astl) with - | (Pnil, []) -> sigma - | (Pcons(pat,patl), ast::asttl) -> - amatchl alp (amatch alp sigma pat ast) patl asttl - | (Plmeta pv, _) -> bind_env sigma pv (AstListNode astl) - | _ -> raise (No_match "Ast.amatchl") - -let ast_match = amatch [] - -let typed_ast_match env p a = match (p,a) with - | PureAstPat p, PureAstNode a -> amatch [] env p a - | AstListPat pl, AstListNode al -> amatchl [] env pl al - | _ -> failwith "Ast.typed_ast_match: TODO" - -let astl_match = amatchl [] - -let first_match pat_of_fun env ast sl = - let rec aux = function - | [] -> None - | h::t -> - (try Some (h, ast_match env (pat_of_fun h) ast) - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) - in - aux sl - -let find_all_matches pat_of_fun env ast sl = - let rec aux = function - | [] -> [] - | (h::t) -> - let l = aux t in - (try (h, ast_match env (pat_of_fun h) ast)::l - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> l) - in - aux sl - -let first_matchl patl_of_fun env astl sl = - let rec aux = function - | [] -> None - | (h::t) -> - (try Some (h, astl_match env (patl_of_fun h) astl) - with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t) - in - aux sl - -let bind_patvar env loc v etyp = - try - if List.assoc v env = etyp then - env - else - user_err_loc - (loc,"Ast.bind_patvar", - (str"variable " ++ str v ++ - str" is bound several times with different types")) - with Not_found -> - if v="$_" then env else (v,etyp)::env - -let make_astvar env loc v cast = - let env' = bind_patvar env loc v ETast in - (Pmeta(v,cast), env') - -(* Note: no metavar in operator position. necessary ? *) -let rec pat_of_ast env ast = - match ast with - | Nmeta(loc,pv) -> make_astvar env loc pv Tany -(* Obsolète - | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid -*) - | Smetalam(loc,s,a) -> - let senv = bind_patvar env loc s ETast in - let (pa,env') = pat_of_ast senv a in - (Pmeta_slam(s, pa), env') - | Node(_,"$VAR",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tvar - | Node(_,"$ID",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tid - | Node(_,"$NUM",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tnum - | Node(_,"$STR",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tstr - | Node(_,"$PATH",[Nmeta(loc,pv)]) -> - make_astvar env loc pv Tpath - | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env) - - (* This may occur when the meta is not textual but bound by coerce_to_id*) - | Slam(loc,Some id,b) when isMeta (string_of_id id) -> - let s = string_of_id id in - let senv = bind_patvar env loc s ETast in - let (pb,env') = pat_of_ast senv b in - (Pmeta_slam(s, pb), env') - - | Slam(_,os,b) -> - let (pb,env') = pat_of_ast env b in - (Pslam(os,pb), env') - | Node(loc,op,_) when isMeta op -> - user_err_loc(loc,"Ast.pat_of_ast", - (str"no patvar in operator position.")) - | Node(_,op,args) -> - let (pargs, env') = patl_of_astl env args in - (Pnode(op,pargs), env') -(* Compatibility with new parsing mode *) - | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany - | (Path _|ConPath _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env) - | Dynamic(loc,_) -> - invalid_arg_loc(loc,"pat_of_ast: dynamic") - -and patl_of_astl env astl = - match astl with - | [Node(_,"$LIST",[Nmeta(loc,pv)])] -> - let penv = bind_patvar env loc pv ETastl in - (Plmeta pv, penv) - | [] -> (Pnil,env) - | ast::asttl -> - let (p1,env1) = pat_of_ast env ast in - let (ptl,env2) = patl_of_astl env1 asttl in - (Pcons (p1,ptl), env2) - -type entry_env = (string * ast_action_type) list - -let to_pat = pat_of_ast - -(* Substitution *) - -(* Locations in quoted ast are wrong (they refer to the right hand - side of a grammar rule). A default location dloc is used whenever - we create an ast constructor. Locations in the binding list are trusted. *) - -(* For old ast printer *) -let rec pat_sub dloc sigma pat = - match pat with - | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) - | Pmeta_slam(pv,p) -> - let idl = env_assoc_nvars sigma (dloc,pv) in - build_lams dloc idl (pat_sub dloc sigma p) - | Pquote a -> set_loc dloc a - | Pnode(op,pl) -> Node(dloc, op, patl_sub dloc sigma pl) - | Pslam(os,p) -> Slam(dloc, os, pat_sub dloc sigma p) - -and patl_sub dloc sigma pl = - match pl with - | Pnil -> - [] - | Plmeta pv -> - env_assoc_list sigma (dloc,pv) - | Pcons(Pmeta(pv,Tlist), ptl) -> - (env_assoc_list sigma (dloc,pv))@(patl_sub dloc sigma ptl) - | Pcons(p1,ptl) -> - (pat_sub dloc sigma p1)::(patl_sub dloc sigma ptl) - -(* Converting and checking free meta-variables *) - -(* For old ast printer *) -let type_of_meta env loc pv = - try - List.assoc pv env - with Not_found -> - user_err_loc (loc,"Ast.type_of_meta", - (str"variable " ++ str pv ++ str" is unbound")) - -(* For old ast printer *) -let check_ast_meta env loc pv = - match type_of_meta env loc pv with - | ETast -> () - | _ -> - user_err_loc (loc,"Ast.check_ast_meta", - (str"variable " ++ str pv ++ str" is not of ast type")) - -(* For old ast printer *) -let rec val_of_ast env = function - | Nmeta(loc,pv) -> - check_ast_meta env loc pv; - Pmeta(pv,Tany) - | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast) - | Smetalam(loc,s,a) -> - let _ = type_of_meta env loc s in (* ids are coerced to id lists *) - Pmeta_slam(s, val_of_ast env a) - | (Path _|ConPath _|Num _|Id _|Str _|Nvar _ as ast) -> Pquote (set_loc dummy_loc ast) - | Slam(_,os,b) -> Pslam(os, val_of_ast env b) - | Node(loc,op,_) when isMeta op -> - user_err_loc(loc,"Ast.val_of_ast", - (str"no patvar in operator position.")) - | Node(_,op,args) -> Pnode(op, vall_of_astl env args) - | Dynamic(loc,_) -> - invalid_arg_loc(loc,"val_of_ast: dynamic") - -and vall_of_astl env = function - | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl -> - if type_of_meta env locv pv = ETastl then - if asttl = [] then - Plmeta pv - else - Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl) - else - user_err_loc - (loc,"Ast.vall_of_astl", - str"variable " ++ str pv ++ str" is not a List") - | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl) - | [] -> Pnil - -(* For old ast printer *) -let rec occur_var_ast s = function - | Node(_,"QUALID",_::_::_) -> false - | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2 - | Nvar(_,s2) -> s = s2 - | Node(loc,op,args) -> List.exists (occur_var_ast s) args - | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here" - | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body - | Id _ | Str _ | Num _ | Path _ | ConPath _ -> false - | Dynamic _ -> (* Hum... what to do here *) false diff --git a/parsing/ast.mli b/parsing/ast.mli deleted file mode 100755 index 9c7eec43c..000000000 --- a/parsing/ast.mli +++ /dev/null @@ -1,121 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $Id$ i*) - -(*i*) -open Pp -open Util -open Names -open Libnames -open Coqast -open Topconstr -open Genarg -open Mod_subst -(*i*) - -(* Abstract syntax trees. *) - -val loc : Coqast.t -> loc - -(* ast constructors with dummy location *) -val ope : string * Coqast.t list -> Coqast.t -val slam : identifier option * Coqast.t -> Coqast.t -val nvar : identifier -> Coqast.t -val ide : string -> Coqast.t -val num : int -> Coqast.t -val string : string -> Coqast.t -val path : kernel_name -> Coqast.t -val dynamic : Dyn.t -> Coqast.t - -val set_loc : loc -> Coqast.t -> Coqast.t - -val path_section : loc -> kernel_name -> Coqast.t -val conpath_section : loc -> constant -> Coqast.t - -(* ast destructors *) -val num_of_ast : Coqast.t -> int -val id_of_ast : Coqast.t -> string -val nvar_of_ast : Coqast.t -> identifier -val meta_of_ast : Coqast.t -> string - -(* patterns of ast *) -type astpat = - | Pquote of Coqast.t - | Pmeta of string * tok_kind - | Pnode of string * patlist - | Pslam of identifier option * astpat - | Pmeta_slam of string * astpat - -and patlist = - | Pcons of astpat * patlist - | Plmeta of string - | Pnil - -and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist - -type pat = - | AstListPat of patlist - | PureAstPat of astpat - -(* semantic actions of grammar rules *) -type act = - | Act of constr_expr - | ActCase of act * (pat * act) list - | ActCaseList of act * (pat * act) list - -(* values associated to variables *) -type typed_ast = - | AstListNode of Coqast.t list - | PureAstNode of Coqast.t - -type ast_action_type = ETast | ETastl - -type dynamic_grammar = - | ConstrNode of constr_expr - | CasesPatternNode of cases_pattern_expr - -type grammar_action = - | SimpleAction of loc * dynamic_grammar - | CaseAction of - loc * grammar_action * ast_action_type * (t list * grammar_action) list - -type env = (string * typed_ast) list - -val coerce_to_id : constr_expr -> identifier located - -val coerce_global_to_id : reference -> identifier -val coerce_reference_to_id : reference -> identifier - -exception No_match of string - -val isMeta : string -> bool - -val print_ast : Coqast.t -> std_ppcmds -val print_astl : Coqast.t list -> std_ppcmds -val print_astpat : astpat -> std_ppcmds -val print_astlpat : patlist -> std_ppcmds - -(* Meta-syntax operations: matching and substitution *) - -type entry_env = (string * ast_action_type) list - -val grammar_type_error : loc * string -> 'a - -(* Converting and checking free meta-variables *) - -(* For old ast printer *) -val pat_sub : loc -> env -> astpat -> Coqast.t -val val_of_ast : entry_env -> Coqast.t -> astpat -val alpha_eq : Coqast.t * Coqast.t -> bool -val alpha_eq_val : typed_ast * typed_ast -> bool -val occur_var_ast : identifier -> Coqast.t -> bool -val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list -val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list -> - ('a * env) option -val to_pat : entry_env -> Coqast.t -> (astpat * entry_env) diff --git a/parsing/coqast.ml b/parsing/coqast.ml deleted file mode 100644 index 3811dd322..000000000 --- a/parsing/coqast.ml +++ /dev/null @@ -1,104 +0,0 @@ -(************************************************************************) -(* 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$ *) - -(*i*) -open Util -open Names -open Libnames -open Mod_subst -(*i*) - -type t = - | Node of loc * string * t list - | Nmeta of loc * string - | Nvar of loc * identifier - | Slam of loc * identifier option * t - | Smetalam of loc * string * t - | Num of loc * int - | Str of loc * string - | Id of loc * string - | Path of loc * kernel_name - | ConPath of loc * constant - | Dynamic of loc * Dyn.t - -type the_coq_ast = t - -let subst_meta bl ast = - let rec aux = function - | Node (_,"META", [Num(_, n)]) -> List.assoc n bl - | Node(loc, node_name, args) -> - Node(loc, node_name, List.map aux args) - | Slam(loc, var, arg) -> Slam(loc, var, aux arg) - | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg) - | other -> other - in - aux ast - -let rec collect_metas = function - | Node (_,"META", [Num(_, n)]) -> [n] - | Node(_, _, args) -> List.concat (List.map collect_metas args) - | Slam(loc, var, arg) -> collect_metas arg - | Smetalam(loc, var, arg) -> collect_metas arg - | _ -> [] - -(* Hash-consing *) -module Hloc = Hashcons.Make( - struct - type t = loc - type u = unit - let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2 - let hash_sub () x = x - let hash = Hashtbl.hash - end) - -module Hast = Hashcons.Make( - struct - type t = the_coq_ast - type u = - (the_coq_ast -> the_coq_ast) * - ((loc -> loc) * (string -> string) - * (identifier -> identifier) * (kernel_name -> kernel_name) - * (constant -> constant)) - let hash_sub (hast,(hloc,hstr,hid,hsp,hcon)) = function - | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al) - | Nmeta(l,s) -> Nmeta(hloc l, hstr s) - | Nvar(l,s) -> Nvar(hloc l, hid s) - | Slam(l,None,t) -> Slam(hloc l, None, hast t) - | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t) - | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t) - | Num(l,n) -> Num(hloc l, n) - | Id(l,s) -> Id(hloc l, hstr s) - | Str(l,s) -> Str(hloc l, hstr s) - | Path(l,d) -> Path(hloc l, hsp d) - | ConPath(l,d) -> ConPath(hloc l, hcon d) - | Dynamic(l,d) -> Dynamic(hloc l, d) - let equal a1 a2 = - match (a1,a2) with - | (Node(l1,s1,al1), Node(l2,s2,al2)) -> - (l1==l2 & s1==s2 & List.length al1 = List.length al2) - & List.for_all2 (==) al1 al2 - | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2 - | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2 - | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2 - | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2 - | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2 - | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2 - | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2 - | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2 - | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2) - | (ConPath(l1,d1), ConPath(l2,d2)) -> (l1==l2 & d1==d2) - | _ -> false - let hash = Hashtbl.hash - end) - -let hcons_ast (hstr,hid,hpath,hconpath) = - let hloc = Hashcons.simple_hcons Hloc.f () in - let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath,hconpath) in - (hast,hloc) diff --git a/parsing/coqast.mli b/parsing/coqast.mli deleted file mode 100644 index a083d09a6..000000000 --- a/parsing/coqast.mli +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $Id$ i*) - -(*i*) -open Util -open Names -open Libnames -(*i*) - -(* Abstract syntax trees. *) - -type t = - | Node of loc * string * t list - | Nmeta of loc * string - | Nvar of loc * identifier - | Slam of loc * identifier option * t - | Smetalam of loc * string * t - | Num of loc * int - | Str of loc * string - | Id of loc * string - | Path of loc * kernel_name - | ConPath of loc * constant - | Dynamic of loc * Dyn.t - -(* returns the list of metas occuring in the ast *) -val collect_metas : t -> int list - -(* [subst_meta bl ast]: for each binding [(i,c_i)] in [bl], - replace the metavar [?i] by [c_i] in [ast] *) -val subst_meta : (int * t) list -> t -> t - -(* hash-consing function *) -val hcons_ast: - (string -> string) * (Names.identifier -> Names.identifier) - * (kernel_name -> kernel_name) * (constant -> constant) - -> (t -> t) * (loc -> loc) - -(*i -val map_tactic_expr : (t -> t) -> (tactic_expr -> tactic_expr) -> tactic_expr -> tactic_expr -val fold_tactic_expr : - ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a -val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit -i*) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index be8b1e8ad..37dc007ee 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -10,52 +10,27 @@ open Pp open Util -open Extend open Pcoq +open Extend open Topconstr -open Ast open Genarg open Libnames open Nameops - -(* State of the grammar extensions *) - -type notation_grammar = - int * Gramext.g_assoc option * notation * prod_item list - -type all_grammar_command = - | Notation of Notation.level * notation_grammar - | Grammar of grammar_command - | TacticGrammar of - (string * int * grammar_production list * - (Names.dir_path * Tacexpr.glob_tactic_expr)) - -let (grammar_state : all_grammar_command list ref) = ref [] - +open Tacexpr +open Names +open Vernacexpr (**************************************************************************) -(* Interpretation of the right hand side of grammar rules *) - -(* When reporting errors, we add the name of the grammar rule that failed *) -let specify_name name e = - match e with - | UserError(lab,strm) -> - UserError(lab, (str"during interpretation of grammar rule " ++ - str name ++ str"," ++ spc () ++ strm)) - | Anomaly(lab,strm) -> - Anomaly(lab, (str"during interpretation of grammar rule " ++ - str name ++ str"," ++ spc () ++ strm)) - | Failure s -> - Failure("during interpretation of grammar rule "^name^", "^s) - | e -> e - -(* Translation of environments: a production +(* + * --- Note on the mapping of grammar productions to camlp4 actions --- + * + * Translation of environments: a production * [ nt1(x1) ... nti(xi) ] -> act(x1..xi) * is written (with camlp4 conventions): * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) * where v1..vi are the values generated by non-terminals nt1..nti. * Since the actions are executed by substituting an environment, - * make_act builds the following closure: + * the make_*_action family build the following closure: * * ((fun env -> * (fun vi -> @@ -69,11 +44,18 @@ let specify_name name e = * []) *) -open Names +(**********************************************************************) +(** Declare Notations grammar rules *) + +type prod_item = + | Term of Token.pattern + | NonTerm of constr_production_entry * + (Names.identifier * constr_production_entry) option type 'a action_env = (identifier * 'a) list -let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = +let make_constr_action + (f : loc -> constr_expr action_env -> constr_expr) pil = let rec make (env : constr_expr action_env) = function | [] -> Gramext.action (fun loc -> f loc env) @@ -97,7 +79,7 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil = failwith "Unexpected entry of type cases pattern" in make [] (List.rev pil) -let make_act_in_cases_pattern (* For Notations *) +let make_cases_pattern_action (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = let rec make (env : cases_pattern_expr action_env) = function | [] -> @@ -123,238 +105,92 @@ let make_act_in_cases_pattern (* For Notations *) failwith "Unexpected entry of type cases pattern or other" in make [] (List.rev pil) -(* For V7 Grammar only *) -let make_cases_pattern_act - (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil = - let rec make (env : cases_pattern_expr action_env) = function - | [] -> - Gramext.action (fun loc -> f loc env) - | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) - | Some (p, ETPattern) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,v) :: env) tl) - | Some (p, ETReference) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,CPatAtom(dummy_loc,Some v)) :: env) - tl) - | Some (p, ETBigint) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,CPatNumeral(dummy_loc,v)) :: env) tl) - | Some (p, (ETConstrList _ | ETIdent | ETConstr _ | ETOther _)) :: tl -> - error "ident and constr entry not admitted in patterns cases syntax extensions" in - make [] (List.rev pil) - -(* Grammar extension command. Rules are assumed correct. - * Type-checking of grammar rules is done during the translation of - * ast to the type grammar_command. We only check that the existing - * entries have the type assumed in the grammar command (these types - * annotations are added when type-checking the command, function - * Extend.of_ast) *) - -let symbol_of_prod_item univ assoc from forpat = function +let make_constr_prod_item univ assoc from forpat = function | Term tok -> (Gramext.Stoken tok, None) | NonTerm (nt, ovar) -> let eobj = symbol_of_production assoc from forpat nt in (eobj, ovar) -let coerce_to_id = function - | CRef (Ident (_,id)) -> id - | c -> - user_err_loc (constr_loc c, "subst_rawconstr", - str"This expression should be a simple identifier") - -let coerce_to_ref = function - | CRef r -> r - | c -> - user_err_loc (constr_loc c, "subst_rawconstr", - str"This expression should be a simple reference") - -let subst_ref loc subst id = - try coerce_to_ref (List.assoc id subst) with Not_found -> Ident (loc,id) - -let subst_pat_id loc subst id = - try List.assoc id subst - with Not_found -> CPatAtom (loc,Some (Ident (loc,id))) - -let subst_id subst id = - try coerce_to_id (List.assoc id subst) with Not_found -> id - -(* -let subst_cases_pattern_expr a loc subs = - let rec subst = function - | CPatAlias (_,p,x) -> CPatAlias (loc,subst p,x) - (* No subst in compound pattern ? *) - | CPatCstr (_,ref,pl) -> CPatCstr (loc,ref,List.map subst pl) - | CPatAtom (_,Some (Ident (_,id))) -> subst_pat_id loc subs id - | CPatAtom (_,x) -> CPatAtom (loc,x) - | CPatNotation (_,ntn,l) -> CPatNotation - | CPatNumeral (_,n) -> CPatNumeral (loc,n) - | CPatDelimiters (_,key,p) -> CPatDelimiters (loc,key,subst p) - in subst a -*) - -let subst_constr_expr a loc subs = - let rec subst = function - | CRef (Ident (_,id)) -> - (try List.assoc id subs with Not_found -> CRef (Ident (loc,id))) - (* Temporary: no robust treatment of substituted binders *) - | CLambdaN (_,[],c) -> subst c - | CLambdaN (_,([],t)::bl,c) -> subst (CLambdaN (loc,bl,c)) - | CLambdaN (_,((_,na)::bl,t)::bll,c) -> - let na = name_app (subst_id subs) na in - CLambdaN (loc,[[loc,na],subst t], subst (CLambdaN (loc,(bl,t)::bll,c))) - | CProdN (_,[],c) -> subst c - | CProdN (_,([],t)::bl,c) -> subst (CProdN (loc,bl,c)) - | CProdN (_,((_,na)::bl,t)::bll,c) -> - let na = name_app (subst_id subs) na in - CProdN (loc,[[loc,na],subst t], subst (CProdN (loc,(bl,t)::bll,c))) - | CLetIn (_,(_,na),b,c) -> - let na = name_app (subst_id subs) na in - CLetIn (loc,(loc,na),subst b,subst c) - | CArrow (_,a,b) -> CArrow (loc,subst a,subst b) - | CAppExpl (_,(p,Ident (_,id)),l) -> - CAppExpl (loc,(p,subst_ref loc subs id),List.map subst l) - | CAppExpl (_,r,l) -> CAppExpl (loc,r,List.map subst l) - | CApp (_,(p,a),l) -> - CApp (loc,(p,subst a),List.map (fun (a,i) -> (subst a,i)) l) - | CCast (_,a,k,b) -> CCast (loc,subst a,k,subst b) - | CNotation (_,n,l) -> CNotation (loc,n,List.map subst l) - | CDelimiters (_,s,a) -> CDelimiters (loc,s,subst a) - | CHole _ | CEvar _ | CPatVar _ | CSort _ - | CNumeral _ | CDynamic _ | CRef _ as x -> x - | CCases (_,(po,rtntypo),a,bl) -> - (* TODO: apply g on the binding variables in pat... *) - let bl = List.map (fun (_,pat,rhs) -> (loc,pat,subst rhs)) bl in - CCases (loc,(option_app subst po,option_app subst rtntypo), - List.map (fun (tm,x) -> subst tm,x) a,bl) - | COrderedCase (_,s,po,a,bl) -> - COrderedCase (loc,s,option_app subst po,subst a,List.map subst bl) - | CLetTuple (_,nal,(na,po),a,b) -> - let na = option_app (name_app (subst_id subs)) na in - let nal = List.map (name_app (subst_id subs)) nal in - CLetTuple (loc,nal,(na,option_app subst po),subst a,subst b) - | CIf (_,c,(na,po),b1,b2) -> - let na = option_app (name_app (subst_id subs)) na in - CIf (loc,subst c,(na,option_app subst po),subst b1,subst b2) - | CFix (_,id,dl) -> - CFix (loc,id,List.map (fun (id,n,bl, t,d) -> - (id,n, - List.map(function - LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) - | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, - subst t,subst d)) dl) - | CCoFix (_,id,dl) -> - CCoFix (loc,id,List.map (fun (id,bl,t,d) -> - (id, - List.map(function - LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty) - | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl, - subst t,subst d)) dl) - in subst a - -(* For V7 Grammar only *) -let make_rule_v7 univ assoc etyp rule = - if not !Options.v7 then anomaly "No Grammar in new syntax"; - let pil = List.map (symbol_of_prod_item univ assoc etyp false) rule.gr_production in - let (symbs,ntl) = List.split pil in - let act = match etyp with - | ETPattern -> - (* Ugly *) - let f loc env = match rule.gr_action, env with - | CRef (Ident(_,p)), [p',a] when p=p' -> a - | CDelimiters (_,s,CRef (Ident(_,p))), [p',a] when p=p' -> - CPatDelimiters (loc,s,a) - | _ -> error "Unable to handle this grammar extension of pattern" in - make_cases_pattern_act f ntl - | ETConstrList _ | ETIdent | ETBigint | ETReference -> error "Cannot extend" - | ETConstr _ | ETOther _ -> - make_act (subst_constr_expr rule.gr_action) ntl in - (symbs, act) - -(* Rules of a level are entered in reverse order, so that the first rules - are applied before the last ones *) -(* For V7 Grammar only *) -let extend_entry univ (te, etyp, pos, name, ass, p4ass, rls) = - let rules = List.rev (List.map (make_rule_v7 univ ass etyp) rls) in - grammar_extend te pos [(name, p4ass, rules)] - -(* Defines new entries. If the entry already exists, check its type *) -let define_entry univ {ge_name=typ; gl_assoc=ass; gl_rules=rls} = - let e,lev,keepassoc = get_constr_entry false typ in - let pos,p4ass,name = find_position false keepassoc ass lev in - (e,typ,pos,name,ass,p4ass,rls) - -(* Add a bunch of grammar rules. Does not check if it is well formed *) -(* For V7 Grammar only *) -let extend_grammar_rules gram = - let univ = get_univ gram.gc_univ in - let tl = List.map (define_entry univ) gram.gc_entries in - List.iter (extend_entry univ) tl - -(* Add a grammar rules for tactics *) -type grammar_tactic_production = - | TacTerm of string - | TacNonTerm of loc * (Gram.te Gramext.g_symbol * argument_type) * string option - -let make_prod_item = function - | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None) - | TacNonTerm (_,(nont,t), po) -> - (nont, option_app (fun p -> (p,t)) po) - -let make_gen_act f pil = - let rec make env = function - | [] -> - Gramext.action (fun loc -> f loc env) - | None :: tl -> (* parse a non-binding item *) - Gramext.action (fun _ -> make env tl) - | Some (p, t) :: tl -> (* non-terminal *) - Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in - make [] (List.rev pil) - -let extend_constr entry (n,assoc,pos,p4assoc,name) make_act (forpat,pt) = +let extend_constr entry (n,assoc,pos,p4assoc,name) mkact (forpat,pt) = let univ = get_univ "constr" in - let pil = List.map (symbol_of_prod_item univ assoc n forpat) pt in + let pil = List.map (make_constr_prod_item univ assoc n forpat) pt in let (symbs,ntl) = List.split pil in - let act = make_act ntl in - grammar_extend entry pos [(name, p4assoc, [symbs, act])] + grammar_extend entry pos [(name, p4assoc, [symbs, mkact ntl])] let extend_constr_notation (n,assoc,ntn,rule) = + (* Add the notation in constr *) let mkact loc env = CNotation (loc,ntn,List.map snd env) in let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in let pos,p4assoc,name = find_position false keepassoc assoc level in extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name) - (make_act mkact) (false,rule); - if not !Options.v7 then + (make_constr_action mkact) (false,rule); + (* Add the notation in cases_pattern *) let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in let pos,p4assoc,name = find_position true keepassoc assoc level in extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name) - (make_act_in_cases_pattern mkact) (true,rule) + (make_cases_pattern_action mkact) (true,rule) + +(**********************************************************************) +(** Making generic actions in type generic_argument *) + +let make_generic_action + (f:loc -> ('b * raw_generic_argument) list -> 'a) pil = + let rec make env = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, t) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in + make [] (List.rev pil) -(* These grammars are not a removable *) let make_rule univ f g pt = let (symbs,ntl) = List.split (List.map g pt) in - let act = make_gen_act f ntl in + let act = make_generic_action f ntl in (symbs, act) +(**********************************************************************) +(** Grammar extensions declared at ML level *) + +type grammar_tactic_production = + | TacTerm of string + | TacNonTerm of + loc * (Gram.te Gramext.g_symbol * argument_type) * string option + +let make_prod_item = function + | TacTerm s -> (Gramext.Stoken (Lexer.terminal s), None) + | TacNonTerm (_,(nont,t), po) -> (nont, option_app (fun p -> (p,t)) po) + +(* Tactic grammar extensions *) + let tac_exts = ref [] let get_extend_tactic_grammars () = !tac_exts let extend_tactic_grammar s gl = tac_exts := (s,gl) :: !tac_exts; let univ = get_univ "tactic" in - let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in - let rules = List.map (make_rule univ make_act make_prod_item) gl in + let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in + let rules = List.map (make_rule univ mkact make_prod_item) gl in Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)] +(* Vernac grammar extensions *) + let vernac_exts = ref [] let get_extend_vernac_grammars () = !vernac_exts let extend_vernac_command_grammar s gl = vernac_exts := (s,gl) :: !vernac_exts; let univ = get_univ "vernac" in - let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in - let rules = List.map (make_rule univ make_act make_prod_item) gl in + let mkact loc l = VernacExtend (s,List.map snd l) in + let rules = List.map (make_rule univ mkact make_prod_item) gl in Gram.extend Vernac_.command None [(None, None, List.rev rules)] +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +(* Interpretation of the grammar entry names *) + let find_index s t = let t,n = repr_ident (id_of_string t) in if s <> t or n = None then raise Not_found; @@ -374,23 +210,12 @@ let rec interp_entry_name up_level u s = else try let i = find_index "tactic" s in - if !Options.v7 then - let e = match i with - | 2 -> Tactic.tactic_expr2 - | 3 -> Tactic.tactic_expr3 - | 4 -> Tactic.tactic_expr4 - | 5 -> Tactic.tactic_expr5 - | _ -> error ("Unknown entry "^s) - in TacticArgType i, Gramext.Snterm (Pcoq.Gram.Entry.obj e) - else - TacticArgType i, - if i=up_level then Gramext.Sself else - if i=up_level-1 then Gramext.Snext else - Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i) + TacticArgType i, + if i=up_level then Gramext.Sself else + if i=up_level-1 then Gramext.Snext else + Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i) with Not_found -> let e = - if !Options.v7 then get_entry (get_univ u) s - else (* Qualified entries are no longer in use *) try get_entry (get_univ "tactic") s with _ -> @@ -403,59 +228,60 @@ let rec interp_entry_name up_level u s = let t = type_of_typed_entry e in t,Gramext.Snterm (Pcoq.Gram.Entry.obj o) -let qualified_nterm current_univ = function - | NtQual (univ, en) -> if !Options.v7 then (univ, en) else assert false - | NtShort en -> (current_univ, en) - let make_vprod_item n univ = function - | VTerm s -> (Gramext.Stoken (Extend.terminal s), None) + | VTerm s -> (Gramext.Stoken (Lexer.terminal s), None) | VNonTerm (loc, nt, po) -> - let (u,nt) = qualified_nterm univ nt in - let (etyp, e) = interp_entry_name n u nt in + let (etyp, e) = interp_entry_name n univ nt in e, option_app (fun p -> (p,etyp)) po let get_tactic_entry n = - if n = 0 then weaken_entry Tactic.simple_tactic, None - else if !Options.v7 then - let e = match n with - | 2 -> Tactic.tactic_expr2 - | 3 -> Tactic.tactic_expr3 - | 4 -> Tactic.tactic_expr4 - | 5 -> Tactic.tactic_expr5 - | _ -> error ("Invalid v7 Tactic Notation level: "^(string_of_int n)) in - weaken_entry e, None - else - if 1<=n && n<=5 then - weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)) + if n = 0 then + weaken_entry Tactic.simple_tactic, None + else if 1<=n && n<=5 then + weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)) -open Tacexpr +(* Declaration of the tactic grammar rule *) let head_is_ident = function VTerm _::_ -> true | _ -> false let add_tactic_entry (key,lev,prods,tac) = let univ = get_univ "tactic" in let entry, pos = get_tactic_entry lev in + let mkprod = make_vprod_item lev "tactic" in let rules = if lev = 0 then begin if not (head_is_ident prods) then error "Notation for simple tactic must start with an identifier"; - let make_act s tac loc l = + let mkact s tac loc l = (TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in - make_rule univ (make_act key tac) (make_vprod_item lev "tactic") prods + make_rule univ (mkact key tac) mkprod prods end else - let make_act s tac loc l = + let mkact s tac loc l = (TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in - make_rule univ (make_act key tac) (make_vprod_item lev "tactic") prods in + make_rule univ (mkact key tac) mkprod prods in let _ = find_position true true None None (* to synchronise with remove *) in grammar_extend entry pos [(None, None, List.rev [rules])] +(**********************************************************************) +(** State of the grammar extensions *) + +type notation_grammar = + int * Gramext.g_assoc option * notation * prod_item list + +type all_grammar_command = + | Notation of Notation.level * notation_grammar + | TacticGrammar of + (string * int * grammar_production list * + (Names.dir_path * Tacexpr.glob_tactic_expr)) + +let (grammar_state : all_grammar_command list ref) = ref [] + let extend_grammar gram = (match gram with | Notation (_,a) -> extend_constr_notation a - | Grammar g -> extend_grammar_rules g | TacticGrammar g -> add_tactic_entry g); grammar_state := gram :: !grammar_state @@ -464,7 +290,7 @@ let reset_extend_grammars_v8 () = let tv = List.rev !vernac_exts in tac_exts := []; vernac_exts := []; - List.iter (fun (s,gl) -> extend_tactic_grammar s gl) te; + List.iter (fun (s,gl) -> print_string ("Resinstalling "^s); flush stdout; extend_tactic_grammar s gl) te; List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv let recover_notation_grammar ntn prec = @@ -489,11 +315,7 @@ let factorize_grams l1 l2 = let number_of_entries gcl = List.fold_left (fun n -> function - | Notation _ -> - if !Options.v7 then n + 1 - else n + 2 (* 1 for operconstr, 1 for pattern *) - | Grammar gc -> - n + (List.length gc.gc_entries) + | Notation _ -> n + 2 (* 1 for operconstr, 1 for pattern *) | TacticGrammar _ -> n + 1) 0 gcl diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index 06ab2b42f..92efd0824 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -11,21 +11,29 @@ (*i*) open Util open Topconstr -open Ast -open Coqast +open Pcoq +open Extend open Vernacexpr open Ppextend -open Extend open Rawterm open Mod_subst (*i*) +(** Mapping of grammar productions to camlp4 actions + Used for Coq-level Notation and Tactic Notation, + and for ML-level tactic and vernac extensions + *) + +type prod_item = + | Term of Token.pattern + | NonTerm of constr_production_entry * + (Names.identifier * constr_production_entry) option + type notation_grammar = int * Gramext.g_assoc option * notation * prod_item list type all_grammar_command = | Notation of (precedence * tolerability list) * notation_grammar - | Grammar of grammar_command | TacticGrammar of (string * int * grammar_production list * (Names.dir_path * Tacexpr.glob_tactic_expr)) @@ -33,22 +41,26 @@ type all_grammar_command = val extend_grammar : all_grammar_command -> unit (* Add grammar rules for tactics *) + type grammar_tactic_production = | TacTerm of string - | TacNonTerm of loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option + | TacNonTerm of + loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option val extend_tactic_grammar : string -> grammar_tactic_production list list -> unit val extend_vernac_command_grammar : string -> grammar_tactic_production list list -> unit - +(* val get_extend_tactic_grammars : unit -> (string * grammar_tactic_production list list) list +*) val get_extend_vernac_grammars : unit -> (string * grammar_tactic_production list list) list +(* val reset_extend_grammars_v8 : unit -> unit - +*) val interp_entry_name : int -> string -> string -> entry_type * Token.t Gramext.g_symbol diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml deleted file mode 100644 index 1ee900dbc..000000000 --- a/parsing/esyntax.ml +++ /dev/null @@ -1,276 +0,0 @@ -(************************************************************************) -(* 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$ *) - -open Pp -open Util -open Names -open Libnames -open Coqast -open Ast -open Extend -open Ppextend -open Names -open Nametab -open Topconstr -open Notation - -(*** Syntax keys ***) - -(* We define keys for ast and astpats. This is a kind of hash - * function. An ast may have several keys, but astpat only one. The - * idea is that if an ast A matches a pattern P, then the key of P - * is in the set of keys of A. Thus, we can split the syntax entries - * according to the key of the pattern. *) - -type key = - | Cst of Names.constant (* keys for global constants rules *) - | SecVar of Names.variable - | Ind of Names.inductive - | Cstr of Names.constructor - | Nod of string (* keys for other constructed asts rules *) - | Oth (* key for other syntax rules *) - | All (* key for catch-all rules (i.e. with a pattern such as $x .. *) - -let warning_verbose = ref true - -let ast_keys = function - | Node(_,"APPLIST", Node(_,"CONST", [ConPath (_,sl)]) ::_) -> - [Cst sl; Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"SECVAR", [Nvar (_,s)]) ::_) -> - [SecVar s; Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) -> - [Ind (sl,tyi); Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT", - [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) -> - [Cstr ((sl,tyi),i); Nod "APPLIST"; All] - | Node(_,s,_) -> [Nod s; All] - | _ -> [Oth; All] - -let spat_key astp = - match astp with - | Pnode("APPLIST", - Pcons(Pnode("CONST", - Pcons(Pquote(ConPath (_,sl)),_)), _)) - -> Cst sl - | Pnode("APPLIST", - Pcons(Pnode("SECVAR", - Pcons(Pquote(Nvar (_,s)),_)), _)) - -> SecVar s - | Pnode("APPLIST", - Pcons(Pnode("MUTIND", - Pcons(Pquote(Path (_,sl)), - Pcons(Pquote(Num (_,tyi)),_))), _)) - -> Ind (sl,tyi) - | Pnode("APPLIST", - Pcons(Pnode("MUTCONSTRUCT", - Pcons(Pquote(Path (_,sl)), - Pcons(Pquote(Num (_,tyi)), - Pcons(Pquote(Num (_,i)),_)))), _)) - -> Cstr ((sl,tyi),i) - | Pnode(na,_) -> Nod na - | Pquote ast -> List.hd (ast_keys ast) - | Pmeta _ -> All - | _ -> Oth - -let se_key se = spat_key se.syn_astpat - -(** Syntax entry tables (state of the pretty_printer) **) -let from_name_table = ref Gmap.empty -let from_key_table = ref Gmapl.empty - -(* Summary operations *) -type frozen_t = (string * string, astpat syntax_entry) Gmap.t * - (string * key, astpat syntax_entry) Gmapl.t - -let freeze () = - (!from_name_table, !from_key_table) - -let unfreeze (fnm,fkm) = - from_name_table := fnm; - from_key_table := fkm - -let init () = - from_name_table := Gmap.empty; - from_key_table := Gmapl.empty - -let find_syntax_entry whatfor gt = - let gt_keys = ast_keys gt in - let entries = - List.flatten - (List.map (fun k -> Gmapl.find (whatfor,k) !from_key_table) gt_keys) - in - find_all_matches (fun se -> se.syn_astpat) [] gt entries - -let remove_with_warning name = - if Gmap.mem name !from_name_table then begin - let se = Gmap.find name !from_name_table in - let key = (fst name, se_key se) in - if !warning_verbose then - (Options.if_verbose - warning ("overriding syntax rule "^(fst name)^":"^(snd name)^".")); - from_name_table := Gmap.remove name !from_name_table; - from_key_table := Gmapl.remove key se !from_key_table - end - -let add_rule whatfor se = - let name = (whatfor,se.syn_id) in - let key = (whatfor, se_key se) in - remove_with_warning name; - from_name_table := Gmap.add name se !from_name_table; - from_key_table := Gmapl.add key se !from_key_table - -let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel - - -(* Pretty-printing machinery *) - -type std_printer = Coqast.t -> std_ppcmds -type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Coqast.t -> std_ppcmds option - -(* Module of primitive printers *) -module Ppprim = - struct - type t = std_printer -> std_printer - let tab = ref ([] : (string * t) list) - let map a = List.assoc a !tab - let add (a,ppr) = tab := (a,ppr)::!tab - end - -(**********************************************************************) -(* Primitive printers (e.g. for numerals) *) - -(* This is the map associating to a printer the scope it belongs to *) -(* and its ML code *) - -let primitive_printer_tab = - ref (Stringmap.empty : (scope_name * primitive_printer) Stringmap.t) -let declare_primitive_printer s sc pp = - primitive_printer_tab := Stringmap.add s (sc,pp) !primitive_printer_tab -let lookup_primitive_printer s = - Stringmap.find s !primitive_printer_tab - -(* Register the primitive printer for "token". It is not used in syntax/PP*.v, - * but any ast matching no PP rule is printed with it. *) -(* -let _ = declare_primitive_printer "token" token_printer -*) - -(* A printer for the tokens. *) -let token_printer stdpr = function - | (Id _ | Num _ | Str _ | Path _ | ConPath _ as ast) -> print_ast ast - | a -> stdpr a - -(* Unused ?? -(* A primitive printer to do "print as" (to specify a length for a string) *) -let print_as_printer = function - | Node (_, "AS", [Num(_,n); Str(_,s)]) -> Some (stras (n,s)) - | ast -> None - -let _ = declare_primitive_printer "print_as" default_scope print_as_printer -*) - -(* Handle infix symbols *) - -let pr_parenthesis inherited se strm = - if tolerable_prec inherited se.syn_prec then - strm - else - (str"(" ++ strm ++ str")") - -let print_delimiters inh se strm = function - | None -> pr_parenthesis inh se strm - | Some key -> - let left = "'"^key^":" and right = "'" in - let lspace = - if is_letter (left.[String.length left -1]) then str " " else mt () in - let rspace = - let c = right.[0] in - if is_ident_tail c then str " " else mt () in - hov 0 (str left ++ lspace ++ strm ++ rspace ++ str right) - -(* Print the syntax entry. In the unparsing hunks, the tokens are - * printed using the token_printer, unless another primitive printer - * is specified. *) - -let print_syntax_entry sub_pr scopes env se = - let rec print_hunk rule_prec scopes = function - | PH(e,externpr,reln) -> - let node = Ast.pat_sub dummy_loc env e in - let printer = - match externpr with (* May branch to an other printer *) - | Some c -> - (try (* Test for a primitive printer *) Ppprim.map c - with Not_found -> token_printer) - | _ -> token_printer in - printer (sub_pr scopes (Some(rule_prec,reln))) node - | RO s -> str s - | UNP_TAB -> tab () - | UNP_FNL -> fnl () - | UNP_BRK(n1,n2) -> brk(n1,n2) - | UNP_TBRK(n1,n2) -> tbrk(n1,n2) - | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub) - | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser" - in - prlist (print_hunk se.syn_prec scopes) se.syn_hunks - -let call_primitive_parser rec_pr otherwise inherited scopes (se,env) = - try ( - match se.syn_hunks with - | [PH(e,Some c,reln)] -> - (* Test for a primitive printer; may raise Not_found *) - let sc,pr = lookup_primitive_printer c in - (* Look if scope [sc] associated to this printer is OK *) - (match Notation.availability_of_numeral sc scopes with - | None -> otherwise () - | Some key -> - (* We can use this printer *) - let node = Ast.pat_sub dummy_loc env e in - match pr node with - | Some strm -> print_delimiters inherited se strm key - | None -> otherwise ()) - | [UNP_SYMBOLIC (sc,pat,sub)] -> - (match Notation.availability_of_notation (sc,pat) scopes with - | None -> otherwise () - | Some (scopt,key) -> - print_delimiters inherited se - (print_syntax_entry rec_pr - (option_fold_right Notation.push_scope scopt scopes) env - {se with syn_hunks = [sub]}) key) - | _ -> - pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) - ) - with Not_found -> (* To handle old style printer *) - pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se) - -(* [genprint whatfor dflt inhprec ast] prints out the ast of - * 'universe' whatfor. If the term is not matched by any - * pretty-printing rule, then it will call dflt on it, which is - * responsible for printing out the term (usually #GENTERM...). - * In the case of tactics and commands, dflt also prints - * global constants basenames. *) - -let genprint dflt whatfor inhprec ast = - let rec rec_pr scopes inherited gt = - let entries = find_syntax_entry whatfor gt in - let rec test_rule = function - | se_env::rules -> - call_primitive_parser - rec_pr - (fun () -> test_rule rules) - inherited scopes se_env - | [] -> dflt gt (* No rule found *) - in test_rule entries - in - try - rec_pr (Notation.current_scopes ()) inhprec ast - with - | Failure _ -> (str"<PP failure: " ++ dflt ast ++ str">") - | Not_found -> (str"<PP search failure: " ++ dflt ast ++ str">") diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli deleted file mode 100644 index 0344a27e2..000000000 --- a/parsing/esyntax.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $Id$ i*) - -(*i*) -open Pp -open Extend -open Notation -open Ppextend -open Topconstr -(*i*) - -(* Syntax entry tables. *) - -type frozen_t - -(* pretty-printer summary operations *) -val init : unit -> unit -val freeze : unit -> frozen_t -val unfreeze : frozen_t -> unit - -(* Search and add a PP rule for an ast in the summary *) -val find_syntax_entry : - string -> Coqast.t -> (Ast.astpat syntax_entry * Ast.env) list -val add_rule : string -> Ast.astpat syntax_entry -> unit -val add_ppobject : Ast.astpat syntax_command -> unit -val warning_verbose : bool ref - -(* Pretty-printing *) - -type std_printer = Coqast.t -> std_ppcmds -type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Coqast.t -> std_ppcmds option - -(* Module of constr primitive printers [old style - no scope] *) -module Ppprim : - sig - type t = std_printer -> std_printer - val add : string * t -> unit - end - -val declare_primitive_printer : - string -> scope_name -> primitive_printer -> unit - -(* Generic printing functions *) -val genprint : std_printer -> unparsing_subfunction diff --git a/parsing/extend.ml b/parsing/extend.ml index d6587e1ec..fbea84e7b 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -13,12 +13,12 @@ open Util open Pp open Gramext open Names -open Ast open Ppextend open Topconstr open Genarg -type entry_type = argument_type +(**********************************************************************) +(* constr entry keys *) type production_position = | BorderProd of bool * Gramext.g_assoc option (* true=left; false=right *) @@ -37,54 +37,13 @@ type ('lev,'pos) constr_entry_key = type constr_production_entry = (production_level,production_position) constr_entry_key -type constr_entry = (int,unit) constr_entry_key -type simple_constr_production_entry = (production_level,unit) constr_entry_key - -type nonterm_prod = - | ProdList0 of nonterm_prod - | ProdList1 of nonterm_prod * Token.pattern list - | ProdOpt of nonterm_prod - | ProdPrimitive of constr_production_entry - -type prod_item = - | Term of Token.pattern - | NonTerm of constr_production_entry * - (Names.identifier * constr_production_entry) option - -type grammar_rule = { - gr_name : string; - gr_production : prod_item list; - gr_action : constr_expr } - -type grammar_entry = { - ge_name : constr_entry; - gl_assoc : Gramext.g_assoc option; - gl_rules : grammar_rule list } - -type grammar_command = { - gc_univ : string; - gc_entries : grammar_entry list } - -type grammar_associativity = Gramext.g_assoc option +type constr_entry = + (int,unit) constr_entry_key +type simple_constr_production_entry = + (production_level,unit) constr_entry_key (**********************************************************************) -(* Globalisation and type-checking of Grammar actions *) - -type entry_context = identifier list - -open Rawterm -open Libnames - -let globalizer = ref (fun _ _ -> CHole dummy_loc) -let set_constr_globalizer f = globalizer := f - -let act_of_ast vars = function - | SimpleAction (loc,ConstrNode a) -> !globalizer vars a - | SimpleAction (loc,CasesPatternNode a) -> - failwith "TODO:act_of_ast: cases_pattern" - | CaseAction _ -> failwith "case/let not supported" - -let to_act_check_vars = act_of_ast +(* syntax modifiers *) type syntax_modifier = | SetItemLevel of string list * production_level @@ -94,285 +53,3 @@ type syntax_modifier = | SetOnlyParsing | SetFormat of string located -type nonterm = - | NtShort of string - | NtQual of string * string -type grammar_production = - | VTerm of string - | VNonTerm of loc * nonterm * Names.identifier option -type raw_grammar_rule = string * grammar_production list * grammar_action -type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list - -(* No kernel names in Grammar's *) -let subst_constr_expr _ a = a - -let subst_grammar_rule subst gr = - { gr with gr_action = subst_constr_expr subst gr.gr_action } - -let subst_grammar_entry subst ge = - { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules } - -let subst_grammar_command subst gc = - { gc with gc_entries = List.map (subst_grammar_entry subst) gc.gc_entries } - - -(*s Terminal symbols interpretation *) - -let is_ident_not_keyword s = - match s.[0] with - | 'a'..'z' | 'A'..'Z' | '_' -> not (Lexer.is_keyword s) - | _ -> false - -let is_number s = - match s.[0] with - | '0'..'9' -> true - | _ -> false - -let strip s = - let len = - let rec loop i len = - if i = String.length s then len - else if s.[i] == ' ' then loop (i + 1) len - else loop (i + 1) (len + 1) - in - loop 0 0 - in - if len == String.length s then s - else - let s' = String.create len in - let rec loop i i' = - if i == String.length s then s' - else if s.[i] == ' ' then loop (i + 1) i' - else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end - in - loop 0 0 - -let terminal s = - let s = strip s in - if s = "" then failwith "empty token"; - if is_ident_not_keyword s then ("IDENT", s) - else if is_number s then ("INT", s) - else ("", s) - -(*s Non-terminal symbols interpretation *) - -(* For compatibility *) -let warn nt nt' = - warning ("'"^nt^"' grammar entry is obsolete; use name '"^nt'^"' instead"); - nt' - -let rename_command_entry nt = - if String.length nt >= 7 & String.sub nt 0 7 = "command" - then warn nt ("constr"^(String.sub nt 7 (String.length nt - 7))) - else if nt = "lcommand" then warn nt "lconstr" - else if nt = "lassoc_command4" then warn nt "lassoc_constr4" - else nt - -(* This translates constr0, constr1, ... level into camlp4 levels of constr *) - -let explicitize_prod_entry inj pos univ nt = - if univ = "prim" & nt = "var" then ETIdent else - if univ = "prim" & nt = "bigint" then ETBigint else - if univ <> "constr" then ETOther (univ,nt) else - match nt with - | "constr0" -> ETConstr (inj 0,pos) - | "constr1" -> ETConstr (inj 1,pos) - | "constr2" -> ETConstr (inj 2,pos) - | "constr3" -> ETConstr (inj 3,pos) - | "lassoc_constr4" -> ETConstr (inj 4,pos) - | "constr5" -> ETConstr (inj 5,pos) - | "constr6" -> ETConstr (inj 6,pos) - | "constr7" -> ETConstr (inj 7,pos) - | "constr8" -> ETConstr (inj 8,pos) - | "constr" when !Options.v7 -> ETConstr (inj 8,pos) - | "constr9" -> ETConstr (inj 9,pos) - | "constr10" | "lconstr" -> ETConstr (inj 10,pos) - | "pattern" -> ETPattern - | "ident" -> ETIdent - | "global" -> ETReference - | _ -> ETOther (univ,nt) - -let explicitize_entry = explicitize_prod_entry (fun x -> x) () - -(* Express border sub entries in function of the from level and an assoc *) -(* We're cheating: not necessarily the same assoc on right and left *) -let clever_explicitize_prod_entry pos univ from en = - let t = explicitize_prod_entry (fun x -> NumLevel x) pos univ en in - match from with - | ETConstr (from,()) -> - (match t with - | ETConstr (n,BorderProd (left,None)) - when (n=NumLevel from & left) -> - ETConstr (n,BorderProd (left,Some Gramext.LeftA)) - | ETConstr (NumLevel n,BorderProd (left,None)) - when (n=from-1 & not left) -> - ETConstr - (NumLevel (n+1),BorderProd (left,Some Gramext.LeftA)) - | ETConstr (NumLevel n,BorderProd (left,None)) - when (n=from-1 & left) -> - ETConstr - (NumLevel (n+1),BorderProd (left,Some Gramext.RightA)) - | ETConstr (n,BorderProd (left,None)) - when (n=NumLevel from & not left) -> - ETConstr (n,BorderProd (left,Some Gramext.RightA)) - | t -> t) - | _ -> t - -let qualified_nterm current_univ pos from = function - | NtQual (univ, en) -> - clever_explicitize_prod_entry pos univ from en - | NtShort en -> - clever_explicitize_prod_entry pos current_univ from en - -let check_entry check_entry_type = function - | ETOther (u,n) -> check_entry_type (u,n) - | _ -> () - -let nterm loc (((check_entry_type,univ),from),pos) nont = - let typ = qualified_nterm univ pos from nont in - check_entry check_entry_type typ; - typ - -let prod_item univ env = function - | VTerm s -> env, Term (terminal s) - | VNonTerm (loc, nt, Some p) -> - let typ = nterm loc univ nt in - (p :: env, NonTerm (typ, Some (p,typ))) - | VNonTerm (loc, nt, None) -> - let typ = nterm loc univ nt in - env, NonTerm (typ, None) - -let rec prod_item_list univ penv pil current_pos = - match pil with - | [] -> [], penv - | pi :: pitl -> - let pos = if pitl=[] then (BorderProd (false,None)) else current_pos in - let (env, pic) = prod_item (univ,pos) penv pi in - let (pictl, act_env) = prod_item_list univ env pitl InternalProd in - (pic :: pictl, act_env) - -let gram_rule univ (name,pil,act) = - let (pilc, act_env) = prod_item_list univ [] pil (BorderProd (true,None)) in - let a = to_act_check_vars act_env act in - { gr_name = name; gr_production = pilc; gr_action = a } - -let border = function - | NonTerm (ETConstr(_,BorderProd (_,a)),_) :: _ -> a - | _ -> None - -let clever_assoc ass g = - if g.gr_production <> [] then - (match border g.gr_production, border (List.rev g.gr_production) with - | Some LeftA, Some RightA -> ass (* Untractable; we cheat *) - | Some LeftA, _ -> Some LeftA - | _, Some RightA -> Some RightA - | _ -> Some NonA) - else ass - -let gram_entry univ (nt, ass, rl) = - let from = explicitize_entry (snd univ) nt in - let l = List.map (gram_rule (univ,from)) rl in - let ass = List.fold_left clever_assoc ass l in - { ge_name = from; - gl_assoc = ass; - gl_rules = l } - -let interp_grammar_command univ ge entryl = - { gc_univ = univ; - gc_entries = List.map (gram_entry (ge,univ)) entryl } - -(* unparsing objects *) - -type 'pat unparsing_hunk = - | PH of 'pat * string option * parenRelation - | RO of string - | UNP_BOX of ppbox * 'pat unparsing_hunk list - | UNP_BRK of int * int - | UNP_TBRK of int * int - | UNP_TAB - | UNP_FNL - | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk - -let rec subst_hunk subst_pat subst hunk = match hunk with - | PH (pat,so,pr) -> - let pat' = subst_pat subst pat in - if pat'==pat then hunk else - PH (pat',so,pr) - | RO _ -> hunk - | UNP_BOX (ppbox, hunkl) -> - let hunkl' = list_smartmap (subst_hunk subst_pat subst) hunkl in - if hunkl' == hunkl then hunk else - UNP_BOX (ppbox, hunkl') - | UNP_BRK _ - | UNP_TBRK _ - | UNP_TAB - | UNP_FNL -> hunk - | UNP_SYMBOLIC (s1, s2, pat) -> - let pat' = subst_hunk subst_pat subst pat in - if pat' == pat then hunk else - UNP_SYMBOLIC (s1, s2, pat') - -(* Checks if the precedence of the parent printer (None means the - highest precedence), and the child's one, follow the given - relation. *) - -let tolerable_prec oparent_prec_reln child_prec = - match oparent_prec_reln with - | Some (pprec, L) -> child_prec < pprec - | Some (pprec, E) -> child_prec <= pprec - | Some (_, Prec level) -> child_prec <= level - | _ -> true - -type 'pat syntax_entry = { - syn_id : string; - syn_prec: precedence; - syn_astpat : 'pat; - syn_hunks : 'pat unparsing_hunk list } - -let subst_syntax_entry subst_pat subst sentry = - let syn_astpat' = subst_pat subst sentry.syn_astpat in - let syn_hunks' = list_smartmap (subst_hunk subst_pat subst) sentry.syn_hunks - in - if syn_astpat' == sentry.syn_astpat - && syn_hunks' == sentry.syn_hunks then sentry - else - { sentry with - syn_astpat = syn_astpat' ; - syn_hunks = syn_hunks' ; - } - -type 'pat syntax_command = { - sc_univ : string; - sc_entries : 'pat syntax_entry list } - -let subst_syntax_command subst_pat subst scomm = - let sc_entries' = - list_smartmap (subst_syntax_entry subst_pat subst) scomm.sc_entries - in - if sc_entries' == scomm.sc_entries then scomm else - { scomm with sc_entries = sc_entries' } - -type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type raw_syntax_entry = precedence * syntax_rule list - -let rec interp_unparsing env = function - | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr) - | UNP_BOX (b,ul) -> UNP_BOX (b,List.map (interp_unparsing env) ul) - | UNP_BRK _ | RO _ | UNP_TBRK _ | UNP_TAB | UNP_FNL as x -> x - | UNP_SYMBOLIC (x,y,u) -> UNP_SYMBOLIC (x,y,interp_unparsing env u) - -let rule_of_ast univ prec (s,spat,unp) = - let (astpat,meta_env) = Ast.to_pat [] spat in - let hunks = List.map (interp_unparsing meta_env) unp in - { syn_id = s; - syn_prec = prec; - syn_astpat = astpat; - syn_hunks = hunks } - -let level_of_ast univ (prec,rl) = List.map (rule_of_ast univ prec) rl - -let interp_syntax_entry univ sel = - { sc_univ = univ; - sc_entries = List.flatten (List.map (level_of_ast univ) sel)} - - diff --git a/parsing/extend.mli b/parsing/extend.mli index 80a0e4448..6a51d738d 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -8,9 +8,9 @@ (*i $Id$ i*) -(*i*) -open Pp open Util +(*i +open Pp open Names open Ast open Coqast @@ -18,9 +18,10 @@ open Ppextend open Topconstr open Genarg open Mod_subst -(*i*) +i*) -type entry_type = argument_type +(**********************************************************************) +(* constr entry keys *) type production_position = | BorderProd of bool * Gramext.g_assoc option (* true=left; false=right *) @@ -39,41 +40,13 @@ type ('lev,'pos) constr_entry_key = type constr_production_entry = (production_level,production_position) constr_entry_key -type constr_entry = (int,unit) constr_entry_key -type simple_constr_production_entry = (production_level,unit) constr_entry_key - -type nonterm_prod = - | ProdList0 of nonterm_prod - | ProdList1 of nonterm_prod * Token.pattern list - | ProdOpt of nonterm_prod - | ProdPrimitive of constr_production_entry - -type prod_item = - | Term of Token.pattern - | NonTerm of constr_production_entry * - (Names.identifier * constr_production_entry) option - -type grammar_rule = { - gr_name : string; - gr_production : prod_item list; - gr_action : constr_expr } - -type grammar_entry = { - ge_name : constr_entry; - gl_assoc : Gramext.g_assoc option; - gl_rules : grammar_rule list } - -type grammar_command = { - gc_univ : string; - gc_entries : grammar_entry list } +type constr_entry = + (int,unit) constr_entry_key +type simple_constr_production_entry = + (production_level,unit) constr_entry_key -type grammar_associativity = Gramext.g_assoc option - -(* Globalisation and type-checking of Grammar actions *) -type entry_context = identifier list - -val set_constr_globalizer : - (entry_context -> constr_expr -> constr_expr) -> unit +(**********************************************************************) +(* syntax modifiers *) type syntax_modifier = | SetItemLevel of string list * production_level @@ -83,67 +56,3 @@ type syntax_modifier = | SetOnlyParsing | SetFormat of string located -type nonterm = - | NtShort of string - | NtQual of string * string -type grammar_production = - | VTerm of string - | VNonTerm of loc * nonterm * Names.identifier option -type raw_grammar_rule = string * grammar_production list * grammar_action -type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list - -val terminal : string -> string * string - -val rename_command_entry : string -> string - -val explicitize_entry : string -> string -> constr_entry - -val subst_grammar_command : - substitution -> grammar_command -> grammar_command - -(* unparsing objects *) - -type 'pat unparsing_hunk = - | PH of 'pat * string option * parenRelation - | RO of string - | UNP_BOX of ppbox * 'pat unparsing_hunk list - | UNP_BRK of int * int - | UNP_TBRK of int * int - | UNP_TAB - | UNP_FNL - | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk - -(* Checks if the precedence of the parent printer (None means the - highest precedence), and the child's one, follow the given - relation. *) - -val tolerable_prec : tolerability option -> precedence -> bool - -type 'pat syntax_entry = { - syn_id : string; - syn_prec: precedence; - syn_astpat : 'pat; - syn_hunks : 'pat unparsing_hunk list } - -val subst_syntax_entry : - (substitution -> 'pat -> 'pat) -> - substitution -> 'pat syntax_entry -> 'pat syntax_entry - - -type 'pat syntax_command = { - sc_univ : string; - sc_entries : 'pat syntax_entry list } - -val subst_syntax_command : - (substitution -> 'pat -> 'pat) -> - substitution -> 'pat syntax_command -> 'pat syntax_command - -type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type raw_syntax_entry = precedence * syntax_rule list - -val interp_grammar_command : - string -> (string * string -> unit) -> - raw_grammar_entry list -> grammar_command - -val interp_syntax_entry : - string -> raw_syntax_entry list -> Ast.astpat syntax_command diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4 index d2df2e144..1f8422111 100644 --- a/parsing/g_constrnew.ml4 +++ b/parsing/g_constrnew.ml4 @@ -24,12 +24,7 @@ let constr_kw = "end"; "as"; "let"; "if"; "then"; "else"; "return"; "Prop"; "Set"; "Type"; ".("; "_"; ".." ] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) constr_kw - -(* For Correctness syntax; doesn't work if in psyntax (freeze pb?) *) -let _ = Lexer.add_token ("","!") +let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw let mk_cast = function (c,(_,None)) -> c @@ -39,9 +34,6 @@ let mk_lam = function ([],c) -> c | (bl,c) -> CLambdaN(constr_loc c, bl,c) -let mk_match (loc,cil,rty,br) = - CCases(loc,(None,rty),cil,br) - let loc_of_binder_let = function | LocalRawAssum ((loc,_)::_,_)::_ -> loc | LocalRawDef ((loc,_),_)::_ -> loc @@ -125,7 +117,6 @@ let lpar_id_coloneq = | _ -> raise Stream.Failure) -if not !Options.v7 then GEXTEND Gram GLOBAL: binder_constr lconstr constr operconstr sort global constr_pattern lconstr_pattern Constr.ident binder binder_let pattern; @@ -138,9 +129,6 @@ GEXTEND Gram Prim.name: [ [ "_" -> (loc, Anonymous) ] ] ; - Prim.ast: - [ [ "_" -> Coqast.Nvar(loc,id_of_string"_") ] ] - ; global: [ [ r = Prim.reference -> r @@ -259,7 +247,7 @@ GEXTEND Gram ; match_constr: [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with"; - br=branches; "end" -> mk_match (loc,ci,ty,br) ] ] + br=branches; "end" -> CCases(loc,ty,ci,br) ] ] ; case_item: [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] @@ -297,7 +285,7 @@ GEXTEND Gram | _ -> Util.user_err_loc (cases_pattern_loc p, "compound_pattern", Pp.str "Constructor expected")) - | p = pattern; "as"; id = base_ident -> + | p = pattern; "as"; id = ident -> CPatAlias (loc, p, id) | c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ] diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4 index 734a65174..313886e9a 100644 --- a/parsing/g_ltacnew.ml4 +++ b/parsing/g_ltacnew.ml4 @@ -10,12 +10,10 @@ open Pp open Util -open Ast open Topconstr open Rawterm open Tacexpr open Vernacexpr -open Ast open Pcoq open Prim open Tactic @@ -39,7 +37,6 @@ let arg_of_expr = function (* Tactics grammar rules *) -if not !Options.v7 then GEXTEND Gram GLOBAL: tactic Vernac_.command tactic_expr tactic_arg constr_may_eval; @@ -60,7 +57,7 @@ GEXTEND Gram | IDENT "info"; tc = tactic_expr -> TacInfo tc (*To do: put Abstract in Refiner*) | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = base_ident -> + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> TacAbstract (tc,Some s) ] (*End of To do*) | "2" RIGHTA @@ -135,7 +132,7 @@ GEXTEND Gram ; input_fun: [ [ "_" -> None - | l = base_ident -> Some l ] ] + | l = ident -> Some l ] ] ; let_clause: [ [ id = identref; ":="; te = tactic_expr -> diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml index 85b79d8bf..d80cc5ec3 100644 --- a/parsing/g_natsyntax.ml +++ b/parsing/g_natsyntax.ml @@ -8,105 +8,14 @@ (* $Id$ *) -(* This file to allow writing (3) for (S (S (S O))) - and still write (S y) for (S y) *) +(* This file defines the printer for natural numbers in [nat] *) +(*i*) open Pcoq open Pp open Util open Names -open Coqast -open Ast open Coqlib -open Termast -open Extend - -let ast_O = ast_of_ref glob_O -let ast_S = ast_of_ref glob_S - -(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) -let nat_of_int n dloc = - let ast_O = set_loc dloc ast_O in - let ast_S = set_loc dloc ast_S in - let rec mk_nat n = - if n <= 0 then - ast_O - else - Node(dloc,"APPLIST", [ast_S; mk_nat (n-1)]) - in - mk_nat n - -let pat_nat_of_int n dloc = - let ast_O = set_loc dloc ast_O in - let ast_S = set_loc dloc ast_S in - let rec mk_nat n = - if n <= 0 then - ast_O - else - Node(dloc,"PATTCONSTRUCT", [ast_S; mk_nat (n-1)]) - in - mk_nat n - -let nat_of_string s dloc = - nat_of_int (int_of_string s) dloc - -let pat_nat_of_string s dloc = - pat_nat_of_int (int_of_string s) dloc - -exception Non_closed_number - -let rec int_of_nat_rec astS astO p = - match p with - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,astS) -> - (int_of_nat_rec astS astO a)+1 - | a when alpha_eq(a,astO) -> 1 - (***** YES, 1, non 0 ... to print the successor of p *) - | _ -> raise Non_closed_number - -let int_of_nat p = - try - Some (int_of_nat_rec ast_S ast_O p) - with - Non_closed_number -> None - -let pr_S a = hov 0 (str "S" ++ brk (1,1) ++ a) - -let rec pr_external_S std_pr = function - | Node (l,"APPLIST", [b; a]) when alpha_eq (b,ast_S) -> - str"(" ++ pr_S (pr_external_S std_pr a) ++ str")" - | p -> std_pr p - -(* Declare the primitive printer *) - -(* Prints not p, but the SUCCESSOR of p !!!!! *) -let nat_printer std_pr p = - match (int_of_nat p) with - | Some i -> str "(" ++ str (string_of_int i) ++ str ")" - | None -> str "(" ++ pr_S (pr_external_S std_pr p) ++ str ")" - -let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer) -(* -(* Declare the primitive parser *) - -let unat = create_univ_if_new "nat" - -let number = create_constr_entry unat "number" -let pat_number = create_constr_entry unat "pat_number" - -let _ = - Gram.extend number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action nat_of_string]] - -let _ = - Gram.extend pat_number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action pat_nat_of_string]] -*) - -(*i*) open Rawterm open Libnames open Bigint @@ -191,38 +100,3 @@ let _ = (glob_nat,["Coq";"Init";"Datatypes"]) (nat_of_int,Some pat_nat_of_int) ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, None) - -(************************************************************************) -(* Old ast printing *) - -open Coqast -open Ast -open Termast - -let _ = if !Options.v7 then -let ast_O = ast_of_ref glob_O in -let ast_S = ast_of_ref glob_S in - -let rec int_of_nat = function - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,ast_S) -> (int_of_nat a) + 1 - | a when alpha_eq(a,ast_O) -> 0 - | _ -> raise Non_closed_number -in -(* Prints not p, but the SUCCESSOR of p !!!!! *) -let nat_printer_S p = - try - Some (int (int_of_nat p + 1)) - with - Non_closed_number -> None -in -let nat_printer_O _ = - Some (int 0) -in -(* Declare the primitive printers *) -let _ = - Esyntax.declare_primitive_printer "nat_printer_S" "nat_scope" nat_printer_S -in -let _ = - Esyntax.declare_primitive_printer "nat_printer_O" "nat_scope" nat_printer_O -in -() diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 2bb5b0630..bbf00a489 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -33,47 +33,22 @@ let local_make_binding loc a b = let local_append l id = l@[id] GEXTEND Gram - GLOBAL: bigint ident natural integer string preident ast - astlist qualid reference dirpath identref name base_ident var - hyp; + GLOBAL: bigint ident string preident ast + astlist qualid reference dirpath identref name base_ident var; - (* Compatibility: Prim.var is a synonym of Prim.ident *) - var: - [ [ id = ident -> id ] ] - ; - hyp: - [ [ id = ident -> id ] ] - ; metaident: [ [ s = METAIDENT -> Nmeta (loc,s) ] ] ; - preident: - [ [ s = IDENT -> s ] ] - ; base_ident: [ [ s = IDENT -> local_id_of_string s ] ] ; - name: - [ [ IDENT "_" -> (loc, Anonymous) - | id = base_ident -> (loc, Name id) ] ] - ; - identref: - [ [ id = base_ident -> (loc,id) ] ] - ; ident: [ [ id = base_ident -> id ] ] ; - natural: - [ [ i = INT -> local_make_posint i ] ] - ; bigint: [ [ i = INT -> Bigint.of_string i | "-"; i = INT -> Bigint.neg (Bigint.of_string i) ] ] ; - integer: - [ [ i = INT -> local_make_posint i - | "-"; i = INT -> local_make_negint i ] ] - ; field: [ [ s = FIELD -> local_id_of_string s ] ] ; diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4 index 667b5654e..0a3a3c92b 100644 --- a/parsing/g_primnew.ml4 +++ b/parsing/g_primnew.ml4 @@ -8,71 +8,62 @@ (*i $Id$ i*) -open Coqast open Pcoq open Names open Libnames open Topconstr -let _ = - if not !Options.v7 then - Pcoq.reset_all_grammars() -let _ = - if not !Options.v7 then - let f = Gram.Unsafe.clear_entry in - f Prim.bigint; - f Prim.qualid; - f Prim.ast; - f Prim.reference - -let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "<>"; "<<"; ">>"; "'"] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) prim_kw +let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] +let _ = List.iter (fun s -> Lexer.add_token("",s)) prim_kw open Prim - open Nametab -let local_id_of_string = id_of_string -let local_make_dirpath = make_dirpath -let local_make_qualid l id' = make_qualid (local_make_dirpath l) id' -let local_make_short_qualid id = make_short_qualid id -let local_make_posint = int_of_string -let local_make_negint n = - int_of_string n -let local_make_path l a = encode_kn (local_make_dirpath l) a -let local_make_binding loc a b = - match a with - | Nvar (_,id) -> Slam(loc,Some id,b) - | Nmeta (_,s) -> Smetalam(loc,s,b) - | _ -> failwith "Slam expects a var or a metavar" -let local_append l id = l@[id] -if not !Options.v7 then +let local_make_qualid l id = make_qualid (make_dirpath l) id + GEXTEND Gram - GLOBAL: bigint fullyqualid qualid reference ne_string; + GLOBAL: + bigint natural integer identref name ident var preident + fullyqualid qualid reference + ne_string; + preident: + [ [ s = IDENT -> s ] ] + ; + ident: + [ [ s = IDENT -> id_of_string s ] ] + ; + var: (* as identref, but interpret as a term identifier in ltac *) + [ [ id = ident -> (loc,id) ] ] + ; + identref: + [ [ id = ident -> (loc,id) ] ] + ; field: - [ [ s = FIELD -> local_id_of_string s ] ] + [ [ s = FIELD -> id_of_string s ] ] ; fields: - [ [ id = field; (l,id') = fields -> (local_append l id,id') + [ [ id = field; (l,id') = fields -> (l@[id],id') | id = field -> ([],id) ] ] ; fullyqualid: - [ [ id = base_ident; (l,id')=fields -> loc,id::List.rev (id'::l) - | id = base_ident -> loc,[id] + [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l) + | id = ident -> loc,[id] ] ] ; basequalid: - [ [ id = base_ident; (l,id')=fields -> - local_make_qualid (local_append l id) id' - | id = base_ident -> local_make_short_qualid id + [ [ id = ident; (l,id')=fields -> local_make_qualid (l@[id]) id' + | id = ident -> make_short_qualid id ] ] ; + name: + [ [ IDENT "_" -> (loc, Anonymous) + | id = ident -> (loc, Name id) ] ] + ; reference: - [ [ id = base_ident; (l,id') = fields -> - Qualid (loc, local_make_qualid (local_append l id) id') - | id = base_ident -> Ident (loc,id) + [ [ id = ident; (l,id') = fields -> + Qualid (loc, local_make_qualid (l@[id]) id') + | id = ident -> Ident (loc,id) ] ] ; qualid: @@ -83,6 +74,13 @@ GEXTEND Gram if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s ] ] ; + integer: + [ [ i = INT -> int_of_string i + | "-"; i = INT -> - int_of_string i ] ] + ; + natural: + [ [ i = INT -> int_of_string i ] ] + ; bigint: (* Negative numbers are dealt with specially *) [ [ i = INT -> (Bigint.of_string i) ] ] ; diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4 index 4f25354b6..5cf5152a3 100644 --- a/parsing/g_proofsnew.ml4 +++ b/parsing/g_proofsnew.ml4 @@ -21,7 +21,6 @@ open Constr let thm_token = G_vernacnew.thm_token (* Proof commands *) -if not !Options.v7 then GEXTEND Gram GLOBAL: command; @@ -36,7 +35,7 @@ GEXTEND Gram ; command: [ [ IDENT "Goal"; c = Constr.lconstr -> VernacGoal c - | IDENT "Proof" -> VernacNop + | IDENT "Proof" -> VernacProof (Tacexpr.TacId "") | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll @@ -113,7 +112,7 @@ GEXTEND Gram tac = tactic -> HintsExtern (None,n,c,tac) | IDENT"Destruct"; - id = base_ident; ":="; + id = ident; ":="; pri = natural; dloc = destruct_location; hyptyp = Constr.constr_pattern; diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml index 3cd6eba3a..fb5be2896 100644 --- a/parsing/g_rsyntax.ml +++ b/parsing/g_rsyntax.ml @@ -6,161 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Coqast -open Ast open Pp open Util open Names open Pcoq -open Extend open Topconstr open Libnames -(**********************************************************************) -(* Parsing with Grammar *) -(**********************************************************************) - -let get_r_sign loc = - let mkid id = - mkRefC (Qualid (loc,Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "R0"), - mkid (id_of_string "R1"), - mkid (id_of_string "Rplus"), - mkid (id_of_string "Rmult"), - mkid (id_of_string "NRplus"), - mkid (id_of_string "NRmult"))) - -let get_r_sign_ast loc = - let mkid id = - Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "R0"), - mkid (id_of_string "R1"), - mkid (id_of_string "Rplus"), - mkid (id_of_string "Rmult"), - mkid (id_of_string "NRplus"), - mkid (id_of_string "NRmult"))) - -(* We have the following interpretation: - [| 0 |] = 0 - [| 1 |] = 1 - [| 2 |] = 1 + 1 - [| 3 |] = 1 + (1 + 1) - [| 2n |] = 2 * [| n |] for n >= 2 - [| 2n+1 |] = 1 + 2 * [| n |] for n >= 2 - [| -n |] = - [| n |] for n >= 0 -*) - -open Bigint - -let rec int_decomp m = - if equal m zero then [0] else - if equal m one then [1] else - let (m',b) = euclid m two in (if equal b zero then 0 else 1) :: int_decomp m' - -let _ = if !Options.v7 then -let r_of_int n dloc = - let (a0,a1,plus,mult,_,_) = get_r_sign dloc in - let list_ch = int_decomp n in - let a2 = mkAppC (plus, [a1; a1]) in - let rec mk_r l = - match l with - | [] -> failwith "Error r_of_int" - | [a] -> if a=1 then a1 else a0 - | [a;b] -> if a==1 then mkAppC (plus, [a1; a2]) else a2 - | a::l' -> if a=1 then mkAppC (plus, [a1; mkAppC (mult, [a2; mk_r l'])]) else mkAppC (mult, [a2; mk_r l']) - in mk_r list_ch -in -let r_of_string s dloc = - r_of_int (of_string s) dloc -in -let rsyntax_create name = - let e = - Pcoq.create_constr_entry (Pcoq.get_univ "rnatural") name in - Pcoq.Gram.Unsafe.clear_entry e; - e -in -let rnumber = rsyntax_create "rnumber" -in -let _ = - Gram.extend rnumber None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action r_of_string]] -in () - -(**********************************************************************) -(* Old ast printing *) -(**********************************************************************) - exception Non_closed_number -let _ = if !Options.v7 then -let int_of_r p = - let (a0,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - let rec int_of_r_rec p = - match p with - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) & alpha_eq(c,a1) -> 2 - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) -> - (match c with - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,mult) -> 1 + int_of_r_rec c - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> 3 - | _ -> raise Non_closed_number) - | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,mult) -> - (match a with - | Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> - (match c with - | g when alpha_eq(g,a1) -> raise Non_closed_number - | g when alpha_eq(g,a0) -> raise Non_closed_number - | _ -> 2 * int_of_r_rec c) - | _ -> raise Non_closed_number) - | a when alpha_eq(a,a0) -> 0 - | a when alpha_eq(a,a1) -> 1 - | _ -> raise Non_closed_number in - try - Some (int_of_r_rec p) - with - Non_closed_number -> None -in -let replace_plus p = - let (_,_,_,_,astnrplus,_) = get_r_sign_ast dummy_loc in - ope ("REXPR",[ope("APPLIST",[astnrplus;p])]) -in -let replace_mult p = - let (_,_,_,_,_,astnrmult) = get_r_sign_ast dummy_loc in - ope ("REXPR",[ope("APPLIST",[astnrmult;p])]) -in -let rec r_printer_odd std_pr p = - let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[plus;a1;p]))) with - | Some i -> str (string_of_int i) - | None -> std_pr (replace_plus p) -in -let rec r_printer_odd_outside std_pr p = - let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[plus;a1;p]))) with - | Some i -> str"``" ++ str (string_of_int i) ++ str"``" - | None -> std_pr (replace_plus p) -in -let rec r_printer_even std_pr p = - let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with - | Some i -> str (string_of_int i) - | None -> std_pr (replace_mult p) -in -let rec r_printer_even_outside std_pr p = - let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in - match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with - | Some i -> str"``" ++ str (string_of_int i) ++ str"``" - | None -> std_pr (replace_mult p) -in -let _ = Esyntax.Ppprim.add ("r_printer_odd", r_printer_odd) in -let _ = Esyntax.Ppprim.add ("r_printer_odd_outside", r_printer_odd_outside) in -let _ = Esyntax.Ppprim.add ("r_printer_even", r_printer_even) in -let _ = Esyntax.Ppprim.add ("r_printer_even_outside", r_printer_even_outside) -in () - (**********************************************************************) (* Parsing R via scopes *) (**********************************************************************) @@ -182,29 +36,6 @@ let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") -(* V7 *) -let r_of_posint dloc n = - let ref_R0 = RRef (dloc, glob_R0) in - let ref_R1 = RRef (dloc, glob_R1) in - let ref_Rplus = RRef (dloc, glob_Rplus) in - let ref_Rmult = RRef (dloc, glob_Rmult) in - let a2 = RApp(dloc, ref_Rplus, [ref_R1; ref_R1]) in - let list_ch = int_decomp n in - let rec mk_r l = - match l with - | [] -> failwith "Error r_of_posint" - | [a] -> if a=1 then ref_R1 else ref_R0 - | a::[b] -> if a==1 then RApp (dloc, ref_Rplus, [ref_R1; a2]) else a2 - | a::l' -> if a=1 then RApp (dloc, ref_Rplus, [ref_R1; RApp (dloc, ref_Rmult, [a2; mk_r l'])]) else RApp (dloc, ref_Rmult, [a2; mk_r l']) - in mk_r list_ch - -let r_of_int2 dloc z = - if is_strictly_neg z then - RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) - else - r_of_posint dloc z - -(* V8 *) let two = mult_2 one let three = add_1 two let four = mult_2 two @@ -280,54 +111,8 @@ let uninterp_r p = let _ = Notation.declare_numeral_interpreter "R_scope" (glob_R,["Coq";"Reals";"Rdefinitions"]) - ((if !Options.v7 then r_of_int2 else r_of_int),None) + (r_of_int,None) ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0); RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);RRef(dummy_loc,glob_R1)], uninterp_r, None) - -(************************************************************************) -(* Old ast printers via scope *) - -let _ = if !Options.v7 then -let bignat_of_pos p = - let (_,one,plus,_,_,_) = get_r_sign_ast dummy_loc in - let rec transl = function - | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one) - -> add_1(transl a) - | a when alpha_eq(a,one) -> Bigint.one - | _ -> raise Non_closed_number - in transl p -in -let bignat_option_of_pos p = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None -in -let r_printer_Rplus1 p = - match bignat_option_of_pos p with - | Some n -> Some (str (Bigint.to_string (add_1 n))) - | None -> None -in -let r_printer_Ropp p = - match bignat_option_of_pos p with - | Some n -> Some (str "-" ++ str (Bigint.to_string n)) - | None -> None -in -let r_printer_R1 _ = - Some (int 1) -in -let r_printer_R0 _ = - Some (int 0) -in -(* Declare pretty-printers for integers *) -let _ = - Esyntax.declare_primitive_printer "r_printer_Ropp" "R_scope" (r_printer_Ropp) -in let _ = - Esyntax.declare_primitive_printer "r_printer_Rplus1" "R_scope" (r_printer_Rplus1) -in let _ = - Esyntax.declare_primitive_printer "r_printer_R1" "R_scope" (r_printer_R1) -in let _ = - Esyntax.declare_primitive_printer "r_printer_R0" "R_scope" r_printer_R0 -in () diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4 index c7fee72db..180754668 100644 --- a/parsing/g_tacticnew.ml4 +++ b/parsing/g_tacticnew.ml4 @@ -9,7 +9,6 @@ (* $Id$ *) open Pp -open Ast open Pcoq open Util open Tacexpr @@ -18,11 +17,8 @@ open Genarg let compute = Cbv all_flags -let tactic_kw = - [ "->"; "<-" ] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token("",s)) tactic_kw +let tactic_kw = [ "->"; "<-" ] +let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) @@ -98,15 +94,8 @@ let induction_arg_of_constr c = try ElimOnIdent (Topconstr.constr_loc c,snd(coerce_to_id c)) with _ -> ElimOnConstr c -let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] - -let error_oldelim _ = error "OldElim no longer supported" - -let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2) - (* Auxiliary grammar rules *) -if not !Options.v7 then GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr casted_open_constr @@ -141,7 +130,7 @@ GEXTEND Gram ] ] ; quantified_hypothesis: - [ [ id = base_ident -> NamedHyp id + [ [ id = ident -> NamedHyp id | n = natural -> AnonHyp n ] ] ; conversion: @@ -167,11 +156,11 @@ GEXTEND Gram [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] | "_" -> IntroWildcard - | id = base_ident -> IntroIdentifier id + | id = ident -> IntroIdentifier id ] ] ; simple_binding: - [ [ "("; id = base_ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c) | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ] ; bindings: @@ -221,11 +210,12 @@ GEXTEND Gram | s = IDENT -> ExtraRedExpr s ] ] ; hypident: - [ [ id = id_or_meta -> id,(InHyp,ref None) + [ [ id = id_or_meta -> + id,InHyp | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - id,(InHypTypeOnly,ref None) + id,InHypTypeOnly | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - id,(InHypValueOnly,ref None) + id,InHypValueOnly ] ] ; hypident_occ: @@ -251,7 +241,7 @@ GEXTEND Gram | -> [] ] ] ; fixdecl: - [ [ "("; id = base_ident; bl=LIST0 Constr.binder; ann=fixannot; + [ [ "("; id = ident; bl=LIST0 Constr.binder; ann=fixannot; ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ] ; fixannot: @@ -275,11 +265,11 @@ GEXTEND Gram IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> TacIntrosUntil id | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl - | IDENT "intro"; id = base_ident; IDENT "after"; id2 = identref -> + | IDENT "intro"; id = ident; IDENT "after"; id2 = identref -> TacIntroMove (Some id, Some id2) | IDENT "intro"; IDENT "after"; id2 = identref -> TacIntroMove (None, Some id2) - | IDENT "intro"; id = base_ident -> TacIntroMove (Some id, None) + | IDENT "intro"; id = ident -> TacIntroMove (Some id, None) | IDENT "intro" -> TacIntroMove (None, None) | IDENT "assumption" -> TacAssumption @@ -293,12 +283,12 @@ GEXTEND Gram | IDENT "case"; cl = constr_with_bindings -> TacCase cl | IDENT "casetype"; c = constr -> TacCaseType c | "fix"; n = natural -> TacFix (None,n) - | "fix"; id = base_ident; n = natural -> TacFix (Some id,n) - | "fix"; id = base_ident; n = natural; "with"; fd = LIST1 fixdecl -> + | "fix"; id = ident; n = natural -> TacFix (Some id,n) + | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacMutualFix (id,n,List.map mk_fix_tac fd) | "cofix" -> TacCofix None - | "cofix"; id = base_ident -> TacCofix (Some id) - | "cofix"; id = base_ident; "with"; fd = LIST1 fixdecl -> + | "cofix"; id = ident -> TacCofix (Some id) + | "cofix"; id = ident; "with"; fd = LIST1 fixdecl -> TacMutualCofix (id,List.map mk_cofix_tac fd) | IDENT "cut"; c = constr -> TacCut c @@ -330,15 +320,15 @@ GEXTEND Gram (* Derived basic tactics *) | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis -> - TacSimpleInduction (h,ref []) + TacSimpleInduction h | IDENT "induction"; c = induction_arg; ids = with_names; - el = OPT eliminator -> TacNewInduction (c,el,(ids,ref [])) + el = OPT eliminator -> TacNewInduction (c,el,ids) | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2) | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis -> TacSimpleDestruct h | IDENT "destruct"; c = induction_arg; ids = with_names; - el = OPT eliminator -> TacNewDestruct (c,el,(ids,ref [])) + el = OPT eliminator -> TacNewDestruct (c,el,ids) | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4 index 21aa0c732..4a0d498d3 100644 --- a/parsing/g_vernacnew.ml4 +++ b/parsing/g_vernacnew.ml4 @@ -11,7 +11,6 @@ open Pp open Util open Names -open Coqast open Topconstr open Vernacexpr open Pcoq @@ -27,11 +26,8 @@ open Constr open Vernac_ open Module - let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] -let _ = - if not !Options.v7 then - List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw +let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) @@ -41,7 +37,6 @@ let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" let thm_token = Gram.Entry.create "vernac:thm_token" let def_body = Gram.Entry.create "vernac:def_body" -if not !Options.v7 then GEXTEND Gram GLOBAL: vernac gallina_ext; vernac: @@ -87,7 +82,6 @@ let no_coercion loc (c,x) = x (* Gallina declarations *) -if not !Options.v7 then GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body; @@ -210,7 +204,7 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = base_ident; bl = LIST1 binder_let; + [ [ id = ident; bl = LIST1 binder_let; annot = OPT rec_annotation; type_ = type_cstr; ":="; def = lconstr; ntn = decl_notation -> let names = List.map snd (names_of_local_assums bl) in @@ -230,7 +224,7 @@ GEXTEND Gram ((id, ni, bl, type_, def),ntn) ] ] ; corec_definition: - [ [ id = base_ident; bl = LIST0 binder_let; c = type_cstr; ":="; + [ [ id = ident; bl = LIST0 binder_let; c = type_cstr; ":="; def = lconstr -> (id,bl,c ,def) ] ] ; @@ -301,7 +295,6 @@ END (* Modules and Sections *) -if not !Options.v7 then GEXTEND Gram GLOBAL: gallina_ext module_expr module_type; @@ -387,7 +380,6 @@ GEXTEND Gram END (* Extensions: implicits, coercions, etc. *) -if not !Options.v7 then GEXTEND Gram GLOBAL: gallina_ext; @@ -400,17 +392,17 @@ GEXTEND Gram | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical qid | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in + let s = coerce_global_to_id qid in VernacDefinition ((Global,CanonicalStructure),(dummy_loc,s),d, (fun _ -> Recordops.declare_canonical_structure)) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in + let s = coerce_global_to_id qid in VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = Ast.coerce_global_to_id qid in + let s = coerce_global_to_id qid in VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> @@ -436,7 +428,6 @@ GEXTEND Gram ; END -if not !Options.v7 then GEXTEND Gram GLOBAL: command check_command class_rawexpr; @@ -632,7 +623,6 @@ GEXTEND Gram ; END; -if not !Options.v7 then GEXTEND Gram command: [ [ @@ -661,7 +651,6 @@ GEXTEND Gram (* Grammar extensions *) -if not !Options.v7 then GEXTEND Gram GLOBAL: syntax; @@ -737,13 +726,8 @@ GEXTEND Gram [ [ "_" -> None | sc = IDENT -> Some sc ] ] ; production_item: - [[ s = ne_string -> VTerm s - | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> - VNonTerm (loc,NtShort nt,po) ]] + [ [ s = ne_string -> VTerm s + | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> + VNonTerm (loc,nt,po) ] ] ; END - -(* Reinstall tactic and vernac extensions *) -let _ = - if not !Options.v7 then - Egrammar.reset_extend_grammars_v8() diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 02b35a1d8..7b7e471c6 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -135,10 +135,13 @@ let rec interp_xml_constr = function | XmlTag (loc,"CONST",al,[]) -> RRef (loc, ConstRef (get_xml_constant al)) | XmlTag (loc,"MUTCASE",al,x::y::yl) -> (* BUGGE *) + failwith "XML MUTCASE TO DO"; +(* ROrderedCase (loc,RegularStyle,Some (interp_xml_patternsType x), interp_xml_inductiveTerm y, Array.of_list (List.map interp_xml_pattern yl), ref None) +*) | XmlTag (loc,"MUTIND",al,[]) -> RRef (loc, IndRef (get_xml_inductive al)) | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml index f78373c28..9f4bba335 100644 --- a/parsing/g_zsyntax.ml +++ b/parsing/g_zsyntax.ml @@ -8,144 +8,16 @@ (* $Id$ *) -open Coqast open Pcoq open Pp open Util open Names -open Ast -open Extend open Topconstr open Libnames open Bigint -(**********************************************************************) -(* V7 parsing via Grammar *) - -let get_z_sign loc = - let mkid id = - mkRefC (Qualid (loc,Libnames.make_short_qualid id)) - in - ((mkid (id_of_string "xI"), - mkid (id_of_string "xO"), - mkid (id_of_string "xH")), - (mkid (id_of_string "ZERO"), - mkid (id_of_string "POS"), - mkid (id_of_string "NEG"))) - -let pos_of_bignat xI xO xH x = - let rec pos_of x = - match div2_with_rest x with - | (q, true) when q <> zero -> mkAppC (xI, [pos_of q]) - | (q, false) -> mkAppC (xO, [pos_of q]) - | (_, true) -> xH - in - pos_of x - -let z_of_string pos_or_neg s dloc = - let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in - let v = Bigint.of_string s in - if v <> zero then - if pos_or_neg then - mkAppC (aPOS, [pos_of_bignat xI xO xH v]) - else - mkAppC (aNEG, [pos_of_bignat xI xO xH v]) - else - aZERO - -(* Declare the primitive parser with Grammar and without the scope mechanism *) -let zsyntax_create name = - let e = - Pcoq.create_constr_entry (Pcoq.get_univ "znatural") name in - Pcoq.Gram.Unsafe.clear_entry e; - e - -let number = zsyntax_create "number" - -let negnumber = zsyntax_create "negnumber" - -let _ = - Gram.extend number None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action (z_of_string true)]] - -let _ = - Gram.extend negnumber None - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action (z_of_string false)]] - -(**********************************************************************) -(* Old v7 ast printing *) - -open Coqlib - exception Non_closed_number -let get_z_sign_ast loc = - let ast_of_id id = - Termast.ast_of_ref - (global_of_constr - (gen_constant_in_modules "Z-printer" zarith_base_modules id)) - in - ((ast_of_id "xI", - ast_of_id "xO", - ast_of_id "xH"), - (ast_of_id "ZERO", - ast_of_id "POS", - ast_of_id "NEG")) - -let _ = if !Options.v7 then -let rec bignat_of_pos c1 c2 c3 p = - match p with - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) -> - mult_2 (bignat_of_pos c1 c2 c3 a) - | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c2) -> - add_1 (mult_2 (bignat_of_pos c1 c2 c3 a)) - | a when alpha_eq(a,c3) -> Bigint.one - | _ -> raise Non_closed_number -in -let bignat_option_of_pos xI xO xH p = - try - Some (bignat_of_pos xO xI xH p) - with Non_closed_number -> - None -in -let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) in -let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) in - -let inside_printer posneg std_pr p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - match (bignat_option_of_pos xI xO xH p) with - | Some n -> - if posneg then - (str (Bigint.to_string n)) - else - (str "(-" ++ str (Bigint.to_string n) ++ str ")") - | None -> - let pr = if posneg then pr_pos else pr_neg in - str "(" ++ pr (std_pr (ope("ZEXPR",[p]))) ++ str ")" -in -let outside_printer posneg std_pr p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - match (bignat_option_of_pos xI xO xH p) with - | Some n -> - if posneg then - (str "`" ++ str (Bigint.to_string n) ++ str "`") - else - (str "`-" ++ str (Bigint.to_string n) ++ str "`") - | None -> - let pr = if posneg then pr_pos else pr_neg in - str "(" ++ pr (std_pr p) ++ str ")" -in -(* For printing with Syntax and without the scope mechanism *) -let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) in -let _ = Esyntax.Ppprim.add ("negative_printer", (outside_printer false)) in -let _ = Esyntax.Ppprim.add ("positive_printer_inside", (inside_printer true))in -let _ = Esyntax.Ppprim.add ("negative_printer_inside", (inside_printer false)) -in () - (**********************************************************************) (* Parsing positive via scopes *) (**********************************************************************) @@ -235,8 +107,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (**********************************************************************) let binnat_module = ["Coq";"NArith";"BinNat"] -let n_path = make_path (make_dir binnat_module) - (id_of_string (if !Options.v7 then "entier" else "N")) +let n_path = make_path (make_dir binnat_module) (id_of_string "N") let glob_n = IndRef (n_path,0) let path_of_N0 = ((n_path,0),1) let path_of_Npos = ((n_path,0),2) @@ -346,48 +217,3 @@ let _ = Notation.declare_numeral_interpreter "Z_scope" RRef (dummy_loc, glob_NEG)], uninterp_z, None) - -(************************************************************************) -(* Old V7 ast Printers *) - -open Esyntax - -let _ = if !Options.v7 then -let bignat_of_pos p = - let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in - let c1 = xO in - let c2 = xI in - let c3 = xH in - let rec transl = function - | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a) - | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a)) - | a when alpha_eq(a,c3) -> Bigint.one - | _ -> raise Non_closed_number - in transl p -in -let bignat_option_of_pos p = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None -in -let z_printer posneg p = - match bignat_option_of_pos p with - | Some n -> - if posneg then - Some (str (Bigint.to_string n)) - else - Some (str "-" ++ str (Bigint.to_string n)) - | None -> None -in -let z_printer_ZERO _ = - Some (int 0) -in -(* Declare pretty-printers for integers *) -let _ = - declare_primitive_printer "z_printer_POS" "Z_scope" (z_printer true) in -let _ = - declare_primitive_printer "z_printer_NEG" "Z_scope" (z_printer false) in -let _ = - declare_primitive_printer "z_printer_ZERO" "Z_scope" z_printer_ZERO in -() diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 1534123f8..1708fa5eb 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -93,12 +93,9 @@ let check_ident str = | (('\134'..'\143' | '\152'..'\155' | '\164'..'\165' | '\168'..'\171'),_) -> bad_token str - | _ -> (* default to iso 8859-1 "â" *) - if !Options.v7 then loop_id [< 'c2; 'c3; s >] - else bad_token str) + | _ -> + bad_token str) (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255'); s >] -> - if !Options.v7 then loop_id s else bad_token str | [< _ = Stream.empty >] -> () | [< >] -> bad_token str in @@ -170,26 +167,13 @@ let get_buff len = String.sub !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) -let rec ident_tail len strm = - if !Options.v7 then - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' | '@' as c); s >] -> - ident_tail (store len c) s - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> - ident_tail (store (store len c1) c2) s - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); s >] -> - ident_tail (store len c) s - | [< >] -> len - else - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> - ident_tail (store len c) s - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> - ident_tail (store (store len c1) c2) s - | [< >] -> len +let rec ident_tail len = parser + | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> + ident_tail (store len c) s + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] -> + ident_tail (store (store len c1) c2) s + | [< >] -> len let rec number len = parser @@ -198,21 +182,11 @@ let rec number len = parser let escape len c = store len c -let rec string_v8 bp len = parser +let rec string bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> - if esc then string_v8 bp (store len '"') s else len - | [< 'c; s >] -> string_v8 bp (store len c) s - | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string - -let rec string_v7 bp len = parser - | [< ''"' >] -> len - | [< ''\\'; c = (parser [< ' ('"' | '\\' as c) >] -> c | [< >] -> '\\'); s >] - -> string_v7 bp (escape len c) s + if esc then string bp (store len '"') s else len + | [< 'c; s >] -> string bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string - | [< 'c; s >] -> string_v7 bp (store len c) s - -let string bp len s = - if !Options.v7 then string_v7 bp len s else string_v8 bp len s (* Hook for exporting comment into xml theory files *) let xml_output_comment = ref (fun _ -> ()) @@ -359,45 +333,22 @@ let parse_226_tail tk = parser (* Parse what follows a dot *) -let parse_after_dot bp c strm = - if !Options.v7 then - match strm with parser - | [< ' ('_' | 'a'..'z' | 'A'..'Z' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); - len = ident_tail (store (store 0 c1) c2) >] -> - ("FIELD", get_buff len) - (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) - | [< ''\226'; t = parse_226_tail - (progress_special '.' (Some !token_tree)) >] ep -> - (match t with - | TokSymbol (Some t) -> ("", t) - | TokSymbol None -> err (bp, ep) Undefined_token - | TokIdent t -> ("FIELD", t)) - (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - | [< (t,_) = process_chars bp c >] -> t - else - match strm with parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); - len = ident_tail (store 0 c) >] -> - ("FIELD", get_buff len) - (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) - | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); - len = ident_tail (store (store 0 c1) c2) >] -> - ("FIELD", get_buff len) - (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) - | [< ''\226'; t = parse_226_tail - (progress_special '.' (Some !token_tree)) >] ep -> - (match t with - | TokSymbol (Some t) -> ("", t) - | TokSymbol None -> err (bp, ep) Undefined_token - | TokIdent t -> ("FIELD", t)) - | [< (t,_) = process_chars bp c >] -> t +let parse_after_dot bp c = parser + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); + len = ident_tail (store 0 c) >] -> + ("FIELD", get_buff len) + (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *) + | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); + len = ident_tail (store (store 0 c1) c2) >] -> + ("FIELD", get_buff len) + (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *) + | [< ''\226'; t = parse_226_tail + (progress_special '.' (Some !token_tree)) >] ep -> + (match t with + | TokSymbol (Some t) -> ("", t) + | TokSymbol None -> err (bp, ep) Undefined_token + | TokIdent t -> ("FIELD", t)) + | [< (t,_) = process_chars bp c >] -> t (* Parse a token in a char stream *) @@ -410,7 +361,6 @@ let rec next_token = parser bp (("METAIDENT", get_buff len), (bp,ep)) | [< ''.' as c; t = parse_after_dot bp c >] ep -> comment_stop bp; - if !Options.v7 & t=("",".") then between_com := true; (t, (bp,ep)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ep -> @@ -433,20 +383,10 @@ let rec next_token = parser bp (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)) (* iso 8859-1 accentuated letters *) - | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; s >] -> - if !Options.v7 then - begin - match s with parser - [< len = ident_tail (store 0 c) >] ep -> - let id = get_buff len in - comment_stop bp; - (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep) - end - else - begin - match s with parser - [< t = process_chars bp c >] -> comment_stop bp; t - end + | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; + t = process_chars bp c >] -> + comment_stop bp; + t | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> comment_stop bp; (("INT", get_buff len), (bp, ep)) @@ -534,3 +474,41 @@ let tparse (p_con, p_prm) = else (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm) i*) + +(* Terminal symbols interpretation *) + +let is_ident_not_keyword s = + match s.[0] with + | 'a'..'z' | 'A'..'Z' | '_' -> not (is_keyword s) + | _ -> false + +let is_number s = + match s.[0] with + | '0'..'9' -> true + | _ -> false + +let strip s = + let len = + let rec loop i len = + if i = String.length s then len + else if s.[i] == ' ' then loop (i + 1) len + else loop (i + 1) (len + 1) + in + loop 0 0 + in + if len == String.length s then s + else + let s' = String.create len in + let rec loop i i' = + if i == String.length s then s' + else if s.[i] == ' ' then loop (i + 1) i' + else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end + in + loop 0 0 + +let terminal s = + let s = strip s in + if s = "" then failwith "empty token"; + if is_ident_not_keyword s then ("IDENT", s) + else if is_number s then ("INT", s) + else ("", s) diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 2730cfea5..84f25ca5e 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -48,3 +48,5 @@ val com_state: unit -> com_state val restore_com_state: com_state -> unit val set_xml_output_comment : (string -> unit) -> unit + +val terminal : string -> string * string diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 90e93b832..0c864ba09 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -11,14 +11,13 @@ open Pp open Util open Names +open Extend open Libnames open Rawterm open Topconstr -open Ast open Genarg open Tacexpr open Ppextend -open Extend (* The lexer of Coq *) @@ -65,8 +64,9 @@ struct let weaken_entry e = Obj.magic e end +type entry_type = argument_type type grammar_object = Gramobj.grammar_object -type typed_entry = entry_type * grammar_object G.Entry.e +type typed_entry = argument_type * grammar_object G.Entry.e let in_typed_entry t e = (t,Gramobj.weaken_entry e) let type_of_typed_entry (t,e) = t let object_of_typed_entry (t,e) = e @@ -311,10 +311,7 @@ module Prim = let reference = make_gen_entry uprim rawwit_ref "reference" (* parsed like ident but interpreted as a term *) - let hyp = gec_gen rawwit_ident "hyp" - - (* synonym of hyp/ident (before semantics split) for v7 compatibility *) - let var = gec_gen rawwit_ident "var" + let var = gec_gen rawwit_var "var" let name = Gram.Entry.create "Prim.name" let identref = Gram.Entry.create "Prim.identref" @@ -328,12 +325,6 @@ module Prim = let ne_string = Gram.Entry.create "Prim.ne_string" - (* For old ast printer *) - let astpat = Gram.Entry.create "Prim.astpat" - let ast = Gram.Entry.create "Prim.ast" - let astlist = Gram.Entry.create "Prim.astlist" - let ast_eoi = eoi_entry ast - let astact = Gram.Entry.create "Prim.astact" end @@ -380,8 +371,7 @@ module Tactic = make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings" let bindings = make_gen_entry utactic rawwit_bindings "bindings" -(*v7*) let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg" -(*v8*) let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval" + let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval" let quantified_hypothesis = make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis" let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var" @@ -391,13 +381,7 @@ module Tactic = (* Main entries for ltac *) let tactic_arg = Gram.Entry.create "tactic:tactic_arg" - (* For v8: *) let tactic_expr = Gram.Entry.create "tactic:tactic_expr" - (* For v7: *) - let tactic_expr2 = Gram.Entry.create "tactic:tactic_expr2" - let tactic_expr3 = Gram.Entry.create "tactic:tactic_expr3" - let tactic_expr4 = Gram.Entry.create "tactic:tactic_expr4" - let tactic_expr5 = Gram.Entry.create "tactic:tactic_expr5" let tactic_main_level = 5 let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic" @@ -422,32 +406,6 @@ module Vernac_ = let vernac_eoi = eoi_entry vernac end - -(* Prim is not re-initialized *) -let reset_all_grammars () = - let f = Gram.Unsafe.clear_entry in - List.iter f - [Constr.constr;Constr.operconstr;Constr.lconstr;Constr.annot; - Constr.constr_pattern;Constr.lconstr_pattern]; - f Constr.ident; f Constr.global; f Constr.sort; f Constr.pattern; - f Module.module_expr; f Module.module_type; - f Tactic.simple_tactic; - f Tactic.open_constr; - f Tactic.constr_with_bindings; - f Tactic.bindings; - f Tactic.constrarg; - f Tactic.quantified_hypothesis; - f Tactic.int_or_var; - f Tactic.red_expr; - f Tactic.tactic_arg; - f Tactic.tactic; - f Vernac_.gallina; - f Vernac_.gallina_ext; - f Vernac_.command; - f Vernac_.syntax; - f Vernac_.vernac; - Lexer.init() - let main_entry = Gram.Entry.create "vernac" GEXTEND Gram @@ -456,88 +414,6 @@ GEXTEND Gram ; END -(* Quotations *) - -open Prim -open Constr -open Tactic -open Vernac_ - -(* current file and toplevel/vernac.ml *) -let globalizer = ref (fun x -> failwith "No globalizer") -let set_globalizer f = globalizer := f - -let define_ast_quotation default s (e:Coqast.t G.Entry.e) = - (if default then - GEXTEND Gram - ast: [ [ "<<"; c = e; ">>" -> c ] ]; - (* Uncomment this to keep compatibility with old grammar syntax - constr: [ [ "<<"; c = e; ">>" -> c ] ]; - vernac: [ [ "<<"; c = e; ">>" -> c ] ]; - tactic: [ [ "<<"; c = e; ">>" -> c ] ]; - *) - END); - (GEXTEND Gram - GLOBAL: ast constr command tactic; - ast: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - (* Uncomment this to keep compatibility with old grammar syntax - constr: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - command: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - tactic: - [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ]; - *) - END) - -(* -let _ = define_ast_quotation false "ast" ast in () -*) - -let dynconstr = Gram.Entry.create "Constr.dynconstr" -let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern" - -GEXTEND Gram - dynconstr: - [ [ a = Constr.constr -> ConstrNode a - (* For compatibility *) - | "<<"; a = Constr.lconstr; ">>" -> ConstrNode a ] ] - ; - dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ]; -END - -(**********************************************************************) -(* The following is to dynamically set the parser in Grammar actions *) -(* and Syntax pattern, according to the universe of the rule defined *) - -type parser_type = - | ConstrParser - | CasesPatternParser - -let default_action_parser_ref = ref dynconstr - -let get_default_action_parser () = !default_action_parser_ref - -let entry_type_of_parser = function - | ConstrParser -> Some ConstrArgType - | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO" - -let parser_type_from_name = function - | "constr" -> ConstrParser - | "cases_pattern" -> CasesPatternParser - | "tactic" -> assert false - | "vernac" -> error "No longer supported" - | s -> ConstrParser - -let set_default_action_parser = function - | ConstrParser -> default_action_parser_ref := dynconstr - | CasesPatternParser -> default_action_parser_ref := dyncasespattern - -let default_action_parser = - Gram.Entry.of_parser "default_action_parser" - (fun strm -> Gram.Entry.parse_token (get_default_action_parser ()) strm) - (**********************************************************************) (* This determines (depending on the associativity of the current level and on the expected associativity) if a reference to constr_n is @@ -547,24 +423,9 @@ let default_action_parser = translated in camlp4 into "constr" without level) or to another level (to be translated into "constr LEVEL n") *) -let assoc_level = function - | Some Gramext.LeftA when !Options.v7 -> "L" - | _ -> "" - -let constr_level = function - | n,assoc -> (string_of_int n)^(assoc_level assoc) - -let constr_level2 = function - | n,assoc -> (string_of_int n)^(assoc_level (Some assoc)) - -let default_levels_v7 = - [10,Gramext.RightA; - 9,Gramext.RightA; - 8,Gramext.RightA; - 1,Gramext.RightA; - 0,Gramext.RightA] +let constr_level = string_of_int -let default_levels_v8 = +let default_levels = [200,Gramext.RightA; 100,Gramext.RightA; 99,Gramext.RightA; @@ -574,20 +435,16 @@ let default_levels_v8 = 1,Gramext.LeftA; 0,Gramext.RightA] -let default_pattern_levels_v8 = +let default_pattern_levels = [10,Gramext.LeftA; 0,Gramext.RightA] let level_stack = - ref - [if !Options.v7 then (default_levels_v7, default_levels_v7) - else (default_levels_v8, default_pattern_levels_v8)] + ref [(default_levels, default_pattern_levels)] (* At a same level, LeftA takes precedence over RightA and NoneA *) (* In case, several associativity exists for a level, we make two levels, *) (* first LeftA, then RightA and NoneA together *) -exception Found of Gramext.g_assoc - open Ppextend let admissible_assoc = function @@ -610,48 +467,35 @@ let error_level_assoc p current expected = pr_assoc expected ++ str " associative") let find_position forpat other assoc lev = - let default = if !Options.v7 then Some (10,Gramext.RightA) else None in let ccurrent,pcurrent as current = List.hd !level_stack in match lev with | None -> level_stack := current :: !level_stack; None, (if other then assoc else None), None | Some n -> - if !Options.v7 & n = 8 & assoc = Some Gramext.LeftA then - error "Left associativity not allowed at level 8"; - let after = ref default in + let after = ref None in let rec add_level q = function - | (p,_ as pa)::l when p > n -> pa :: add_level (Some pa) l - | (p,a as pa)::l as l' when p = n -> - if admissible_assoc (a,assoc) then raise (Found a); - (* No duplication of levels in v8 *) - if not !Options.v7 then error_level_assoc p a (out_some assoc); - (* Maybe this was (p,Left) and p occurs a second time *) - if a = Gramext.LeftA then - match l with - | (p,a)::_ when p = n -> raise (Found a) - | _ -> after := Some pa; pa::(n,create_assoc assoc)::l - else - (* This was not (p,LeftA) hence assoc is RightA *) - (after := q; (n,create_assoc assoc)::l') - | l -> - after := q; (n,create_assoc assoc)::l + | (p,_ as pa)::l when p > n -> pa :: add_level (Some p) l + | (p,a)::l when p = n -> + if admissible_assoc (a,assoc) then raise Exit; + error_level_assoc p a (out_some assoc) + | l -> after := q; (n,create_assoc assoc)::l in try (* Create the entry *) let updated = - if forpat then (ccurrent, add_level default pcurrent) - else (add_level default ccurrent, pcurrent) in + if forpat then (ccurrent, add_level None pcurrent) + else (add_level None ccurrent, pcurrent) in level_stack := updated:: !level_stack; let assoc = create_assoc assoc in (if !after = None then Some Gramext.First - else Some (Gramext.After (constr_level2 (out_some !after)))), - Some assoc, Some (constr_level2 (n,assoc)) + else Some (Gramext.After (constr_level (out_some !after)))), + Some assoc, Some (constr_level n) with - Found a -> + Exit -> level_stack := current :: !level_stack; (* Just inherit the existing associativity and name (None) *) - Some (Gramext.Level (constr_level2 (n,a))), None, None + Some (Gramext.Level (constr_level n)), None, None let remove_levels n = level_stack := list_skipn n !level_stack @@ -729,7 +573,7 @@ let compute_entry allow_create adjust forpat = function | ETConstr (n,q) -> (if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr), - (if forpat & !Options.v7 then None else adjust (n,q)), false + adjust (n,q), false | ETIdent -> weaken_entry Constr.ident, None, false | ETBigint -> weaken_entry Prim.bigint, None, false | ETReference -> weaken_entry Constr.global, None, false @@ -747,7 +591,7 @@ let compute_entry allow_create adjust forpat = function (* This computes the name of the level where to add a new rule *) let get_constr_entry forpat en = match en with - ETConstr(200,()) when not !Options.v7 & not forpat -> + ETConstr(200,()) when not forpat -> snd (get_entry (get_univ "constr") "binder_constr"), None, false @@ -756,25 +600,7 @@ let get_constr_entry forpat en = (* This computes the name to give to a production knowing the name and associativity of the level where it must be added *) let get_constr_production_entry ass from forpat en = - (* first 2 cases to help factorisation *) - match en with - | ETConstr (NumLevel 10,q) when !Options.v7 & not forpat -> - weaken_entry Constr.lconstr, None, false -(* - | ETConstr (8,q) when !Options.v7 -> - weaken_entry Constr.constr, None, false -*) - | _ -> compute_entry false (adjust_level ass from) forpat en - -let constr_prod_level assoc cur lev = - if !Options.v7 then - if cur then constr_level (lev,assoc) else - match lev with - | 4 when !Options.v7 -> "4L" - | n -> string_of_int n - else - (* No duplication L/R of levels in v8 *) - constr_level (lev,assoc) + compute_entry false (adjust_level ass from) forpat en let is_self from e = match from, e with @@ -789,8 +615,7 @@ let is_self from e = let is_binder_level from e = match from, e with ETConstr(200,()), - ETConstr(NumLevel 200,(BorderProd(false,_)|InternalProd)) -> - not !Options.v7 + ETConstr(NumLevel 200,(BorderProd(false,_)|InternalProd)) -> true | _ -> false let rec symbol_of_production assoc from forpat typ = @@ -814,4 +639,19 @@ let rec symbol_of_production assoc from forpat typ = | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj) | (eobj,Some None,_) -> Gramext.Snext | (eobj,Some (Some (lev,cur)),_) -> - Gramext.Snterml (Gram.Entry.obj eobj,constr_prod_level assoc cur lev) + Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev) + +let coerce_reference_to_id = function + | Ident (_,id) -> id + | Qualid (loc,_) -> + user_err_loc (loc, "coerce_reference_to_id", + str "This expression should be a simple identifier") + +let coerce_global_to_id = coerce_reference_to_id + +let coerce_to_id = function + | CRef (Ident (loc,id)) -> (loc,id) + | a -> user_err_loc + (constr_loc a,"coerce_to_id", + str "This expression should be a simple identifier") + diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index a6aa7417e..87e0c24ba 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -11,13 +11,12 @@ open Util open Names open Rawterm -open Ast +open Extend open Genarg open Topconstr open Tacexpr open Vernacexpr open Libnames -open Extend (* The lexer and parser of Coq. *) @@ -31,16 +30,15 @@ type grammar_object (* The type of typed grammar objects *) type typed_entry -val type_of_typed_entry : typed_entry -> Extend.entry_type +type entry_type = argument_type + +val type_of_typed_entry : typed_entry -> entry_type val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e val get_constr_entry : bool -> constr_entry -> grammar_object Gram.Entry.e * int option * bool -val symbol_of_production : Gramext.g_assoc option -> constr_entry -> - bool -> constr_production_entry -> Token.t Gramext.g_symbol - val grammar_extend : grammar_object Gram.Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * @@ -83,22 +81,6 @@ val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_ val get_generic_entry : string -> grammar_object Gram.Entry.e val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type -type parser_type = - | ConstrParser - | CasesPatternParser - -val entry_type_of_parser : parser_type -> entry_type option -val parser_type_from_name : string -> parser_type - -(* Quotations in ast parser *) -val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit -val set_globalizer : (constr_expr -> Coqast.t) -> unit - -(* The default parser for actions in grammar rules *) - -val default_action_parser : dynamic_grammar Gram.Entry.e -val set_default_action_parser : parser_type -> unit - (* The main entry: reads an optional vernac command *) val main_entry : (loc * vernac_expr) option Gram.Entry.e @@ -124,13 +106,7 @@ module Prim : val reference : reference Gram.Entry.e val dirpath : dir_path Gram.Entry.e val ne_string : string Gram.Entry.e - val hyp : identifier Gram.Entry.e - (* v7 only entries *) - val astpat: typed_ast Gram.Entry.e - val ast : Coqast.t Gram.Entry.e - val astlist : Coqast.t list Gram.Entry.e - val ast_eoi : Coqast.t Gram.Entry.e - val var : identifier Gram.Entry.e + val var : identifier located Gram.Entry.e end module Constr : @@ -164,8 +140,7 @@ module Tactic : val casted_open_constr : open_constr_expr Gram.Entry.e val constr_with_bindings : constr_expr with_bindings Gram.Entry.e val bindings : constr_expr bindings Gram.Entry.e -(*v7*) val constrarg : (constr_expr,reference) may_eval Gram.Entry.e -(*v8*) val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e + val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e val quantified_hypothesis : quantified_hypothesis Gram.Entry.e val int_or_var : int or_var Gram.Entry.e val red_expr : raw_red_expr Gram.Entry.e @@ -176,12 +151,6 @@ module Tactic : val tactic_main_level : int val tactic : raw_tactic_expr Gram.Entry.e val tactic_eoi : raw_tactic_expr Gram.Entry.e - - (* For v7 *) - val tactic_expr2 : raw_tactic_expr Gram.Entry.e - val tactic_expr3 : raw_tactic_expr Gram.Entry.e - val tactic_expr4 : raw_tactic_expr Gram.Entry.e - val tactic_expr5 : raw_tactic_expr Gram.Entry.e end module Vernac_ : @@ -195,7 +164,10 @@ module Vernac_ : val vernac_eoi : vernac_expr Gram.Entry.e end -val reset_all_grammars : unit -> unit +(* Binding entry names to campl4 entries *) + +val symbol_of_production : Gramext.g_assoc option -> constr_entry -> + bool -> constr_production_entry -> Token.t Gramext.g_symbol (* Registering/resetting the level of an entry *) @@ -204,3 +176,7 @@ val find_position : Gramext.position option * Gramext.g_assoc option * string option val remove_levels : int -> unit + +val coerce_global_to_id : reference -> identifier + +val coerce_to_id : constr_expr -> identifier located diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index c47ad04c3..e6de302f6 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -9,381 +9,15 @@ (* $Id$ *) (*i*) -open Ast open Util open Pp open Nametab open Names open Nameops open Libnames -open Coqast open Ppextend open Topconstr open Term open Pattern (*i*) -let latom = 0 -let lannot = 1 -let lprod = 8 (* not 1 because the scope extends to 8 on the right *) -let llambda = 8 (* not 1 *) -let lif = 8 (* not 1 *) -let lletin = 8 (* not 1 *) -let lcases = 1 -let larrow = 8 -let lcast = 9 -let lapp = 10 -let ltop = (8,E) - -let prec_less child (parent,assoc) = match assoc with - | E -> child <= parent - | L -> child < parent - | Prec n -> child <= n - | Any -> true - -let env_assoc_value v env = - try List.nth env (v-1) - with Not_found -> anomaly "Inconsistent environment for pretty-print rule" - -let decode_constrlist_value = function - | CAppExpl (_,_,l) -> l - | CApp (_,_,l) -> List.map fst l - | _ -> anomaly "Ill-formed list argument of notation" - -let decode_patlist_value = function - | CPatCstr (_,_,l) -> l - | _ -> anomaly "Ill-formed list argument of notation" - -open Notation - -let rec print_hunk n decode pr env = function - | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env) - | UnpListMetaVar (e,prec,sl) -> - prlist_with_sep (fun () -> prlist (print_hunk n decode pr env) sl) - (pr (n,prec)) (decode (env_assoc_value e env)) - | UnpTerminal s -> str s - | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk n decode pr env) sub) - | UnpCut cut -> ppcmd_of_cut cut - -let pr_notation_gen decode pr s env = - let unpl, level = find_notation_printing_rule s in - prlist (print_hunk level decode pr env) unpl, level - -let pr_notation = pr_notation_gen decode_constrlist_value -let pr_patnotation = pr_notation_gen decode_patlist_value - -let pr_delimiters key strm = - let left = "'"^key^":" and right = "'" in - let lspace = - if is_letter (left.[String.length left -1]) then str " " else mt () in - let rspace = - let c = right.[0] in - if is_letter c or is_digit c or c = '\'' then str " " else mt () in - str left ++ lspace ++ strm ++ rspace ++ str right - -open Rawterm - -let pr_opt pr = function - | None -> mt () - | Some x -> spc () ++ pr x - -let pr_universe = Univ.pr_uni - -let pr_sort = function - | RProp Term.Null -> str "Prop" - | RProp Term.Pos -> str "Set" - | RType u -> str "Type" ++ pr_opt pr_universe u - -let pr_explicitation = function - | None -> mt () - | Some (_,ExplByPos n) -> int n ++ str "!" - | Some (_,ExplByName n) -> anomaly "Argument made explicit by name" - -let pr_expl_args pr (a,expl) = - pr_explicitation expl ++ pr (lapp,L) a - -let pr_opt_type pr = function - | CHole _ -> mt () - | t -> str ":" ++ pr ltop t - -let pr_tight_coma () = str "," ++ cut () - -let pr_located pr (loc,x) = pr x - -let pr_let_binder pr x a = - hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ brk(0,1) ++ pr ltop a) - -let pr_binder pr (nal,t) = - hov 0 ( - prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++ - pr_opt_type pr t) - -let pr_binders pr bl = - hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl) - -let pr_local_binder pr = function - LocalRawAssum(nal,t) -> pr_binder pr (nal,t) - | LocalRawDef((_,na),t) -> pr_let_binder pr na t - -let pr_local_binders pr bl = - hv 0 (prlist_with_sep pr_semicolon (pr_local_binder pr) bl) - -let pr_global vars ref = pr_global_env vars ref - -let rec pr_lambda_tail pr bll = function - | CLambdaN (_,bl,a) -> - pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_binders pr bl) a - | CLetIn (_,x,a,b) -> - pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_let_binder pr (snd x) a) b - | a -> - bll, pr ltop a - -let rec pr_prod_tail pr bll = function - | CProdN (_,bl,a) -> - pr_prod_tail pr (bll ++ pr_semicolon () ++ pr_binders pr bl) a - | a -> bll, pr ltop a - -let pr_recursive_decl pr id binders t c = - pr_id id ++ binders ++ - brk (1,2) ++ str ": " ++ pr ltop t ++ str " :=" ++ - brk (1,2) ++ pr ltop c - -let split_lambda = function - | CLambdaN (loc,[[na],t],c) -> (na,t,c) - | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) - | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c)) - | _ -> anomaly "ill-formed fixpoint body" - -let split_product = function - | CArrow (loc,t,c) -> ((loc,Anonymous),t,c) - | CProdN (loc,[[na],t],c) -> (na,t,c) - | CProdN (loc,([na],t)::bl,c) -> (na,t,CProdN(loc,bl,c)) - | CProdN (loc,(na::nal,t)::bl,c) -> (na,t,CProdN(loc,(nal,t)::bl,c)) - | _ -> anomaly "ill-formed fixpoint body" - -let concat_binder na t = function - | [] -> [[na],t] - | (nal,u)::bl' as bl -> if t=u then (na::nal,t)::bl' else ([na],t)::bl - -let rec split_fix n typ def = - if n = 0 then ([],typ,def) - else - let (na,_,def) = split_lambda def in - let (_,t,typ) = split_product typ in - let (bl,typ,def) = split_fix (n-1) typ def in - (concat_binder na t bl,typ,def) - -let pr_fixdecl pr (id,n,bl,t,c) = - pr_recursive_decl pr id - (brk (1,2) ++ str "[" ++ pr_local_binders pr bl ++ str "]") t c - -let pr_cofixdecl pr (id,bl,t,c) = - let b = - if bl=[] then mt() else - brk(1,2) ++ str"[" ++ pr_local_binders pr bl ++ str "]" in - pr_recursive_decl pr id b t c - -let pr_recursive fix pr_decl id = function - | [] -> anomaly "(co)fixpoint with no definition" - | d1::dl -> - hov 0 ( - str fix ++ spc () ++ pr_id id ++ brk (1,2) ++ str "{" ++ - (v 0 ( - (hov 0 (pr_decl d1)) ++ - (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix)) - dl))) ++ - str "}") - -let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr) -let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr) - -let rec pr_arrow pr = function - | CArrow (_,a,b) -> pr (larrow,L) a ++ cut () ++ str "->" ++ pr_arrow pr b - | a -> pr (larrow,E) a - -let pr_annotation pr = function - | None -> mt () - | Some t -> str "<" ++ pr ltop t ++ str ">" ++ brk (0,2) - -let rec pr_cases_pattern _inh = function - | CPatAlias (_,p,x) -> - pr_cases_pattern _inh p ++ spc () ++ str "as" ++ spc () ++ pr_id x - | CPatCstr (_,c,[]) -> pr_reference c - | CPatCstr (_,c,pl) -> - hov 0 ( - str "(" ++ pr_reference c ++ spc () ++ - prlist_with_sep spc (pr_cases_pattern _inh) pl ++ str ")") - | CPatAtom (_,Some c) -> pr_reference c - | CPatAtom (_,None) -> str "_" - | CPatOr (_,pl) -> - str "(" ++ - hov 0 (prlist_with_sep pr_bar (pr_cases_pattern _inh) pl) ++ - str ")" - | CPatNotation (_,"( _ )",[p]) -> - str"("++ pr_cases_pattern _inh p ++ str")" - | CPatNotation (_,s,env) -> fst (pr_patnotation pr_cases_pattern s env) - | CPatNumeral (_,n) -> Bigint.pr_bigint n - | CPatDelimiters (_,key,p) -> pr_delimiters key (pr_cases_pattern _inh p) - -let pr_cases_pattern = pr_cases_pattern (0,E) (* level unused *) - -let pr_eqn pr (_,patl,rhs) = - hov 0 ( - prlist_with_sep spc pr_cases_pattern patl ++ spc () ++ - str "=>" ++ - brk (1,1) ++ pr ltop rhs) ++ spc () - -let pr_cases pr (po,_) tml eqns = - hov 0 ( - pr_annotation pr po ++ - hv 0 ( - hv 0 ( - str "Cases" ++ brk (1,2) ++ - prlist_with_sep spc (fun (tm,_) -> pr ltop tm) tml ++ spc() ++ str "of") ++ brk(1,2) ++ - prlist_with_sep (fun () -> str "| ") (pr_eqn pr) eqns ++ - str "end")) - -let pr_proj pr pr_app a f l = - hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")") - -let pr_explapp pr f l = - hov 0 ( - str "!" ++ pr_reference f ++ - prlist (fun a -> brk (1,1) ++ pr (lapp,L) a) l) - -let pr_app pr a l = - hov 0 ( - pr (lapp,L) a ++ - prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l) - -let rec pr inherited a = - let (strm,prec) = match a with - | CRef r -> pr_reference r, latom - | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom - | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom - | CArrow _ -> hv 0 (pr_arrow pr a), larrow - | CProdN (_,bl,a) -> - let bll, a = pr_prod_tail pr (mt()) a in - hv 1 ( - hv 1 (str "(" ++ pr_binders pr bl ++ bll ++ str ")") ++ - brk (0,1) ++ a), lprod - | CLambdaN (_,bl,a) -> - let bll, a = pr_lambda_tail pr (mt()) a in - hv 1 ( - hv 1 (str "[" ++ pr_binders pr bl ++ bll ++ str "]") ++ - brk (0,1) ++ a), llambda - | CLetIn (_,x,a,b) -> - let bll, b = pr_lambda_tail pr (mt()) b in - hv 1 ( - hv 1 (str "[" ++ pr_let_binder pr (snd x) a ++ bll ++ str "]") ++ - brk (0,1) ++ b), lletin - | CAppExpl (_,((* V7 don't know about projections *)_,f),l) -> - pr_explapp pr f l, lapp - | CApp (_,(_,a),l) -> - pr_app pr a l, lapp - | CCases (_,po,tml,eqns) -> - pr_cases pr po tml eqns, lcases - | COrderedCase (_,IfStyle,po,c,[b1;b2]) -> - (* On force les parenthèses autour d'un "if" sous-terme (même si le - parsing est lui plus tolérant) *) - hov 0 ( - pr_annotation pr po ++ - hv 0 ( - str "if " ++ pr ltop c ++ spc () ++ - hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++ - hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lif - | CLetTuple _ | CIf _ -> - anomaly "Let tuple and If not supported in v7" - - | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) -> - hov 0 ( - hov 0 ( - pr_annotation pr po ++ - hov 0 ( - str (if style=RegularStyle then "Case" else "Match") ++ - brk (1,1) ++ pr ltop c ++ spc () ++ - str (if style=RegularStyle then "of" else "with") ++ - brk (1,3) ++ - fnl () ++ hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl) ++ - str "end"))), lcases - | COrderedCase (_,_,_,_,_) -> - anomaly "malformed if or destructuring let" - | CHole _ -> str "?", latom -(* - | CEvar (_,n) -> str "?" ++ int n, latom -*) - | CEvar (_,n) -> str (Evd.string_of_existential n), latom - | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom - | CSort (_,s) -> pr_sort s, latom - | CCast (_,a,_,b) -> - hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast - | CNotation (_,"( _ )",[t]) -> - str"("++ pr (max_int,E) t ++ str")", latom - | CNotation (_,s,env) -> pr_notation pr s env - | CNumeral (_,p) -> Bigint.pr_bigint p, latom - | CDelimiters (_,sc,a) -> pr_delimiters sc (pr ltop a), latom - | CDynamic _ -> str "<dynamic>", latom - in - if prec_less prec inherited then strm - else str"(" ++ strm ++ str")" - -let pr_constr = pr ltop - -let pr_pattern = pr_constr - -let pr_qualid qid = str (string_of_qualid qid) - -open Rawterm - -let pr_arg pr x = spc () ++ pr x - -let pr_red_flag pr r = - (if r.rBeta then pr_arg str "Beta" else mt ()) ++ - (if r.rIota then pr_arg str "Iota" else mt ()) ++ - (if r.rZeta then pr_arg str "Zeta" else mt ()) ++ - (if r.rConst = [] then - if r.rDelta then pr_arg str "Delta" - else mt () - else - pr_arg str "Delta" ++ (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) - -open Genarg - -let pr_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c - -let pr_red_expr (pr_constr,pr_ref) = function - | Red false -> str "Red" - | Hnf -> str "Hnf" - | Simpl o -> str "Simpl" ++ pr_opt (pr_occurrences pr_constr) o - | Cbv f -> - if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then - str "Compute" - else - hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (str "Unfold" ++ - prlist (fun (nl,qid) -> - prlist (pr_arg int) nl ++ spc () ++ pr_ref qid) l) - | Fold l -> hov 1 (str "Fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> hov 1 (str "Pattern " ++ prlist (pr_occurrences pr_constr) l) - | Red true -> error "Shouldn't be accessible from user" - | ExtraRedExpr s -> str s - | CbvVm -> str "vm_compute" - - -let rec pr_may_eval pr pr2 = function - | ConstrEval (r,c) -> - hov 0 - (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr2) r ++ - spc () ++ str "in" ++ brk (1,1) ++ pr c) - | ConstrContext ((_,id),c) -> - hov 0 - (str "Inst " ++ brk (1,1) ++ pr_id id ++ spc () ++ - str "[" ++ pr c ++ str "]") - | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c) - | ConstrTerm c -> pr c - -let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c) diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 3ca626121..5bbeecc2c 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -8,33 +8,3 @@ (*i $Id$ i*) -open Pp -open Environ -open Term -open Libnames -open Pcoq -open Rawterm -open Extend -open Coqast -open Topconstr -open Names -open Util - -val split_fix : int -> constr_expr -> constr_expr -> - (name located list * constr_expr) list * constr_expr * constr_expr - -val pr_global : Idset.t -> global_reference -> std_ppcmds - -val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds -val pr_qualid : qualid -> std_ppcmds -val pr_red_expr : - ('a -> std_ppcmds) * ('b -> std_ppcmds) -> - ('a,'b) red_expr_gen -> std_ppcmds -val pr_occurrences : ('a -> std_ppcmds) -> 'a occurrences -> std_ppcmds - -val pr_sort : rawsort -> std_ppcmds -val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds -val pr_constr : constr_expr -> std_ppcmds -val pr_cases_pattern : cases_pattern_expr -> std_ppcmds -val pr_may_eval : ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds -val pr_rawconstr : rawconstr -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index d5c42a04d..9803c0031 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -12,7 +12,6 @@ open Pp open Names open Nameops open Util -open Extend open Tacexpr open Rawterm open Topconstr @@ -21,28 +20,21 @@ open Libnames open Pattern open Ppextend -let pr_red_expr = Ppconstr.pr_red_expr -let pr_may_eval = Ppconstr.pr_may_eval -let pr_sort = Ppconstr.pr_sort -let pr_global x = - if Options.do_translate () then (* for pr_gen *) - Ppconstrnew.pr_global Idset.empty x - else - Ppconstr.pr_global Idset.empty x -let pr_opt = Ppconstr.pr_opt -let pr_occurrences = Ppconstr.pr_occurrences +let pr_red_expr = Ppconstrnew.pr_red_expr +let pr_may_eval = Ppconstrnew.pr_may_eval +let pr_sort = Ppconstrnew.pr_sort +let pr_global x = Nametab.pr_global_env Idset.empty x +let pr_opt = Ppconstrnew.pr_opt type grammar_terminals = string option list (* Extensions *) -let prtac_tab_v7 = Hashtbl.create 17 let prtac_tab = Hashtbl.create 17 -let declare_extra_tactic_pprule for_v8 s (tags,prods) = - Hashtbl.add prtac_tab_v7 (s,tags) prods; - if for_v8 then Hashtbl.add prtac_tab (s,tags) prods +let declare_extra_tactic_pprule (s,tags,prods) = + Hashtbl.add prtac_tab (s,tags) prods -let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab_v7 (s,tags) +let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags) type 'a raw_extra_genarg_printer = (constr_expr -> std_ppcmds) -> @@ -62,10 +54,9 @@ type 'a extra_genarg_printer = (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds -let genarg_pprule_v7 = ref Stringmap.empty let genarg_pprule = ref Stringmap.empty -let declare_extra_genarg_pprule for_v8 (rawwit, f) (globwit, g) (wit, h) = +let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) = let s = match unquote wit with | ExtraArgType s -> s | _ -> error @@ -74,9 +65,7 @@ let declare_extra_genarg_pprule for_v8 (rawwit, f) (globwit, g) (wit, h) = let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in - genarg_pprule_v7 := Stringmap.add s (f,g,h) !genarg_pprule_v7; - if for_v8 then - genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule + genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule let pr_arg pr x = spc () ++ pr x @@ -92,14 +81,10 @@ let pr_and_short_name pr (c,_) = pr c let pr_located pr (loc,x) = pr x -let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) - let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Libnames.ConstRef sp) -let pr_inductive ind = pr_global (Libnames.IndRef ind) - let pr_quantified_hypothesis = function | AnonHyp n -> int n | NamedHyp id -> pr_id id @@ -116,12 +101,7 @@ let pr_bindings prc prlc = function prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ - prlist_with_sep spc - (fun b -> if Options.do_translate () or not !Options.v7 then - str"(" ++ pr_binding prlc b ++ str")" - else - pr_binding prc b) - l + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_bindings_no_with prc prlc = function @@ -130,21 +110,11 @@ let pr_bindings_no_with prc prlc = function prlist_with_sep spc prc l | ExplicitBindings l -> brk (1,1) ++ - prlist_with_sep spc - (fun b -> if Options.do_translate () or not !Options.v7 then - str"(" ++ pr_binding prlc b ++ str")" - else - pr_binding prc b) - l + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = - if Options.do_translate () then - (* translator calls pr_with_bindings on rawconstr: we cast it! *) - let bl' = Ppconstrnew.translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in - prc c ++ hv 0 (pr_bindings prc prlc bl') - else - prc c ++ hv 0 (pr_bindings prc prlc bl) + prc c ++ hv 0 (pr_bindings prc prlc bl) let pr_with_constr prc = function | None -> mt () @@ -154,111 +124,6 @@ let pr_with_names = function | None -> mt () | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat) -let pr_hyp_location pr_id = function - | id, _, (InHyp,_) -> spc () ++ pr_id id - | id, _, (InHypTypeOnly,_) -> - spc () ++ str "(Type of " ++ pr_id id ++ str ")" - | id, _, _ -> error "Unsupported hyp location in v7" - -let pr_clause pr_id = function - | [] -> mt () - | l -> spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) - -let pr_clauses pr_id cls = - match cls with - { onhyps = Some l; onconcl = false } -> - spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l) - | { onhyps = Some []; onconcl = true } -> mt() - | _ -> error "this clause has both hypothesis and conclusion" - -let pr_simple_clause pr_id = function - | [] -> mt () - | l -> spc () ++ - hov 0 (str "in" ++ spc () ++ prlist_with_sep spc pr_id l) - -let pr_clause_pattern pr_id cls = - pr_opt - (prlist (fun (id,occs,_) -> - prlist (pr_arg int) occs ++ spc () ++ pr_id id)) cls.onhyps ++ - if cls.onconcl then - prlist (pr_arg int) cls.concl_occs ++ spc() ++ str"Goal" - else mt() - -let pr_subterms pr occl = - hov 0 (pr_occurrences pr occl ++ spc () ++ str "with") - -let pr_induction_arg prc = function - | ElimOnConstr c -> prc c - | ElimOnIdent (_,id) -> pr_id id - | ElimOnAnonHyp n -> int n - -let pr_induction_kind = function - | SimpleInversion -> str "Simple Inversion" - | FullInversion -> str "Inversion" - | FullInversionClear -> str "Inversion_clear" - -let pr_lazy lz = if lz then str "lazy " else mt () - -let pr_match_pattern pr_pat = function - | Term a -> pr_pat a - | Subterm (None,a) -> str "[" ++ pr_pat a ++ str "]" - | Subterm (Some id,a) -> pr_id id ++ str "[" ++ pr_pat a ++ str "]" - -let pr_match_hyps pr_pat = function - | Hyp ((_,na),mp) -> pr_name na ++ str ":" ++ pr_match_pattern pr_pat mp - -let pr_match_rule m pr_pat pr = function - | Pat ([],mp,t) when m -> - str "[" ++ pr_match_pattern pr_pat mp ++ str "]" - ++ spc () ++ str "->" ++ brk (1,2) ++ pr t - | Pat (rl,mp,t) -> - str "[" ++ prlist_with_sep pr_semicolon - (pr_match_hyps pr_pat) rl ++ spc () ++ - str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "]" ++ - spc () ++ str "->" ++ brk (1,2) ++ pr t - | All t -> str "_" ++ spc () ++ str "->" ++ brk (1,2) ++ pr t - -let pr_funvar = function - | None -> spc () ++ str "()" - | Some id -> spc () ++ pr_id id - -let pr_let_clause k pr = function - | ((_,id),None,t) -> hv 0(str k ++ pr_id id ++ str " =" ++ brk (1,1) ++ pr t) - | ((_,id),Some c,t) -> str "TODO(LETCLAUSE)" - -let pr_let_clauses pr = function - | hd::tl -> - hv 0 - (pr_let_clause "Let " pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "And " pr t) tl) - | [] -> anomaly "LetIn must declare at least one binding" - -let pr_rec_clause pr ((_,id),(l,t)) = - pr_id id ++ prlist pr_funvar l ++ str "->" ++ spc () ++ pr t - -let pr_rec_clauses pr l = - prlist_with_sep (fun () -> fnl () ++ str "And ") (pr_rec_clause pr) l - -let pr_hintbases = function - | None -> spc () ++ str "with *" - | Some [] -> mt () - | Some l -> - spc () ++ str "with" ++ hv 0 (prlist (fun s -> spc () ++ str s) l) - -let pr_autoarg_adding = function - | [] -> mt () - | l -> - spc () ++ str "Adding [" ++ - hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" - -let pr_autoarg_destructing = function - | true -> spc () ++ str "Destructing" - | false -> mt () - -let pr_autoarg_usingTDB = function - | true -> spc () ++ str "Using TDB" - | false -> mt () - let rec pr_raw_generic prc prlc prtac prref x = match Genarg.genarg_tag x with | BoolArgType -> pr_arg str (if out_gen rawwit_bool x then "true" else "false") @@ -268,20 +133,18 @@ let rec pr_raw_generic prc prlc prtac prref x = | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen rawwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen rawwit_ident x)) - | HypArgType -> pr_arg - (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen rawwit_var x) + | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x) + | VarArgType -> pr_arg (pr_located pr_id) (out_gen rawwit_var x) | RefArgType -> pr_arg prref (out_gen rawwit_ref x) | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x) | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc prref) + pr_arg (pr_may_eval prc prlc prref) (out_gen rawwit_constr_may_eval x) - | QuantHypArgType -> + | QuantVarArgType -> pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr - (prc,prref)) (out_gen rawwit_red_expr x) + pr_arg (pr_red_expr (prc,prlc,prref)) (out_gen rawwit_red_expr x) | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (rawwit_tactic n) x) | OpenConstrArgType b -> pr_arg prc (snd (out_gen (rawwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> @@ -300,10 +163,7 @@ let rec pr_raw_generic prc prlc prtac prref x = pr_raw_generic prc prlc prtac prref b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi1 (Stringmap.find s tab) prc prlc prtac x + try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "] " @@ -316,19 +176,20 @@ let rec pr_glob_generic prc prlc prtac x = | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen globwit_ident x)) - | HypArgType -> pr_arg (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen globwit_var x) + | IdentArgType -> pr_arg pr_id (out_gen globwit_ident x) + | VarArgType -> pr_arg (pr_located pr_id) (out_gen globwit_var x) | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x) | SortArgType -> pr_arg pr_sort (out_gen globwit_sort x) | ConstrArgType -> pr_arg prc (out_gen globwit_constr x) | ConstrMayEvalArgType -> - pr_arg (pr_may_eval prc + pr_arg (pr_may_eval prc prlc (pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_constr_may_eval x) - | QuantHypArgType -> + | QuantVarArgType -> pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x) | RedExprArgType -> pr_arg (pr_red_expr - (prc,pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_red_expr x) + (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference))) + (out_gen globwit_red_expr x) | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (globwit_tactic n) x) | OpenConstrArgType b -> pr_arg prc (snd (out_gen (globwit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> @@ -347,10 +208,7 @@ let rec pr_glob_generic prc prlc prtac x = pr_glob_generic prc prlc prtac b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi2 (Stringmap.find s tab) prc prlc prtac x + try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "] " open Closure @@ -364,17 +222,18 @@ let rec pr_generic prc prlc prtac x = | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x) | IntroPatternArgType -> pr_arg pr_intro_pattern (out_gen wit_intro_pattern x) - | IdentArgType -> pr_arg pr_id (Constrextern.v7_to_v8_id (out_gen wit_ident x)) - | HypArgType -> pr_arg prc (out_gen wit_var x) + | IdentArgType -> pr_arg pr_id (out_gen wit_ident x) + | VarArgType -> pr_arg pr_id (out_gen wit_var x) | RefArgType -> pr_arg pr_global (out_gen wit_ref x) | SortArgType -> pr_arg prc (Term.mkSort (out_gen wit_sort x)) | ConstrArgType -> pr_arg prc (out_gen wit_constr x) | ConstrMayEvalArgType -> pr_arg prc (out_gen wit_constr_may_eval x) - | QuantHypArgType -> + | QuantVarArgType -> pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr (prc,pr_evaluable_reference)) (out_gen wit_red_expr x) + pr_arg (pr_red_expr (prc,prlc,pr_evaluable_reference)) + (out_gen wit_red_expr x) | TacticArgType n -> pr_arg (prtac (n,E)) (out_gen (wit_tactic n) x) | OpenConstrArgType b -> pr_arg prc (snd (out_gen (wit_open_constr_gen b) x)) | ConstrWithBindingsArgType -> @@ -393,10 +252,7 @@ let rec pr_generic prc prlc prtac x = pr_generic prc prlc prtac b) x) | ExtraArgType s -> - let tab = - if Options.do_translate() or not !Options.v7 then !genarg_pprule - else !genarg_pprule_v7 in - try pi3 (Stringmap.find s tab) prc prlc prtac x + try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str " [no printer for " ++ str s ++ str "]" let rec pr_tacarg_using_rule pr_gen = function @@ -408,388 +264,17 @@ let rec pr_tacarg_using_rule pr_gen = function let surround p = hov 1 (str"(" ++ p ++ str")") let pr_extend_gen prgen lev s l = - let tab = - if Options.do_translate() or not !Options.v7 then prtac_tab - else prtac_tab_v7 - in try let tags = List.map genarg_tag l in - (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *) - let s = - let n = String.length s in - if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "v7" - then String.sub s 0 (n-2) ^ "v8" - else s in - let (lev',pl) = Hashtbl.find tab (s,tags) in + let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in let p = pr_tacarg_using_rule prgen (pl,l) in if lev' > lev then surround p else p with Not_found -> str s ++ prlist prgen l ++ str " (* Generic printer *)" -let make_pr_tac (pr_tac_level,pr_constr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend) = - -let pr_bindings = pr_bindings pr_constr pr_constr in -let pr_with_bindings = pr_with_bindings pr_constr pr_constr in -let pr_eliminator cb = str "using" ++ pr_arg (pr_with_bindings) cb in -let pr_intarg n = spc () ++ int n in - - (* Printing tactics as arguments *) -let rec pr_atom0 = function - | TacIntroPattern [] -> str "Intros" - | TacIntroMove (None,None) -> str "Intro" - | TacAssumption -> str "Assumption" - | TacAnyConstructor None -> str "Constructor" - | TacTrivial (Some []) -> str "Trivial" - | TacAuto (None,Some []) -> str "Auto" - | TacAutoTDB None -> str "AutoTDB" - | TacDestructConcl -> str "DConcl" - | TacReflexivity -> str "Reflexivity" - | t -> str "(" ++ pr_atom1 t ++ str ")" - - (* Main tactic printer *) -and pr_atom1 = function - | TacExtend (_,s,l) -> pr_extend pr_constr pr_constr pr_tac_level 1 s l - | TacAlias (_,s,l,_) -> - pr_extend pr_constr pr_constr pr_tac_level 1 s (List.map snd l) - - (* Basic tactics *) - | TacIntroPattern [] as t -> pr_atom0 t - | TacIntroPattern (_::_ as p) -> - hov 1 (str "Intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) - | TacIntrosUntil h -> - hv 1 (str "Intros until" ++ pr_arg pr_quantified_hypothesis h) - | TacIntroMove (None,None) as t -> pr_atom0 t - | TacIntroMove (Some id1,None) -> str "Intro " ++ pr_id id1 - | TacIntroMove (ido1,Some (_,id2)) -> - hov 1 - (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2) - | TacAssumption as t -> pr_atom0 t - | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c) - | TacExactNoCheck c -> hov 1 (str "Exact_no_check" ++ pr_arg pr_constr c) - | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb) - | TacElim (cb,cbo) -> - hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ - pr_opt pr_eliminator cbo) - | TacElimType c -> hov 1 (str "ElimType" ++ pr_arg pr_constr c) - | TacCase cb -> hov 1 (str "Case" ++ spc () ++ pr_with_bindings cb) - | TacCaseType c -> hov 1 (str "CaseType" ++ pr_arg pr_constr c) - | TacFix (ido,n) -> hov 1 (str "Fix" ++ pr_opt pr_id ido ++ pr_intarg n) - | TacMutualFix (id,n,l) -> - hov 1 (str "Fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc () ++ - hov 0 (str "with" ++ brk (1,1) ++ - prlist_with_sep spc - (fun (id,n,c) -> - spc () ++ pr_id id ++ pr_intarg n ++ pr_arg pr_constr c) - l)) - | TacCofix ido -> hov 1 (str "Cofix" ++ pr_opt pr_id ido) - | TacMutualCofix (id,l) -> - hov 1 (str "Cofix" ++ spc () ++ pr_id id ++ spc () ++ - hov 0 (str "with" ++ brk (1,1) ++ - prlist (fun (id,c) -> spc () ++ pr_id id ++ pr_arg pr_constr c) - l)) - | TacCut c -> hov 1 (str "Cut" ++ pr_arg pr_constr c) - | TacTrueCut (Anonymous,c) -> - hov 1 (str "Assert" ++ pr_arg pr_constr c) - | TacTrueCut (Name id,c) -> - hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c) - | TacForward (false,na,c) -> - hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) - | TacForward (true,na,c) -> - hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) - | TacGeneralize l -> - hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l) - | TacGeneralizeDep c -> - hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++ - pr_constr c) - | TacLetTac (na,c,cl) -> - let pcl = match cl with - {onhyps=None;onconcl=true;concl_occs=[]} -> mt() - | _ -> pr_clauses pr_ident cl in - hov 1 (str "LetTac" ++ spc () ++ pr_name na ++ str ":=" ++ - pr_constr c ++ pcl) - (* | TacInstantiate (n,c,ConclLocation ()) -> - hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ) - | TacInstantiate (n,c,HypLocation (id,hloc)) -> - hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ++ - str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) - *) - (* Derived basic tactics *) - | TacSimpleInduction (h,_) -> - hov 1 (str "Induction" ++ pr_arg pr_quantified_hypothesis h) - | TacNewInduction (h,e,(ids,_)) -> - hov 1 (str "NewInduction" ++ spc () ++ pr_induction_arg pr_constr h ++ - pr_opt pr_eliminator e ++ pr_with_names ids) - | TacSimpleDestruct h -> - hov 1 (str "Destruct" ++ pr_arg pr_quantified_hypothesis h) - | TacNewDestruct (h,e,(ids,_)) -> - hov 1 (str "NewDestruct" ++ spc () ++ pr_induction_arg pr_constr h ++ - pr_opt pr_eliminator e ++ pr_with_names ids) - | TacDoubleInduction (h1,h2) -> - hov 1 - (str "Double Induction" ++ - pr_arg pr_quantified_hypothesis h1 ++ - pr_arg pr_quantified_hypothesis h2) - | TacDecomposeAnd c -> - hov 1 (str "Decompose Record" ++ pr_arg pr_constr c) - | TacDecomposeOr c -> - hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c) - | TacDecompose (l,c) -> - hov 1 (str "Decompose" ++ spc () ++ - hov 0 (str "[" ++ prlist_with_sep spc pr_ind l - ++ str "]" ++ pr_arg pr_constr c)) - | TacSpecialize (n,c) -> - hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c) - | TacLApply c -> - hov 1 (str "LApply" ++ pr_constr c) - - (* Automation tactics *) - | TacTrivial (Some []) as x -> pr_atom0 x - | TacTrivial db -> hov 0 (str "Trivial" ++ pr_hintbases db) - | TacAuto (None,Some []) as x -> pr_atom0 x - | TacAuto (n,db) -> - hov 0 (str "Auto" ++ pr_opt (pr_or_var int) n ++ pr_hintbases db) - | TacAutoTDB None as x -> pr_atom0 x - | TacAutoTDB (Some n) -> hov 0 (str "AutoTDB" ++ spc () ++ int n) - | TacDestructHyp (true,(_,id)) -> hov 0 (str "CDHyp" ++ spc () ++ pr_id id) - | TacDestructHyp (false,(_,id)) -> hov 0 (str "DHyp" ++ spc () ++ pr_id id) - | TacDestructConcl as x -> pr_atom0 x - | TacSuperAuto (n,l,b1,b2) -> - hov 1 (str "SuperAuto" ++ pr_opt int n ++ pr_autoarg_adding l ++ - pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2) - | TacDAuto (n,p) -> - hov 1 (str "Auto" ++ pr_opt (pr_or_var int) n ++ str "Decomp" ++ pr_opt int p) - - (* Context management *) - | TacClear (keep,l) -> - hov 1 (str "Clear" ++ spc () ++ (if keep then str "- " else mt ()) ++ - prlist_with_sep spc pr_ident l) - | TacClearBody l -> - hov 1 (str "ClearBody" ++ spc () ++ prlist_with_sep spc pr_ident l) - | TacMove (b,id1,id2) -> - (* Rem: only b = true is available for users *) - assert b; - hov 1 - (str "Move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ - str "after" ++ brk (1,1) ++ pr_ident id2) - | TacRename (id1,id2) -> - hov 1 - (str "Rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ - str "into" ++ brk (1,1) ++ pr_ident id2) - - (* Constructors *) - | TacLeft l -> hov 1 (str "Left" ++ pr_bindings l) - | TacRight l -> hov 1 (str "Right" ++ pr_bindings l) - | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l) - | TacAnyConstructor (Some t) -> - hov 1 (str "Constructor" ++ pr_arg (pr_tac_level (0,E)) t) - | TacAnyConstructor None as t -> pr_atom0 t - | TacConstructor (n,l) -> - hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l) - - (* Conversion *) - | TacReduce (r,h) -> - hov 1 (pr_red_expr (pr_constr,pr_cst) r ++ pr_clauses pr_ident h) - | TacChange (occl,c,h) -> - hov 1 (str "Change" ++ pr_opt (pr_subterms pr_constr) occl ++ - brk (1,1) ++ pr_constr c ++ pr_clauses pr_ident h) - - (* Equivalence relations *) - | TacReflexivity as x -> pr_atom0 x - | TacSymmetry cls -> str "Symmetry " ++ pr_clauses pr_ident cls - | TacTransitivity c -> str "Transitivity" ++ pr_arg pr_constr c - - (* Equality and inversion *) - | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 (str "Dependent " ++ pr_induction_kind k ++ - pr_quantified_hypothesis hyp ++ - pr_with_names ids ++ pr_with_constr pr_constr c) - | TacInversion (NonDepInversion (k,cl,ids),hyp) -> - hov 1 (pr_induction_kind k ++ spc () ++ - pr_quantified_hypothesis hyp ++ - pr_with_names ids ++ pr_simple_clause pr_ident cl) - | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 (str "Inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ - str "using" ++ spc () ++ pr_constr c ++ - pr_simple_clause pr_ident cl) - -and pr_tactic_seq_body tl = - hv 0 (str "[ " ++ - prlist_with_sep (fun () -> spc () ++ str "| ") prtac tl ++ str " ]") - - (* Strictly closed atomic tactic expressions *) -and pr0 = function - | TacFirst tl -> str "First" ++ spc () ++ pr_tactic_seq_body tl - | TacSolve tl -> str "Solve" ++ spc () ++ pr_tactic_seq_body tl - | TacId "" -> str "Idtac" - | TacFail (ArgArg 0,"") -> str "Fail" - | TacAtom (_,t) -> pr_atom0 t - | TacArg c -> pr_tacarg c - | t -> str "(" ++ prtac t ++ str ")" - - (* Semi-closed atomic tactic expressions *) -and pr1 = function - | TacAtom (_,t) -> pr_atom1 t - | TacId s -> str "Idtac \"" ++ str s ++ str "\"" - | TacFail (ArgArg 0,s) -> str "Fail \"" ++ str s ++ str "\"" - | TacFail (n,"") -> str "Fail " ++ pr_or_var int n - | TacFail (n,s) -> str "Fail " ++ pr_or_var int n ++ str " \"" ++ str s ++ str "\"" - | t -> pr0 t - - (* Orelse tactic expressions (printed as if parsed associating on the right - though the semantics is purely associative) *) -and pr2 = function - | TacOrelse (t1,t2) -> - hov 1 (pr1 t1 ++ str " Orelse" ++ brk (1,1) ++ pr3 t2) - | TacAtom (_,TacAlias (_,s,l,_)) -> - pr_extend pr_constr pr_constr pr_tac_level 2 s (List.map snd l) - | t -> pr1 t - - (* Non closed prefix tactic expressions *) -and pr3 = function - | TacTry t -> hov 1 (str "Try" ++ spc () ++ pr3 t) - | TacDo (n,t) -> hov 1 (str "Do " ++ pr_or_var int n ++ spc () ++ pr3 t) - | TacRepeat t -> hov 1 (str "Repeat" ++ spc () ++ pr3 t) - | TacProgress t -> hov 1 (str "Progress" ++ spc () ++ pr3 t) - | TacInfo t -> hov 1 (str "Info" ++ spc () ++ pr3 t) - | TacAtom (_,TacAlias (_,s,l,_)) -> - pr_extend pr_constr pr_constr pr_tac_level 3 s (List.map snd l) - | t -> pr2 t - -and pr4 = function - | TacAtom (_,TacAlias (_,s,l,_)) -> - pr_extend pr_constr pr_constr pr_tac_level 4 s (List.map snd l) - | t -> pr3 t - - (* THEN and THENS tactic expressions (printed as if parsed - associating on the left though the semantics is purely associative) *) -and pr5 = function - | TacThens (t,tl) -> - hov 1 (pr5 t ++ str ";" ++ spc () ++ pr_tactic_seq_body tl) - | TacThen (t1,t2) -> - hov 1 (pr5 t1 ++ str ";" ++ spc () ++ pr4 t2) - | TacAtom (_,TacAlias (_,s,l,_)) -> - pr_extend pr_constr pr_constr pr_tac_level 5 s (List.map snd l) - | t -> pr4 t - - (* Ltac tactic expressions *) -and pr6 = function - |(TacAtom _ - | TacThen _ - | TacThens _ - | TacFirst _ - | TacSolve _ - | TacTry _ - | TacOrelse _ - | TacDo _ - | TacRepeat _ - | TacProgress _ - | TacId _ - | TacFail _ - | TacInfo _) as t -> pr5 t - - | TacAbstract (t,None) -> str "Abstract " ++ pr6 t - | TacAbstract (t,Some s) -> - hov 0 - (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s) - | TacLetRecIn (l,t) -> - hv 0 - (str "Rec " ++ pr_rec_clauses prtac l ++ - spc () ++ str "In" ++ fnl () ++ prtac t) - | TacLetIn (llc,u) -> - v 0 - (hv 0 (pr_let_clauses pr_tacarg0 llc ++ spc () ++ str "In") ++ fnl () ++ prtac u) - | TacMatch (lz,t,lrul) -> - hov 0 (pr_lazy lz ++ str "Match" ++ spc () ++ pr6 t ++ spc() - ++ str "With" - ++ prlist - (fun r -> fnl () ++ str "|" ++ spc () ++ - pr_match_rule true pr_pat prtac r) - lrul) - | TacMatchContext (lz,lr,lrul) -> - hov 0 (pr_lazy lz ++ - str (if lr then "Match Reverse Context With" else "Match Context With") - ++ prlist - (fun r -> fnl () ++ str "|" ++ spc () ++ - pr_match_rule false pr_pat prtac r) - lrul) - | TacFun (lvar,body) -> - hov 0 (str "Fun" ++ - prlist pr_funvar lvar ++ spc () ++ str "->" ++ spc () ++ prtac body) - - | TacArg c -> pr_tacarg c - -and pr_tacarg0 = function - | TacDynamic (_,t) -> str ("<dynamic ["^(Dyn.tag t)^"]>") - | MetaIdArg (_,s) -> str ("$" ^ s) - | IntroPattern ipat -> pr_intro_pattern ipat - | TacVoid -> str "()" - | Reference r -> pr_ref r - | ConstrMayEval (ConstrTerm c) -> str "'" ++ pr_constr c - | ConstrMayEval c -> pr_may_eval pr_constr pr_cst c - | Integer n -> int n - | TacFreshId sopt -> str "FreshId" ++ pr_opt qstring sopt - | TacExternal _ -> failwith "Not supported in v7 syntax" - | (TacCall _ | Tacexp _) as t -> str "(" ++ pr_tacarg1 t ++ str ")" - -and pr_tacarg1 = function - | TacCall (_,f,l) -> - hov 0 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg0 l) - | Tacexp t -> pr_tac_level (6,E) t - | t -> pr_tacarg0 t - -and pr_tacarg x = pr_tacarg1 x - -and prtac x = pr6 x - -and prtac_level (n,p) = - let n = match p with E -> n | L -> n-1 | Prec n -> n | Any -> 6 in - match n with - | 0 -> pr0 - | 1 -> pr1 - | 2 -> pr2 - | 3 -> pr3 - | 4 -> pr4 - | 5 -> pr5 - | 6 -> pr6 - | _ -> anomaly "Unknown tactic level" - -in (prtac_level,pr_match_rule false pr_pat (pr_tac_level (6,E))) - let pr_raw_extend prc prlc prtac = pr_extend_gen (pr_raw_generic prc prlc prtac Ppconstrnew.pr_reference) let pr_glob_extend prc prlc prtac = pr_extend_gen (pr_glob_generic prc prlc prtac) let pr_extend prc prlc prtac = pr_extend_gen (pr_generic prc prlc prtac) - -let pr_and_constr_expr pr (c,_) = pr c - -let rec glob_printers = - (pr_glob_tactic_level, - pr_and_constr_expr Printer.pr_rawterm, - Printer.pr_pattern, - pr_or_var (pr_and_short_name pr_evaluable_reference), - pr_or_var pr_inductive, - pr_or_var (pr_located pr_ltac_constant), - pr_located pr_id, - pr_glob_extend) - -and pr_glob_tactic_level n (t:glob_tactic_expr) = - fst (make_pr_tac glob_printers) n t - -and pr_glob_match_context t = - snd (make_pr_tac glob_printers) t - -let (pr_tactic_level,_) = - make_pr_tac - (pr_glob_tactic_level, - Printer.prterm, - Printer.pr_pattern, - pr_evaluable_reference, - pr_inductive, - pr_ltac_constant, - pr_id, - pr_extend) - -let pr_glob_tactic = pr_glob_tactic_level (6,E) -let pr_tactic = pr_tactic_level (6,E) diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index bd42a1ffe..fa835fff1 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -20,7 +20,6 @@ open Ppextend val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds -val pr_located : ('a -> std_ppcmds) -> 'a Util.located -> std_ppcmds type 'a raw_extra_genarg_printer = (constr_expr -> std_ppcmds) -> @@ -42,7 +41,6 @@ type 'a extra_genarg_printer = (* if the boolean is false then the extension applies only to old syntax *) val declare_extra_genarg_pprule : - bool -> ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> ('b closed_abstract_argument_type * 'b extra_genarg_printer) -> unit @@ -50,26 +48,11 @@ val declare_extra_genarg_pprule : type grammar_terminals = string option list (* if the boolean is false then the extension applies only to old syntax *) -val declare_extra_tactic_pprule : bool -> string -> - argument_type list * (int * grammar_terminals) -> unit +val declare_extra_tactic_pprule : + string * argument_type list * (int * grammar_terminals) -> unit val exists_extra_tactic_pprule : string -> argument_type list -> bool -val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds - -val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> - ('a,'b) match_rule -> std_ppcmds - -val pr_glob_tactic : glob_tactic_expr -> std_ppcmds - -val pr_tactic : Proof_type.tactic_expr -> std_ppcmds - -val pr_glob_generic: - (rawconstr_and_expr -> std_ppcmds) -> - (rawconstr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - glob_generic_argument -> std_ppcmds - val pr_raw_generic : (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 5092601fb..76c87f2c8 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -58,8 +58,7 @@ let print_impl_args_by_name = function str" are implicit" ++ fnl() let print_impl_args l = - if !Options.v7 then print_impl_args_by_pos (positions_of_implicits l) - else print_impl_args_by_name (List.filter is_status_implicit l) + print_impl_args_by_name (List.filter is_status_implicit l) (*********************) (** Printing Scopes *) @@ -183,8 +182,7 @@ let pr_located_qualid = function | VarRef _ -> "Variable" in str ref_str ++ spc () ++ pr_sp (Nametab.sp_of_global ref) | Syntactic kn -> - str (if !Options.v7 then "Syntactic Definition" else "Notation") ++ - spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn) + str "Notation" ++ spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn) | Dir dir -> let s,dir = match dir with | DirOpenModule (dir,_) -> "Open Module", dir @@ -269,13 +267,7 @@ let assumptions_for_print lna = (* *) let print_params env params = - if params = [] then - (mt ()) - else - if !Options.v7 then - (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2)) - else - (pr_rel_context env params ++ brk(1,2)) + if params = [] then mt () else pr_rel_context env params ++ brk(1,2) let print_constructors envpar names types = let pc = @@ -356,9 +348,8 @@ let print_inductive sp = (print_mutual sp) let print_syntactic_def sep kn = let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn in let c = Syntax_def.search_syntactic_definition dummy_loc kn in - (str (if !Options.v7 then "Syntactic Definition " else "Notation ") - ++ pr_qualid qid ++ str sep ++ - Constrextern.without_symbols pr_rawterm c ++ fnl ()) + str "Notation " ++ pr_qualid qid ++ str sep ++ + Constrextern.without_symbols pr_rawterm c ++ fnl () let print_leaf_entry with_values sep ((sp,kn as oname),lobj) = let tag = object_tag lobj in diff --git a/parsing/printer.ml b/parsing/printer.ml index 355bf6c94..a87415d95 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -18,11 +18,7 @@ open Sign open Environ open Global open Declare -open Coqast -open Ast -open Termast open Libnames -open Extend open Nametab open Ppconstr open Evd @@ -33,97 +29,25 @@ open Pfedit let emacs_str s = if !Options.print_emacs then s else "" (**********************************************************************) -(* Old Ast printing *) - -let constr_syntax_universe = "constr" -(* This is starting precedence for printing constructions or tactics *) -(* Level 9 means no parentheses except for applicative terms (at level 10) *) -let constr_initial_prec_v7 = Some (9,Ppextend.L) -let constr_initial_prec = Some (200,Ppextend.E) - -let dfltpr ast = (str"#GENTERM " ++ print_ast ast);; - -let global_const_name kn = - try pr_global Idset.empty (ConstRef kn) - with Not_found -> (* May happen in debug *) - (str ("CONST("^(string_of_con kn)^")")) - -let global_var_name id = - try pr_global Idset.empty (VarRef id) - with Not_found -> (* May happen in debug *) - (str ("SECVAR("^(string_of_id id)^")")) - -let global_ind_name (kn,tyi) = - try pr_global Idset.empty (IndRef (kn,tyi)) - with Not_found -> (* May happen in debug *) - (str ("IND("^(string_of_kn kn)^","^(string_of_int tyi)^")")) - -let global_constr_name ((kn,tyi),i) = - try pr_global Idset.empty (ConstructRef ((kn,tyi),i)) - with Not_found -> (* May happen in debug *) - (str ("CONSTRUCT("^(string_of_kn kn)^","^(string_of_int tyi) - ^","^(string_of_int i)^")")) - -let globpr gt = match gt with - | Nvar(_,s) -> (pr_id s) - | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev))) - | Node(_,"CONST",[ConPath(_,sl)]) -> - global_const_name sl - | Node(_,"SECVAR",[Nvar(_,s)]) -> - global_var_name s - | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> - global_ind_name (sl, tyi) - | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> - global_constr_name ((sl, tyi), i) - | Dynamic(_,d) -> - if (Dyn.tag d) = "constr" then (str"<dynamic [constr]>") - else dfltpr gt - | gt -> dfltpr gt - - -let wrap_exception = function - Anomaly (s1,s2) -> - warning ("Anomaly ("^s1^")"); pp s2; - str"<PP error: non-printable term>" - | Failure _ | UserError _ | Not_found -> - str"<PP error: non-printable term>" - | s -> raise s - -let gentermpr_fail gt = - let prec = - if !Options.v7 then constr_initial_prec_v7 else constr_initial_prec in - Esyntax.genprint globpr constr_syntax_universe prec gt - -let gentermpr gt = - try gentermpr_fail gt - with s -> wrap_exception s - -(**********************************************************************) (* Generic printing: choose old or new printers *) (* [at_top] means ids of env must be avoided in bound variables *) -let gentermpr_core at_top env t = - if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t) - else Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t) -let gentypepr_core at_top env t = - if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t) - else Ppconstrnew.pr_lconstr (Constrextern.extern_type at_top env t) +let prterm_core at_top env t = + Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t) +let prtype_core at_top env t = + Ppconstrnew.pr_lconstr (Constrextern.extern_type at_top env t) let pr_cases_pattern t = - if !Options.v7 then gentermpr (Termast.ast_of_cases_pattern t) - else Ppconstrnew.pr_cases_pattern - (Constrextern.extern_cases_pattern Idset.empty t) + Ppconstrnew.pr_cases_pattern (Constrextern.extern_cases_pattern Idset.empty t) let pr_pattern_env tenv env t = - if !Options.v7 then gentermpr (Termast.ast_of_pattern tenv env t) - else Ppconstrnew.pr_constr - (Constrextern.extern_pattern tenv env t) + Ppconstrnew.pr_constr (Constrextern.extern_pattern tenv env t) (**********************************************************************) (* Derived printers *) -let prterm_env_at_top env = gentermpr_core true env -let prterm_env env = gentermpr_core false env -let prtype_env_at_top env = gentypepr_core true env -let prtype_env env = gentypepr_core false env +let prterm_env_at_top env = prterm_core true env +let prterm_env env = prterm_core false env +let prtype_env_at_top env = prtype_core true env +let prtype_env env = prtype_core false env let prjudge_env env j = (prterm_env env j.uj_val, prterm_env env j.uj_type) @@ -134,13 +58,11 @@ let prjudge j = prjudge_env (Global.env()) j let _ = Termops.set_print_constr prterm_env -(*let _ = Tactic_debug.set_pattern_printer pr_pattern_env*) - let pr_constant env cst = prterm_env env (mkConst cst) let pr_existential env ev = prterm_env env (mkEvar ev) let pr_inductive env ind = prterm_env env (mkInd ind) let pr_constructor env cstr = prterm_env env (mkConstruct cstr) -let pr_global = pr_global Idset.empty +let pr_global = pr_global_env Idset.empty let pr_evaluable_reference ref = let ref' = match ref with | EvalConstRef const -> ConstRef const @@ -148,8 +70,7 @@ let pr_evaluable_reference ref = pr_global ref' let pr_rawterm t = - if !Options.v7 then gentermpr (Termast.ast_of_rawconstr t) - else Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t) + Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t) open Pattern @@ -197,16 +118,11 @@ let pr_named_context env ne_context = let pr_rel_context env rel_context = let rec prec env = function | [] -> (mt ()) - | [b] -> - if !Options.v7 then pr_rel_decl env b - else str "(" ++ pr_rel_decl env b ++ str")" + | [b] -> str "(" ++ pr_rel_decl env b ++ str")" | b::rest -> let pb = pr_rel_decl env b in let penvtl = prec (push_rel b env) rest in - if !Options.v7 then - (pb ++ str";" ++ spc () ++ penvtl) - else - (str "(" ++ pb ++ str")" ++ spc () ++ penvtl) + str "(" ++ pb ++ str")" ++ spc () ++ penvtl in hov 0 (prec env (List.rev rel_context)) @@ -367,74 +283,13 @@ let pr_nth_open_subgoal n = (* Elementary tactics *) -let pr_prim_rule_v7 = function - | Intro id -> - str"Intro " ++ pr_id id - - | Intro_replacing id -> - (str"intro replacing " ++ pr_id id) - - | Cut (b,id,t) -> - if b then - (str"Assert " ++ print_constr t) - else - (str"Cut " ++ print_constr t ++ str ";[Intro " ++ pr_id id ++ str "|Idtac]") - - | FixRule (f,n,[]) -> - (str"Fix " ++ pr_id f ++ str"/" ++ int n) - - | FixRule (f,n,others) -> - let rec print_mut = function - | (f,n,ar)::oth -> - pr_id f ++ str"/" ++ int n ++ str" : " ++ print_constr ar ++ print_mut oth - | [] -> mt () in - (str"Fix " ++ pr_id f ++ str"/" ++ int n ++ - str" with " ++ print_mut others) - - | Cofix (f,[]) -> - (str"Cofix " ++ pr_id f) - - | Cofix (f,others) -> - let rec print_mut = function - | (f,ar)::oth -> - (pr_id f ++ str" : " ++ print_constr ar ++ print_mut oth) - | [] -> mt () in - (str"Cofix " ++ pr_id f ++ str" with " ++ print_mut others) - - | Refine c -> - str(if occur_meta c then "Refine " else "Exact ") ++ - Constrextern.with_meta_as_hole print_constr c - - | Convert_concl (c,_) -> - (str"Change " ++ print_constr c) - - | Convert_hyp (id,None,t) -> - (str"Change " ++ print_constr t ++ spc () ++ str"in " ++ pr_id id) - - | Convert_hyp (id,Some c,t) -> - (str"Change " ++ print_constr c ++ spc () ++ str"in " - ++ pr_id id ++ str" (Type of " ++ pr_id id ++ str ")") - - | Thin ids -> - (str"Clear " ++ prlist_with_sep pr_spc pr_id ids) - - | ThinBody ids -> - (str"ClearBody " ++ prlist_with_sep pr_spc pr_id ids) - - | Move (withdep,id1,id2) -> - (str (if withdep then "Dependent " else "") ++ - str"Move " ++ pr_id id1 ++ str " after " ++ pr_id id2) - - | Rename (id1,id2) -> - (str "Rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) - let print_constr8 t = Ppconstrnew.pr_constr (Constrextern.extern_constr false (Global.env()) t) let print_lconstr8 t = Ppconstrnew.pr_lconstr (Constrextern.extern_constr false (Global.env()) t) -let pr_prim_rule_v8 = function +let pr_prim_rule = function | Intro id -> str"intro " ++ pr_id id @@ -494,6 +349,3 @@ let pr_prim_rule_v8 = function | Rename (id1,id2) -> (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2) - -let pr_prim_rule t = - if! Options.v7 then pr_prim_rule_v7 t else pr_prim_rule_v8 t diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 9a5e43feb..d28b36924 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -30,95 +30,6 @@ let anti loc x = in <:expr< $anti:e$ >> -(* [mlexpr_of_ast] contributes to translate g_*.ml4 files into g_*.ppo *) -(* This is where $id's (and macros) in ast are translated in ML variables *) -(* which will bind their actual ast value *) - -let rec mlexpr_of_ast = function - | Coqast.Nmeta (loc, id) -> anti loc id - | Coqast.Id (loc, id) when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >> - | Coqast.Node (_, "$VAR", [Coqast.Nmeta (loc, x)]) -> - <:expr< let s = $anti loc x$ in - if String.length s > 0 && String.sub s 0 1 = "$" then - failwith "Wrong ast: $VAR should not be bound to a meta variable" - else - Coqast.Nvar loc (Names.id_of_string s) >> - | Coqast.Node (_, "$PATH", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Path loc $anti loc x$ >> - | Coqast.Node (_, "$ID", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Id loc $anti loc x$ >> - | Coqast.Node (_, "$STR", [Coqast.Nmeta (loc, x)]) -> - <:expr< Coqast.Str loc $anti loc x$ >> -(* Obsolète - | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] -> - <:expr< - List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $mlexpr_of_ast y$ >> -*) - | Coqast.Node (loc, "$ABSTRACT", [Coqast.Str (_, s); x; y]) -> - let x = mlexpr_of_ast x in - let y = mlexpr_of_ast y in - <:expr< Ast.abstract_binders_ast loc $str:s$ $x$ $y$ >> - | Coqast.Node (loc, nn, al) -> - let e = expr_list_of_ast_list al in - <:expr< Coqast.Node loc $str:nn$ $e$ >> - | Coqast.Nvar (loc, id) -> - <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >> - | Coqast.Slam (loc, None, a) -> - <:expr< Coqast.Slam loc None $mlexpr_of_ast a$ >> - | Coqast.Smetalam (loc, s, a) -> - <:expr< - match $anti loc s$ with - [ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $mlexpr_of_ast a$ - | Coqast.Nmeta _ s -> Coqast.Smetalam loc s $mlexpr_of_ast a$ - | _ -> failwith "Slam expects a var or a metavar" ] >> - | Coqast.Slam (loc, Some s, a) -> - let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in - <:expr< Coqast.Slam loc (Some $se$) $mlexpr_of_ast a$ >> - | Coqast.Num (loc, i) -> <:expr< Coqast.Num loc $int:string_of_int i$ >> - | Coqast.Id (loc, id) -> <:expr< Coqast.Id loc $str:id$ >> - | Coqast.Str (loc, str) -> <:expr< Coqast.Str loc $str:str$ >> - | Coqast.Path (loc, kn) -> - let l,a = Libnames.decode_kn kn in - let mlexpr_of_modid id = - <:expr< Names.id_of_string $str:string_of_id id$ >> in - let e = List.map mlexpr_of_modid (repr_dirpath l) in - let e = expr_list_of_var_list e in - <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$) - (Names.id_of_string $str:Names.string_of_id a$)) >> - | Coqast.ConPath (loc, kn) -> - let l,a = Libnames.decode_con kn in - let mlexpr_of_modid id = - <:expr< Names.id_of_string $str:string_of_id id$ >> in - let e = List.map mlexpr_of_modid (repr_dirpath l) in - let e = expr_list_of_var_list e in - <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$) - (Names.id_of_string $str:Names.string_of_id a$)) >> - | Coqast.Dynamic (_, _) -> - failwith "Q_Coqast: dynamic: not implemented" - -and expr_list_of_ast_list al = - List.fold_right - (fun a e2 -> match a with - | (Coqast.Node (_, "$LIST", [Coqast.Nmeta (locv, pv)])) -> - let e1 = anti locv pv in - let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in - if e2 = (let loc = dummy_loc in <:expr< [] >>) - then <:expr< $e1$ >> - else <:expr< ( $lid:"@"$ $e1$ $e2$) >> - | _ -> - let e1 = mlexpr_of_ast a in - let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in - <:expr< [$e1$ :: $e2$] >> ) - al (let loc = dummy_loc in <:expr< [] >>) - -and expr_list_of_var_list sl = - let loc = dummy_loc in - List.fold_right - (fun e1 e2 -> - let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in - <:expr< [$e1$ :: $e2$] >>) - sl <:expr< [] >> - (* We don't give location for tactic quotation! *) let loc = dummy_loc @@ -173,12 +84,12 @@ let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident) let mlexpr_of_occs = mlexpr_of_list mlexpr_of_int let mlexpr_of_hyp_location = function - | id, occs, (Tacexpr.InHyp,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHyp, ref None)) >> - | id, occs, (Tacexpr.InHypTypeOnly,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypTypeOnly, ref None)) >> - | id, occs, (Tacexpr.InHypValueOnly,_) -> - <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypValueOnly,ref None)) >> + | id, occs, Tacexpr.InHyp -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHyp) >> + | id, occs, Tacexpr.InHypTypeOnly -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypTypeOnly) >> + | id, occs, Tacexpr.InHypValueOnly -> + <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, Tacexpr.InHypValueOnly) >> let mlexpr_of_clause cl = <:expr< {Tacexpr.onhyps= @@ -187,13 +98,6 @@ let mlexpr_of_clause cl = Tacexpr.onconcl= $mlexpr_of_bool cl.Tacexpr.onconcl$; Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >> -(* -let mlexpr_of_red_mode = function - | Closure.UNIFORM -> <:expr< Closure.UNIFORM >> - | Closure.SIMPL -> <:expr< Closure.SIMPL >> - | Closure.WITHBACK -> <:expr< Closure.WITHBACK >> -*) - let mlexpr_of_red_flags { Rawterm.rBeta = bb; Rawterm.rIota = bi; @@ -226,7 +130,6 @@ let rec mlexpr_of_constr = function | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> | Topconstr.CCases (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Topconstr.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >> | Topconstr.CNotation(_,ntn,l) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ @@ -268,9 +171,9 @@ let rec mlexpr_of_argtype loc = function | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> - | Genarg.HypArgType -> <:expr< Genarg.HypArgType >> + | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> - | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> + | Genarg.QuantVarArgType -> <:expr< Genarg.QuantVarArgType >> | Genarg.OpenConstrArgType b -> <:expr< Genarg.OpenConstrArgType $mlexpr_of_bool b$ >> | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> @@ -409,18 +312,18 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ >> (* Derived basic tactics *) - | Tacexpr.TacSimpleInduction (h,_) -> - <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$,ref []) >> + | Tacexpr.TacSimpleInduction h -> + <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$) >> | Tacexpr.TacNewInduction (c,cbo,ids) -> let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in - <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref [])>> + let ids = mlexpr_of_option mlexpr_of_intro_pattern ids in + <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ $ids$>> | Tacexpr.TacSimpleDestruct h -> <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacNewDestruct (c,cbo,ids) -> let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in - <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref []) >> + let ids = mlexpr_of_option mlexpr_of_intro_pattern ids in + <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ $ids$ >> (* Context management *) | Tacexpr.TacClear (b,l) -> @@ -551,14 +454,6 @@ and mlexpr_of_tactic_arg = function <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> | _ -> failwith "mlexpr_of_tactic_arg: TODO" -let f e = - let ee s = - mlexpr_of_ast (Pcoq.Gram.Entry.parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - let fconstr e = let ee s = mlexpr_of_constr (Pcoq.Gram.Entry.parse e @@ -578,6 +473,4 @@ let ftac e = let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); -(* Quotation.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*) -(* Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*) Quotation.default := "constr" diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index 991982211..16943d925 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -66,3 +66,39 @@ let mlexpr_of_string s = <:expr< $str:s$ >> let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> + +open Vernacexpr +open Pcoq +open Genarg + +let rec interp_entry_name loc s = + let l = String.length s in + if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in + List1ArgType t, <:expr< Gramext.Slist1 $g$ >> + else if l > 5 & String.sub s (l-5) 5 = "_list" then + let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in + List0ArgType t, <:expr< Gramext.Slist0 $g$ >> + else if l > 4 & String.sub s (l-4) 4 = "_opt" then + let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in + OptArgType t, <:expr< Gramext.Sopt $g$ >> + else + let s = if s = "hyp" then "var" else s in + let t, se = + match Pcoq.entry_type (Pcoq.get_univ "prim") s with + | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "constr") s with + | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | None -> + match Pcoq.entry_type (Pcoq.get_univ "tactic") s with + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> + | None -> None, <:expr< $lid:s$ >> in + let t = + match t with + | Some t -> t + | None -> +(* Pp.warning_with Pp_control.err_ft + ("Unknown primitive grammar entry: "^s);*) + ExtraArgType s + in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> diff --git a/parsing/q_util.mli b/parsing/q_util.mli index 8ed0f9d21..4418c6376 100644 --- a/parsing/q_util.mli +++ b/parsing/q_util.mli @@ -28,3 +28,4 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val interp_entry_name : Util.loc -> string -> Pcoq.entry_type * MLast.expr diff --git a/parsing/search.ml b/parsing/search.ml index 82829337a..42b5cef5c 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -17,7 +17,6 @@ open Rawterm open Declarations open Libobject open Declare -open Coqast open Environ open Pattern open Matching diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index a8e47aa9b..4601b0db4 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -120,34 +120,13 @@ let rec make_tags loc = function <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l -let make_one_printing_rule (pt,e) = +let make_one_printing_rule se (pt,e) = let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in let prods = mlexpr_of_list mlexpr_terminals_of_grammar_production pt in - <:expr< ($make_tags loc pt$, ($level$, $prods$)) >> + <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >> -let make_printing_rule = mlexpr_of_list make_one_printing_rule - -let new_tac_ext (s,cl) = - (String.lowercase s, List.map - (fun (l,e) -> - (List.map (function - | TacTerm s -> TacTerm (String.lowercase s) - | t -> t) l, - e)) - cl) - -let declare_tactic_v7 loc s cl = - let pp = make_printing_rule cl in - let gl = mlexpr_of_clause cl in - let se = mlexpr_of_string s in - <:str_item< - declare - open Pcoq; - Egrammar.extend_tactic_grammar $se$ $gl$; - List.iter (Pptactic.declare_extra_tactic_pprule False $se$) $pp$; - end - >> +let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se) let rec contains_epsilon = function | List0ArgType _ -> true @@ -165,81 +144,41 @@ let is_atomic = function | _ -> [] let declare_tactic loc s cl = - let (s',cl') = new_tac_ext (s,cl) in - let pp' = make_printing_rule cl' in - let gl' = mlexpr_of_clause cl' in - let se' = mlexpr_of_string s' in - let pp = make_printing_rule cl in + let se = mlexpr_of_string s in + let pp = make_printing_rule se cl in let gl = mlexpr_of_clause cl in let hide_tac (p,e) = (* reste a definir les fonctions cachees avec des noms frais *) - let stac = "h_"^s' in + let stac = "h_"^s in let e = make_fun <:expr< - Refiner.abstract_extended_tactic $mlexpr_of_string s'$ $make_args p$ $make_eval_tactic e p$ + Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ >> p in <:str_item< value $lid:stac$ = $e$ >> in - let hidden = if List.length cl = 1 then List.map hide_tac cl' else [] in + let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in let atomic_tactics = mlexpr_of_list mlexpr_of_string - (List.flatten (List.map (fun (al,_) -> is_atomic al) cl')) in + (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in <:str_item< declare open Pcoq; declare $list:hidden$ end; try - let _=Refiner.add_tactic $se'$ (fun [ $list:make_clauses s' cl'$ ]) in + let _=Refiner.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in List.iter (fun s -> Tacinterp.add_primitive_tactic s (Tacexpr.TacAtom($default_loc$, Tacexpr.TacExtend($default_loc$,s,[])))) $atomic_tactics$ with e -> Pp.pp (Cerrors.explain_exn e); - if Options.v7.val then Egrammar.extend_tactic_grammar $se'$ $gl$ - else Egrammar.extend_tactic_grammar $se'$ $gl'$; - List.iter (Pptactic.declare_extra_tactic_pprule True $se'$) $pp'$; - List.iter (Pptactic.declare_extra_tactic_pprule False $se'$) $pp$; + Egrammar.extend_tactic_grammar $se$ $gl$; + List.iter Pptactic.declare_extra_tactic_pprule $pp$; end >> -open Vernacexpr -open Pcoq - -let rec interp_entry_name loc s = - let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in - List1ArgType t, <:expr< Gramext.Slist1 $g$ >> - else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in - List0ArgType t, <:expr< Gramext.Slist0 $g$ >> - else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in - OptArgType t, <:expr< Gramext.Sopt $g$ >> - else - - let t, se = - match Pcoq.entry_type (Pcoq.get_univ "prim") s with - | Some _ as x -> x, <:expr< Prim. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "constr") s with - | Some _ as x -> x, <:expr< Constr. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "tactic") s with - | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> - | None -> None, <:expr< $lid:s$ >> in - let t = - match t with - | Some t -> t - | None -> -(* Pp.warning_with Pp_control.err_ft - ("Unknown primitive grammar entry: "^s);*) - ExtraArgType s - in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> - open Pcaml EXTEND @@ -248,11 +187,7 @@ EXTEND [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; OPT "|"; l = LIST1 tacrule SEP "|"; "END" -> - declare_tactic loc s l - | "V7"; "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ]; - OPT "|"; l = LIST1 tacrule SEP "|"; - "END" -> - declare_tactic_v7 loc s l ] ] + declare_tactic loc s l ] ] ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" @@ -265,7 +200,7 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name loc e in + let t, g = Q_util.interp_entry_name loc e in TacNonTerm (loc, t, g, Some s) | s = STRING -> if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal"); diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml index 6b5b35dd2..32a673cdc 100644 --- a/parsing/tactic_printer.ml +++ b/parsing/tactic_printer.ml @@ -20,15 +20,10 @@ open Printer let pr_tactic = function | TacArg (Tacexp t) -> - if !Options.v7 then - Pptactic.pr_glob_tactic t (*top tactic from tacinterp*) - else - Pptacticnew.pr_glob_tactic (Global.env()) t + (*top tactic from tacinterp*) + Pptacticnew.pr_glob_tactic (Global.env()) t | t -> - if !Options.v7 then - Pptactic.pr_tactic t - else - Pptacticnew.pr_tactic (Global.env()) t + Pptacticnew.pr_tactic (Global.env()) t let pr_rule = function | Prim r -> hov 0 (pr_prim_rule r) diff --git a/parsing/termast.ml b/parsing/termast.ml deleted file mode 100644 index 3d191d4a9..000000000 --- a/parsing/termast.ml +++ /dev/null @@ -1,551 +0,0 @@ -(************************************************************************) -(* 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$ *) - -open Pp -open Util -open Univ -open Names -open Nameops -open Term -open Termops -open Inductive -open Sign -open Environ -open Libnames -open Declare -open Impargs -open Coqast -open Ast -open Rawterm -open Pattern -open Nametab -open Mod_subst - -(* In this file, we translate rawconstr to ast, in order to print constr *) - -(**********************************************************************) -(* Parametrization *) -open Constrextern -(* -(* This governs printing of local context of references *) -let print_arguments = ref false - -(* If true, prints local context of evars, whatever print_arguments *) -let print_evar_arguments = ref false -*) - -(* This forces printing of cast nodes *) -let print_casts = ref true - -(* -(* This governs printing of implicit arguments. When - [print_implicits] is on then [print_implicits_explicit_args] tells - how implicit args are printed. If on, implicit args are printed - prefixed by "!" otherwise the function and not the arguments is - prefixed by "!" *) -let print_implicits = ref false -*) -let print_implicits_explicit_args = ref false - -(* -(* This forces printing of coercions *) -let print_coercions = ref false - -(* This forces printing universe names of Type{.} *) -let print_universes = ref false - - -let with_option o f x = - let old = !o in o:=true; - try let r = f x in o := old; r - with e -> o := old; raise e - -let with_arguments f = with_option print_arguments f -let with_casts f = with_option print_casts f -let with_implicits f = with_option print_implicits f -let with_coercions f = with_option print_coercions f -let with_universes f = with_option print_universes f -*) -(**********************************************************************) -(* conversion of references *) - -let ids_of_ctxt ctxt = - Array.to_list - (Array.map - (function c -> match kind_of_term c with - | Var id -> id - | _ -> - error - "Termast: arbitrary substitution of references not yet implemented") - ctxt) - -let ast_of_ident id = nvar id - -let ast_of_name = function - | Name id -> nvar id - | Anonymous -> nvar wildcard - -let idopt_of_name = function - | Name id -> Some id - | Anonymous -> None - -let ast_of_binders bl = - List.map (fun (nal,isdef,ty) -> - if isdef then ope("LETBINDER",ty::List.map ast_of_name nal) - else ope("BINDER",ty::List.map ast_of_name nal)) bl - -let ast_type_of_binder bl t = - List.fold_right (fun (nal,isdef,ty) ast -> - if isdef then - ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) - else - ope("PROD",[ty;List.fold_right - (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) - bl t - -let ast_body_of_binder bl t = - List.fold_right (fun (nal,isdef,ty) ast -> - if isdef then - ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)]) - else - ope("LAMBDA",[ty;List.fold_right - (fun na ast -> slam(idopt_of_name na,ast)) nal ast])) - bl t - -let ast_of_constant_ref sp = - ope("CONST", [conpath_section dummy_loc sp]) - -let ast_of_existential_ref ev = -(* - let ev = - try int_of_string (string_of_id ev) - with _ -> warning "cannot find existential variable number"; 0 in -*) - ope("EVAR", [num ev]) - -let ast_of_constructor_ref ((sp,tyi),n) = - ope("MUTCONSTRUCT",[path_section dummy_loc sp; num tyi; num n]) - -let ast_of_inductive_ref (sp,tyi) = - ope("MUTIND", [path_section dummy_loc sp; num tyi]) - -let ast_of_section_variable_ref s = - ope("SECVAR", [nvar s]) - -let ast_of_qualid p = - let dir, s = repr_qualid p in - let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in - ope ("QUALID", args) - -let ast_of_ref = function - | ConstRef sp -> ast_of_constant_ref sp - | IndRef sp -> ast_of_inductive_ref sp - | ConstructRef sp -> ast_of_constructor_ref sp - | VarRef id -> ast_of_section_variable_ref id - -(**********************************************************************) -(* conversion of patterns *) - -let rec ast_of_cases_pattern = function (* loc is thrown away for printing *) - | PatVar (loc,Name id) -> nvar id - | PatVar (loc,Anonymous) -> nvar wildcard - | PatCstr(loc,cstrsp,args,Name id) -> - let args = List.map ast_of_cases_pattern args in - ope("PATTAS", - [nvar id; - ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)]) - | PatCstr(loc,cstrsp,args,Anonymous) -> - ope("PATTCONSTRUCT", - (ast_of_constructor_ref cstrsp) - :: List.map ast_of_cases_pattern args) - -let ast_dependent na aty = - match na with - | Name id -> occur_var_ast id aty - | Anonymous -> false - -let decompose_binder = function - | RProd(_,na,ty,c) -> Some (BProd,na,ty,c) - | RLambda(_,na,ty,c) -> Some (BLambda,na,ty,c) - | RLetIn(_,na,b,c) -> Some (BLetIn,na,b,c) - | _ -> None - -(* Implicit args indexes are in ascending order *) -let explicitize impl args = - let n = List.length args in - let rec exprec q = function - | a::args, imp::impl when is_status_implicit imp -> - let tail = exprec (q+1) (args,impl) in - let visible = - (!print_implicits & !print_implicits_explicit_args) - or not (is_inferable_implicit false n imp) in - if visible then ope("EXPL", [num q; a]) :: tail else tail - | a::args, _::impl -> a :: exprec (q+1) (args,impl) - | args, [] -> args (* In case of polymorphism *) - | [], _ -> [] - in exprec 1 (args,impl) - -let rec skip_coercion dest_ref (f,args as app) = - if !print_coercions then app - else - try - match dest_ref f with - | Some r -> - (match Classops.hide_coercion r with - | Some n -> - if n >= List.length args then app - else (* We skip a coercion *) - let fargs = list_skipn n args in - skip_coercion dest_ref (List.hd fargs,List.tl fargs) - | None -> app) - | None -> app - with Not_found -> app - -let ast_of_app impl f args = - if !print_implicits & not !print_implicits_explicit_args then - ope("APPLISTEXPL", f::args) - else - let args = explicitize impl args in - if args = [] then f else ope("APPLIST", f::args) - -let rec ast_of_raw = function - | RRef (_,ref) -> ast_of_ref ref - | RVar (_,id) -> ast_of_ident id - | REvar (_,n,_) -> (* we drop args *) ast_of_existential_ref n - | RPatVar (_,(_,n)) -> ope("META",[ast_of_ident n]) - | RApp (_,f,args) -> - let (f,args) = - skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in - let astf = ast_of_raw f in - let astargs = List.map ast_of_raw args in - (match f with - | RRef (_,ref) -> ast_of_app (implicits_of_global ref) astf astargs - | _ -> ast_of_app [] astf astargs) - - | RProd (_,Anonymous,t,c) -> - (* Anonymous product are never factorized *) - ope("ARROW",[ast_of_raw t; slam(None,ast_of_raw c)]) - - | RLetIn (_,na,t,c) -> - ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)]) - - | RProd (_,na,t,c) -> - let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in - (* PROD et PRODLIST doivent être distingués à cause du cas *) - (* non dépendant, pour isoler l'implication; peut-être un *) - (* constructeur ARROW serait-il plus justifié ? *) - let tag = if n=1 then "PROD" else "PRODLIST" in - ope(tag,[ast_of_raw t;a]) - - | RLambda (_,na,t,c) -> - let (n,a) = factorize_binder 1 BLambda na (ast_of_raw t) c in - (* LAMBDA et LAMBDALIST se comportent pareil ... Non ! *) - (* Pour compatibilité des theories, il faut LAMBDALIST partout *) - ope("LAMBDALIST",[ast_of_raw t;a]) - - | RCases (_,(typopt,_),tml,eqns) -> - let pred = ast_of_rawopt typopt in - let tag = "CASES" in - let asttomatch = - ope("TOMATCH", List.map (fun (tm,_) -> ast_of_raw tm) tml) in - let asteqns = List.map ast_of_eqn eqns in - ope(tag,pred::asttomatch::asteqns) - - | ROrderedCase (_,LetStyle,typopt,tm,[|bv|],_) -> - let nvar' = function Anonymous -> nvar wildcard | Name id -> nvar id in - let rec f l = function - | RLambda (_,na,RHole _,c) -> f (nvar' na :: l) c - | c -> List.rev l, ast_of_raw c in - let l,c = f [] bv in - let eqn = ope ("EQN", [c;ope ("PATTCONSTRUCT",(nvar wildcard)::l)]) in - ope ("FORCELET",[(ast_of_rawopt typopt);(ast_of_raw tm);eqn]) - - | ROrderedCase (_,st,typopt,tm,bv,_) -> - let tag = match st with - | IfStyle -> "FORCEIF" - | RegularStyle -> "CASE" - | MatchStyle | LetStyle -> "MATCH" - in - - (* warning "Old Case syntax"; *) - ope(tag,(ast_of_rawopt typopt) - ::(ast_of_raw tm) - ::(Array.to_list (Array.map ast_of_raw bv))) - - | RLetTuple _ | RIf _ -> - anomaly "Let tuple and If not supported in v7" - - | RRec (_,fk,idv,blv,tyv,bv) -> - let alfi = Array.map ast_of_ident idv in - (match fk with - | RFix (nv,n) -> - let rec split_lambda binds = function - | (0, t) -> (List.rev binds,ast_of_raw t) - | (n, RLetIn (_,na,b,c)) -> - let bind = ope("LETBINDER",[ast_of_raw b;ast_of_name na]) in - split_lambda (bind::binds) (n,c) - | (n, RLambda (_,na,t,b)) -> - let bind = ope("BINDER",[ast_of_raw t;ast_of_name na]) in - split_lambda (bind::binds) (n-1,b) - | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint body" in - let rec split_product = function - | (0, t) -> ast_of_raw t - | (n, RLetIn (_,na,_,c)) -> split_product (n,c) - | (n, RProd (_,na,t,b)) -> split_product (n-1,b) - | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint type" in - let listdecl = - Array.mapi - (fun i fi -> - if List.length blv.(i) >= nv.(i)+1 then - let (oldfixp,factb) = list_chop (nv.(i)+1) blv.(i) in - let bl = factorize_local_binder oldfixp in - let factb = factorize_local_binder factb in - let asttyp = ast_type_of_binder factb - (ast_of_raw tyv.(i)) in - let astdef = ast_body_of_binder factb - (ast_of_raw bv.(i)) in - ope("FDECL",[fi;ope("BINDERS",ast_of_binders bl); - asttyp; astdef]) - else - let n = nv.(i)+1 - List.length blv.(i) in - let (lparams,astdef) = - split_lambda [] (n,bv.(i)) in - let bl = factorize_local_binder blv.(i) in - let lparams = ast_of_binders bl @ lparams in - let asttyp = split_product (n,tyv.(i)) in - ope("FDECL", - [fi; ope ("BINDERS",lparams); - asttyp; astdef])) - alfi - in - ope("FIX", alfi.(n)::(Array.to_list listdecl)) - | RCoFix n -> - let listdecl = - Array.mapi - (fun i fi -> - let bl = factorize_local_binder blv.(i) in - let asttyp = ast_type_of_binder bl (ast_of_raw tyv.(i)) in - let astdef = ast_body_of_binder bl (ast_of_raw bv.(i)) in - ope("CFDECL",[fi; asttyp; astdef])) - alfi - in - ope("COFIX", alfi.(n)::(Array.to_list listdecl))) - - | RSort (_,s) -> - (match s with - | RProp Null -> ope("PROP",[]) - | RProp Pos -> ope("SET",[]) - | RType _ -> ope("TYPE",[])) - | RHole _ -> ope("ISEVAR",[]) - | RCast (_,c,_,t) -> ope("CAST",[ast_of_raw c;ast_of_raw t]) - | RDynamic (loc,d) -> Dynamic (loc,d) - -and ast_of_eqn (_,ids,pl,c) = - ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl)) - -and ast_of_rawopt = function - | None -> (string "SYNTH") - | Some p -> ast_of_raw p - -and factorize_binder n oper na aty c = - let (p,body) = match decompose_binder c with - | Some (oper',na',ty',c') - when (oper = oper') & (aty = ast_of_raw ty') - & not (ast_dependent na aty) (* To avoid na in ty' escapes scope *) - & not (na' = Anonymous & oper = BProd) - -> factorize_binder (n+1) oper na' aty c' - | _ -> (n,ast_of_raw c) - in - (p,slam(idopt_of_name na, body)) - -and factorize_local_binder = function - [] -> [] - | (na,Some bd,ty)::l -> - ([na],true,ast_of_raw bd) :: factorize_local_binder l - | (na,None,ty)::l -> - let ty = ast_of_raw ty in - (match factorize_local_binder l with - (lna,false,ty') :: l when ty=ty' -> - (na::lna,false,ty') :: l - | l -> ([na],false,ty) :: l) - - -let ast_of_rawconstr = ast_of_raw - -(******************************************************************) -(* Main translation function from constr -> ast *) - -let ast_of_constr at_top env t = - let t' = - if !print_casts then t - else Reductionops.local_strong strip_outer_cast t in - let avoid = if at_top then ids_of_context env else [] in - ast_of_raw - (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t') - -(**********************************************************************) -(* Object substitution in modules *) - -let rec subst_ast subst ast = match ast with - | Node (l,s,astl) -> - let astl' = Util.list_smartmap (subst_ast subst) astl in - if astl' == astl then ast else - Node (l,s,astl') - | Slam (l,ido,ast1) -> - let ast1' = subst_ast subst ast1 in - if ast1' == ast1 then ast else - Slam (l,ido,ast1') - | Smetalam (l,s,ast1) -> - let ast1' = subst_ast subst ast1 in - if ast1' == ast1 then ast else - Smetalam (l,s,ast1') - | Path (loc,kn) -> - let kn' = subst_kn subst kn in - if kn' == kn then ast else - Path(loc,kn') - | ConPath (loc,kn) -> - let kn',t = subst_con subst kn in - if kn' == kn then ast else - ast_of_constr false (Global.env ()) t - | Nmeta _ - | Nvar _ -> ast - | Num _ - | Str _ - | Id _ - | Dynamic _ -> ast - -let rec subst_astpat subst = function -(*CSC: this is wrong since I am not recompiling the whole pattern. - However, this is V7-syntax code that is doomed to disappear. Hence I - prefer to be lazy and to not fix the bug. *) - | Pquote a -> Pquote (subst_ast subst a) - | Pmeta _ as p -> p - | Pnode (s,pl) -> Pnode (s,subst_astpatlist subst pl) - | Pslam (ido,p) -> Pslam (ido,subst_astpat subst p) - | Pmeta_slam (s,p) -> Pmeta_slam (s,subst_astpat subst p) - -and subst_astpatlist subst = function - | Pcons (p,pl) -> Pcons (subst_astpat subst p, subst_astpatlist subst pl) - | (Plmeta _ | Pnil) as pl -> pl - -let subst_pat subst = function - | AstListPat pl -> AstListPat (subst_astpatlist subst pl) - | PureAstPat p -> PureAstPat (subst_astpat subst p) - -let ast_of_constant env sp = - let a = ast_of_constant_ref sp in - a - -let ast_of_existential env (ev,ids) = - let a = ast_of_existential_ref ev in - if !print_arguments or !print_evar_arguments then - ope("INSTANCE",a::(array_map_to_list (ast_of_constr false env) ids)) - else a - -let ast_of_constructor env cstr_sp = - let a = ast_of_constructor_ref cstr_sp in - a - -let ast_of_inductive env ind_sp = - let a = ast_of_inductive_ref ind_sp in - a - -let decompose_binder_pattern = function - | PProd(na,ty,c) -> Some (BProd,na,ty,c) - | PLambda(na,ty,c) -> Some (BLambda,na,ty,c) - | PLetIn(na,b,c) -> Some (BLetIn,na,b,c) - | _ -> None - -let rec ast_of_pattern tenv env = function - | PRef ref -> ast_of_ref ref - - | PVar id -> ast_of_ident id - - | PEvar (n,_) -> ast_of_existential_ref n - - | PRel n -> - (try match lookup_name_of_rel n env with - | Name id -> ast_of_ident id - | Anonymous -> - anomaly "ast_of_pattern: index to an anonymous variable" - with Not_found -> - nvar (id_of_string ("[REL "^(string_of_int n)^"]"))) - - | PApp (f,args) -> - let (f,args) = - skip_coercion (function PRef r -> Some r | _ -> None) - (f,Array.to_list args) in - let astf = ast_of_pattern tenv env f in - let astargs = List.map (ast_of_pattern tenv env) args in - (match f with - | PRef ref -> ast_of_app (implicits_of_global ref) astf astargs - | _ -> ast_of_app [] astf astargs) - - | PSoApp (n,args) -> - ope("SOAPP",(ope ("META",[ast_of_ident n])):: - (List.map (ast_of_pattern tenv env) args)) - - | PLetIn (na,b,c) -> - let c' = ast_of_pattern tenv (add_name na env) c in - ope("LETIN",[ast_of_pattern tenv env b;slam(idopt_of_name na,c')]) - - | PProd (Anonymous,t,c) -> - ope("PROD",[ast_of_pattern tenv env t; - slam(None,ast_of_pattern tenv env c)]) - | PProd (na,t,c) -> - let env' = add_name na env in - let (n,a) = - factorize_binder_pattern tenv env' 1 BProd na - (ast_of_pattern tenv env t) c in - (* PROD et PRODLIST doivent être distingués à cause du cas *) - (* non dépendant, pour isoler l'implication; peut-être un *) - (* constructeur ARROW serait-il plus justifié ? *) - let tag = if n=1 then "PROD" else "PRODLIST" in - ope(tag,[ast_of_pattern tenv env t;a]) - | PLambda (na,t,c) -> - let env' = add_name na env in - let (n,a) = - factorize_binder_pattern tenv env' 1 BLambda na - (ast_of_pattern tenv env t) c in - (* LAMBDA et LAMBDALIST se comportent pareil *) - let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in - ope(tag,[ast_of_pattern tenv env t;a]) - - | PCase (st,typopt,tm,bv) -> - warning "Old Case syntax"; - ope("MUTCASE",(ast_of_patopt tenv env typopt) - ::(ast_of_pattern tenv env tm) - ::(Array.to_list (Array.map (ast_of_pattern tenv env) bv))) - - | PSort s -> - (match s with - | RProp Null -> ope("PROP",[]) - | RProp Pos -> ope("SET",[]) - | RType _ -> ope("TYPE",[])) - - | PMeta (Some n) -> ope("META",[ast_of_ident n]) - | PMeta None -> ope("ISEVAR",[]) - | PFix f -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkFix f)) - | PCoFix c -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkCoFix c)) - -and ast_of_patopt tenv env = function - | None -> (string "SYNTH") - | Some p -> ast_of_pattern tenv env p - -and factorize_binder_pattern tenv env n oper na aty c = - let (p,body) = match decompose_binder_pattern c with - | Some (oper',na',ty',c') - when (oper = oper') & (aty = ast_of_pattern tenv env ty') - & not (na' = Anonymous & oper = BProd) - -> - factorize_binder_pattern tenv (add_name na' env) (n+1) oper na' aty c' - | _ -> (n,ast_of_pattern tenv env c) - in - (p,slam(idopt_of_name na, body)) diff --git a/parsing/termast.mli b/parsing/termast.mli deleted file mode 100644 index da7e476be..000000000 --- a/parsing/termast.mli +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $Id$ i*) - -(*i*) -open Names -open Term -open Termops -open Sign -open Environ -open Libnames -open Nametab -open Rawterm -open Pattern -open Mod_subst -(*i*) - -(* Translation of pattern, cases pattern, rawterm and term into syntax - trees for printing *) - -val ast_of_cases_pattern : cases_pattern -> Coqast.t -val ast_of_rawconstr : rawconstr -> Coqast.t -val ast_of_pattern : env -> names_context -> constr_pattern -> Coqast.t - -(* If [b=true] in [ast_of_constr b env c] then the variables in the first - level of quantification clashing with the variables in [env] are renamed *) - -val ast_of_constr : bool -> env -> constr -> Coqast.t - -(* Object substitution in modules *) -val subst_ast: substitution -> Coqast.t -> Coqast.t -val subst_astpat : substitution -> Ast.astpat -> Ast.astpat - -val ast_of_constant : env -> constant -> Coqast.t -val ast_of_existential : env -> existential -> Coqast.t -val ast_of_constructor : env -> constructor -> Coqast.t -val ast_of_inductive : env -> inductive -> Coqast.t -val ast_of_ref : global_reference -> Coqast.t -val ast_of_qualid : qualid -> Coqast.t - -(*i Now in constrextern.mli -val print_implicits : bool ref -val print_casts : bool ref -val print_arguments : bool ref -val print_evar_arguments : bool ref -val print_coercions : bool ref -val print_universes : bool ref - -val with_casts : ('a -> 'b) -> 'a -> 'b -val with_implicits : ('a -> 'b) -> 'a -> 'b -val with_arguments : ('a -> 'b) -> 'a -> 'b -val with_coercions : ('a -> 'b) -> 'a -> 'b -val with_universes : ('a -> 'b) -> 'a -> 'b -i*) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 6e2f5fe3a..b478e37d9 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -11,7 +11,6 @@ open Genarg open Q_util open Q_coqast -open Ast open Argextend let join_loc (deb1,_) (_,fin2) = (deb1,fin2) @@ -96,40 +95,6 @@ let declare_command loc s cl = end >> -open Vernacexpr -open Pcoq - -let rec interp_entry_name loc s = - let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in - List1ArgType t, <:expr< Gramext.Slist1 $g$ >> - else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in - List0ArgType t, <:expr< Gramext.Slist0 $g$ >> - else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in - OptArgType t, <:expr< Gramext.Sopt $g$ >> - else - let t, se = - match Pcoq.entry_type (Pcoq.get_univ "prim") s with - | Some _ as x -> x, <:expr< Prim. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "constr") s with - | Some _ as x -> x, <:expr< Constr. $lid:s$ >> - | None -> - match Pcoq.entry_type (Pcoq.get_univ "tactic") s with - | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> - | None -> None, <:expr< $lid:s$ >> in - let t = - match t with - | Some t -> t - | None -> -(* Pp.warning_with Pp_control.err_ft - ("Unknown primitive grammar entry: "^s);*) - ExtraArgType s - in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> - open Pcaml EXTEND @@ -149,7 +114,7 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name loc e in + let t, g = Q_util.interp_entry_name loc e in VernacNonTerm (loc, t, g, Some s) | s = STRING -> VernacTerm s diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 28e8c4139..d9f7324cf 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1641,7 +1641,7 @@ let build_initial_predicate isdep allnames pred = in buildrec 0 pred allnames let extract_arity_signature env0 tomatchl tmsign = - let get_one_sign n tm {contents = (na,t)} = + let get_one_sign n tm (na,t) = match tm with | NotInd (bo,typ) -> (match t with @@ -1684,34 +1684,23 @@ let extract_arity_signature env0 tomatchl tmsign = * type and 1 assumption for each term not _syntactically_ in an * inductive type. - * V7 case: determines whether the multiple case is dependent or not - * - if its arity is made of nrealargs assumptions for each matched - * term in an inductive type and nothing for terms not _syntactically_ - * in an inductive type, then it is non dependent - * - if its arity is made of 1+nrealargs assumptions for each matched - * term in an inductive type and nothing for terms not _syntactically_ - * in an inductive type, then it is dependent and needs an adjustement - * to fulfill the criterion above that terms not in an inductive type - * counts for 1 in the dependent case + * Each matched terms are independently considered dependent or not. - * V8 case: each matched terms are independently considered dependent - * or not - - * A type constraint but no annotation case: it is assumed non dependent + * A type constraint but no annotation case: it is assumed non dependent. *) let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function - (* No type annotation at all *) - | (None,{contents = None}) -> + (* No type annotation *) + | None -> (match tycon with | None -> None | Some t -> - let names,pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in + let names,pred = + prepare_predicate_from_tycon loc false env isevars tomatchs t in Some (build_initial_predicate false names pred)) - (* v8 style type annotation *) - | (None,{contents = Some rtntyp}) -> - + (* Some type annotation *) + | Some rtntyp -> (* We extract the signature of the arity *) let arsign = extract_arity_signature env tomatchs sign in let env = List.fold_right push_rels arsign env in @@ -1719,39 +1708,6 @@ let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in Some (build_initial_predicate true allnames predccl) - (* v7 style type annotation; set the v8 annotation by side effect *) - | (Some pred,x) -> - let loc = loc_of_rawconstr pred in - let dep, n, predj = - let isevars_copy = !isevars in - (* We first assume the predicate is non dependent *) - let ndep_arity = build_expected_arity env isevars false tomatchs in - try - false, nb_prod ndep_arity, typing_fun (mk_tycon ndep_arity) env pred - with PretypeError _ | TypeError _ | - Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) -> - (* Backtrack! *) - isevars := isevars_copy; - (* We then assume the predicate is dependent *) - let dep_arity = build_expected_arity env isevars true tomatchs in - try - true, nb_prod dep_arity, typing_fun (mk_tycon dep_arity) env pred - with PretypeError _ | TypeError _ | - Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) -> - (* Backtrack again! *) - isevars := isevars_copy; - (* Otherwise we attempt to type it without constraints, possibly *) - (* failing with an error message; it may also be well-typed *) - (* but fails to satisfy arity constraints in case_dependent *) - let predj = typing_fun empty_tycon env pred in - error_wrong_predicate_arity_loc - loc env predj.uj_val ndep_arity dep_arity - in - let ln,predccl= extract_predicate_conclusion dep tomatchs predj.uj_val in - set_arity_signature dep n sign tomatchs pred x; - Some (build_initial_predicate dep ln predccl) - - (**************************************************************************) (* Main entry of the matching compilation *) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index de63ea525..7da7abcce 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -53,7 +53,7 @@ val compile_cases : evar_defs ref -> type_constraint -> env -> - (rawconstr option * rawconstr option ref) * - (rawconstr * (name * (loc * inductive * name list) option) ref) list * + rawconstr option * + (rawconstr * (name * (loc * inductive * name list) option)) list * (loc * identifier list * cases_pattern list * rawconstr) list -> unsafe_judgment diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 6d49baf52..62c721b8b 100755 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -210,8 +210,8 @@ let inductive_class_of ind = fst (class_info (CL_IND ind)) let class_args_of c = snd (decompose_app c) let string_of_class = function - | CL_FUN -> if !Options.v7 then "FUNCLASS" else "Funclass" - | CL_SORT -> if !Options.v7 then "SORTCLASS" else "Sortclass" + | CL_FUN -> "Funclass" + | CL_SORT -> "Sortclass" | CL_CONST sp -> string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp)) | CL_IND sp -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 19c5ca54b..b955d62d7 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -223,14 +223,13 @@ let detype_case computable detype detype_eqn testdep List.rev (fst (decompose_prod_assum t)) in let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in let consnargsl = Array.map List.length consnargs in - let alias, aliastyp, newpred, pred = + let alias, aliastyp, pred= if (not !Options.raw_print) & synth_type & computable & Array.length bl<>0 then - Anonymous, None, None, None + Anonymous, None, None else - let p = option_app detype p in - match p with - | None -> Anonymous, None, None, None + match option_app detype p with + | None -> Anonymous, None, None | Some p -> let decompose_lam k c = let rec lamdec_rec l avoid k c = @@ -255,7 +254,7 @@ let detype_case computable detype detype_eqn testdep else let pars = list_tabulate (fun _ -> Anonymous) mib.mind_nparams in Some (dummy_loc,indsp,pars@nl) in - n, aliastyp, Some typ, Some p + n, aliastyp, Some typ in let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in let eqnv = array_map3 detype_eqn constructs consnargsl bl in @@ -273,10 +272,10 @@ let detype_case computable detype detype_eqn testdep with Not_found -> st in if tag = RegularStyle then - RCases (dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl) + RCases (dummy_loc,pred,[tomatch,(alias,aliastyp)],eqnl) else let bl' = Array.map detype bl in - if not !Options.v7 && tag = LetStyle && aliastyp = None then + if tag = LetStyle && aliastyp = None then let rec decomp_lam_force n avoid l p = if n = 0 then (List.rev l,p) else match p with @@ -293,37 +292,16 @@ let detype_case computable detype detype_eqn testdep | RApp (loc,p,l) -> RApp (loc,p,l@[a]) | _ -> (RApp (dummy_loc,p,[a]))) in let (nal,d) = decomp_lam_force consnargsl.(0) avoid [] bl'.(0) in - RLetTuple (dummy_loc,nal,(alias,newpred),tomatch,d) + RLetTuple (dummy_loc,nal,(alias,pred),tomatch,d) else let nondepbrs = array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in - if not !Options.v7 && tag = IfStyle && aliastyp = None + if tag = IfStyle && aliastyp = None && array_for_all ((<>) None) nondepbrs then - RIf (dummy_loc,tomatch,(alias,newpred), + RIf (dummy_loc,tomatch,(alias,pred), out_some nondepbrs.(0),out_some nondepbrs.(1)) - else if !Options.v7 then - let rec remove_type avoid args c = - match c,args with - | RLambda (loc,na,t,c), _::args -> - let h = RHole (dummy_loc,BinderType na) in - RLambda (loc,na,h,remove_type avoid args c) - | RLetIn (loc,na,b,c), _::args -> - RLetIn (loc,na,b,remove_type avoid args c) - | c, (na,None,t)::args -> - let id = next_name_away_with_default "x" na avoid in - let h = RHole (dummy_loc,BinderType na) in - let c = remove_type (id::avoid) args - (RApp (dummy_loc,c,[RVar (dummy_loc,id)])) in - RLambda (dummy_loc,Name id,h,c) - | c, (na,Some b,t)::args -> - let h = RHole (dummy_loc,BinderType na) in - let avoid = name_fold (fun x l -> x::l) na avoid in - RLetIn (dummy_loc,na,h,remove_type avoid args c) - | c, [] -> c in - let bl' = array_map2 (remove_type avoid) consnargs bl' in - ROrderedCase (dummy_loc,tag,pred,tomatch,bl',ref None) - else - RCases(dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl) + else + RCases(dummy_loc,pred,[tomatch,(alias,aliastyp)],eqnl) let rec detype tenv avoid env t = @@ -405,11 +383,6 @@ and detype_cofix tenv avoid env n (names,tys,bodies) = Array.map (fun (_,bd,_) -> bd) v) and share_names tenv n l avoid env c t = - if !Options.v7 && n=0 then - let c = detype tenv avoid env c in - let t = detype tenv avoid env t in - (List.rev l,c,t) - else match kind_of_term c, kind_of_term t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> @@ -535,17 +508,16 @@ let rec subst_raw subst raw = if r1' == r1 && r2' == r2 then raw else RLetIn (loc,n,r1',r2') - | RCases (loc,(ro,rtno),rl,branches) -> - let ro' = option_smartmap (subst_raw subst) ro - and rtno' = ref (option_smartmap (subst_raw subst) !rtno) + | RCases (loc,rtno,rl,branches) -> + let rtno' = option_smartmap (subst_raw subst) rtno and rl' = list_smartmap (fun (a,x as y) -> let a' = subst_raw subst a in - let (n,topt) = !x in + let (n,topt) = x in let topt' = option_smartmap (fun (loc,(sp,i),x as t) -> let sp' = subst_kn subst sp in if sp == sp' then t else (loc,(sp',i),x)) topt in - if a == a' && topt == topt' then y else (a',ref (n,topt'))) rl + if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = list_smartmap (fun (loc,idl,cpl,r as branch) -> let cpl' = list_smartmap (subst_pat subst) cpl @@ -554,15 +526,8 @@ let rec subst_raw subst raw = (loc,idl,cpl',r')) branches in - if ro' == ro && rl' == rl && branches' == branches then raw else - RCases (loc,(ro',rtno'),rl',branches') - - | ROrderedCase (loc,b,ro,r,ra,x) -> - let ro' = option_smartmap (subst_raw subst) ro - and r' = subst_raw subst r - and ra' = array_smartmap (subst_raw subst) ra in - if ro' == ro && r' == r && ra' == ra then raw else - ROrderedCase (loc,b,ro',r',ra',x) + if rtno' == rtno && rl' == rl && branches' == branches then raw else + RCases (loc,rtno',rl',branches') | RLetTuple (loc,nal,(na,po),b,c) -> let po' = option_smartmap (subst_raw subst) po diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index df9139db1..634f0b591 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -22,14 +22,8 @@ open Mod_subst (* Metavariables *) type patvar_map = (patvar * constr) list -let patvar_of_int n = - let p = if !Options.v7 & not (Options.do_translate ()) then "?" else "X" - in - Names.id_of_string (p ^ string_of_int n) let pr_patvar = pr_id -let patvar_of_int_v7 n = Names.id_of_string ("?" ^ string_of_int n) - (* Patterns *) type constr_pattern = @@ -217,26 +211,21 @@ let rec pat_of_raw metas vars = function Options.if_verbose Pp.warning "Cast not taken into account in constr pattern"; pat_of_raw metas vars c - | ROrderedCase (_,st,po,c,br,_) -> - PCase ((None,st),option_app (pat_of_raw metas vars) po, - pat_of_raw metas vars c, - Array.map (pat_of_raw metas vars) br) | RIf (_,c,(_,None),b1,b2) -> PCase ((None,IfStyle),None, pat_of_raw metas vars c, [|pat_of_raw metas vars b1; pat_of_raw metas vars b2|]) - | RCases (loc,(po,_),[c,_],brs) -> + | RCases (loc,None,[c,_],brs) -> let sp = match brs with | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind | _ -> None in - (* When po disappears: switch to rtn type *) - PCase ((sp,Term.RegularStyle),option_app (pat_of_raw metas vars) po, + PCase ((sp,Term.RegularStyle),None, pat_of_raw metas vars c, Array.init (List.length brs) (pat_of_raw_branch loc metas vars sp brs)) | r -> let loc = loc_of_rawconstr r in - user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern") + user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Pattern not supported") and pat_of_raw_branch loc metas vars ind brs i = let bri = List.filter diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 7ce0c4124..0815f8721 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -25,10 +25,6 @@ open Mod_subst type patvar_map = (patvar * constr) list val pr_patvar : patvar -> std_ppcmds -(* Only for v7 parsing/printing *) -val patvar_of_int : int -> patvar -val patvar_of_int_v7 : int -> patvar - (* Patterns *) type constr_pattern = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 0baaa9819..193d0a161 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -462,201 +462,6 @@ let rec pretype tycon env isevars lvar = function in { uj_val = v; uj_type = ccl }) - (* Special Case for let constructions to avoid exponential behavior *) - | ROrderedCase (loc,st,po,c,[|f|],xx) when st <> MatchStyle -> - let cj = pretype empty_tycon env isevars lvar c in - let (IndType (indf,realargs) as indt) = - try find_rectype env (evars_of !isevars) cj.uj_type - with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env (evars_of !isevars) cj - in - let j = match po with - | Some p -> - let pj = pretype empty_tycon env isevars lvar p in - let dep = is_dependent_elimination env pj.uj_type indf in - let ar = - arity_of_case_predicate env indf dep (Type (new_univ())) in - let _ = e_cumul env isevars pj.uj_type ar in - let pj = j_nf_evar (evars_of !isevars) pj in - let pj = if dep then pj else make_dep_of_undep env indt pj in - let (bty,rsty) = - Indrec.type_rec_branches - false env (evars_of !isevars) indt pj.uj_val cj.uj_val - in - if Array.length bty <> 1 then - error_number_branches_loc - loc env (evars_of !isevars) cj (Array.length bty); - let fj = - let tyc = bty.(0) in - pretype (mk_tycon tyc) env isevars lvar f - in - let fv = j_val fj in - let ft = fj.uj_type in - check_branches_message loc env isevars cj.uj_val (bty,[|ft|]); - let v = - let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env st mis in - mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|]) - in - { uj_val = v; uj_type = rsty } - - | None -> - (* get type information from type of branches *) - let expbr = Cases.branch_scheme env isevars false indf in - if Array.length expbr <> 1 then - error_number_branches_loc loc env (evars_of !isevars) - cj (Array.length expbr); - let expti = expbr.(0) in - let fj = pretype (mk_tycon expti) env isevars lvar f in - let use_constraint () = - (* get type information from constraint *) - (* warning: if the constraint comes from an evar type, it *) - (* may be Type while Prop or Set would be expected *) - match tycon with - | Some pred -> - let arsgn = make_arity_signature env true indf in - let pred = lift (List.length arsgn) pred in - let pred = - it_mkLambda_or_LetIn (nf_evar (evars_of !isevars) pred) - arsgn in - false, pred - | None -> - let sigma = evars_of !isevars in - error_cant_find_case_type_loc loc env sigma cj.uj_val - in - let ok, p = - try - let pred = - Cases.pred_case_ml - env (evars_of !isevars) false indt (0,fj.uj_type) - in - if is_ground_term !isevars pred then - true, pred - else - use_constraint () - with Cases.NotInferable _ -> - use_constraint () - in - let p = nf_evar (evars_of !isevars) p in - let (bty,rsty) = - Indrec.type_rec_branches - false env (evars_of !isevars) indt p cj.uj_val - in - let _ = option_app (e_cumul env isevars rsty) tycon in - let fj = - if ok then fj - else pretype (mk_tycon bty.(0)) env isevars lvar f - in - let fv = fj.uj_val in - let v = - let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env st mis in - mkCase (ci, (nf_betaiota p), cj.uj_val,[|fv|] ) - in - { uj_val = v; uj_type = rsty } in - - (* Build the LetTuple form for v8 *) - let c = - let (ind,params) = dest_ind_family indf in - let rtntypopt, indnalopt = match po with - | None -> None, (Anonymous,None) - | Some p -> - let pj = pretype empty_tycon env isevars lvar p in - let dep = is_dependent_elimination env pj.uj_type indf in - let rec decomp_lam_force n avoid l p = - (* avoid is not exhaustive ! *) - if n = 0 then (List.rev l,p,avoid) else - match p with - | RLambda (_,(Name id as na),_,c) -> - decomp_lam_force (n-1) (id::avoid) (na::l) c - | RLambda (_,(Anonymous as na),_,c) -> - decomp_lam_force (n-1) avoid (na::l) c - | _ -> - let x = Nameops.next_ident_away (id_of_string "x") avoid in - decomp_lam_force (n-1) (x::avoid) (Name x :: l) - (* eta-expansion *) - (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in - let (nal,p,avoid) = - decomp_lam_force (List.length realargs) [] [] p in - let na,rtntyp,_ = - if dep then decomp_lam_force 1 avoid [] p - else [Anonymous],p,[] in - let intyp = - if List.for_all - (function - | Anonymous -> true - | Name id -> not (occur_rawconstr id rtntyp)) nal - then (* No dependency in realargs *) - None - else - let args = List.map (fun _ -> Anonymous) params @ nal in - Some (dummy_loc,ind,args) in - (Some rtntyp,(List.hd na,intyp)) in - let cs = (get_constructors env indf).(0) in - match indnalopt with - | (na,None) -> (* Represented as a let *) - let rec decomp_lam_force n avoid l p = - if n = 0 then (List.rev l,p) else - match p with - | RLambda (_,(Name id as na),_,c) -> - decomp_lam_force (n-1) (id::avoid) (na::l) c - | RLambda (_,(Anonymous as na),_,c) -> - decomp_lam_force (n-1) avoid (na::l) c - | _ -> - let x = Nameops.next_ident_away (id_of_string "x") avoid in - decomp_lam_force (n-1) (x::avoid) (Name x :: l) - (* eta-expansion *) - (let a = RVar (dummy_loc,x) in - match p with - | RApp (loc,p,l) -> RApp (loc,p,l@[a]) - | _ -> (RApp (dummy_loc,p,[a]))) in - let (nal,d) = decomp_lam_force cs.cs_nargs [] [] f in - RLetTuple (loc,nal,(na,rtntypopt),c,d) - | _ -> (* Represented as a match *) - let detype_eqn constr construct_nargs branch = - let name_cons = function - | Anonymous -> fun l -> l - | Name id -> fun l -> id::l in - let make_pat na avoid b ids = - PatVar (dummy_loc,na), - name_cons na avoid,name_cons na ids - in - let rec buildrec ids patlist avoid n b = - if n=0 then - (dummy_loc, ids, - [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], - b) - else - match b with - | RLambda (_,x,_,b) -> - let pat,new_avoid,new_ids = make_pat x avoid b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) b - - | RLetIn (_,x,_,b) -> - let pat,new_avoid,new_ids = make_pat x avoid b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) b - - | RCast (_,c,_,_) -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid n c - - | _ -> (* eta-expansion *) - (* nommage de la nouvelle variable *) - let id = Nameops.next_ident_away (id_of_string "x") avoid in - let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in - let pat,new_avoid,new_ids = - make_pat (Name id) avoid new_b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) new_b - - in - buildrec [] [] [] construct_nargs branch in - let eqn = detype_eqn (ind,1) cs.cs_nargs f in - RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],[eqn]) - in - xx := Some c; - (* End building the v8 syntax *) - j - | RIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env isevars lvar c in let (IndType (indf,realargs)) = @@ -707,200 +512,6 @@ let rec pretype tycon env isevars lvar = function in { uj_val = v; uj_type = p } - | ROrderedCase (loc,st,po,c,lf,x) -> - let isrec = (st = MatchStyle) in - let cj = pretype empty_tycon env isevars lvar c in - let (IndType (indf,realargs) as indt) = - try find_rectype env (evars_of !isevars) cj.uj_type - with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env (evars_of !isevars) cj in - let (dep,pj) = match po with - | Some p -> - let pj = pretype empty_tycon env isevars lvar p in - let dep = is_dependent_elimination env pj.uj_type indf in - let ar = - arity_of_case_predicate env indf dep (Type (new_univ())) in - let _ = e_cumul env isevars pj.uj_type ar in - (dep, pj) - | None -> - (* get type information from type of branches *) - let expbr = Cases.branch_scheme env isevars isrec indf in - let rec findtype i = - if i >= Array.length lf - then - (* get type information from constraint *) - (* warning: if the constraint comes from an evar type, it *) - (* may be Type while Prop or Set would be expected *) - match tycon with - | Some pred -> - let arsgn = make_arity_signature env true indf in - let pred = lift (List.length arsgn) pred in - let pred = - it_mkLambda_or_LetIn (nf_evar (evars_of !isevars) pred) - arsgn in - (true, - Retyping.get_judgment_of env (evars_of !isevars) pred) - | None -> - let sigma = evars_of !isevars in - error_cant_find_case_type_loc loc env sigma cj.uj_val - else - try - let expti = expbr.(i) in - let fj = - pretype (mk_tycon expti) env isevars lvar lf.(i) in - let pred = - Cases.pred_case_ml (* eta-expanse *) - env (evars_of !isevars) isrec indt (i,fj.uj_type) in - if not (is_ground_term !isevars pred) then findtype (i+1) - else - let pty = - Retyping.get_type_of env (evars_of !isevars) pred in - let pj = { uj_val = pred; uj_type = pty } in -(* - let _ = option_app (the_conv_x_leq env isevars pred) tycon - in -*) - (true,pj) - with Cases.NotInferable _ -> findtype (i+1) in - findtype 0 - in - let pj = j_nf_evar (evars_of !isevars) pj in - let pj = if dep then pj else make_dep_of_undep env indt pj in - let (bty,rsty) = - Indrec.type_rec_branches - isrec env (evars_of !isevars) indt pj.uj_val cj.uj_val in - let _ = option_app (e_cumul env isevars rsty) tycon in - if Array.length bty <> Array.length lf then - error_number_branches_loc loc env (evars_of !isevars) - cj (Array.length bty) - else - let lfj = - array_map2 - (fun tyc f -> pretype (mk_tycon tyc) env isevars lvar f) bty - lf in - let lfv = Array.map j_val lfj in - let lft = Array.map (fun j -> j.uj_type) lfj in - check_branches_message loc env isevars cj.uj_val (bty,lft); - let v = - if isrec - then - transform_rec loc env (evars_of !isevars)(pj,cj.uj_val,lfv) indt - else - let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env st mis in - mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, - Array.map (fun j-> j.uj_val) lfj) - in - (* Build the Cases form for v8 *) - let c = - let (ind,params) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let recargs = mip.mind_recargs in - let tyi = snd ind in - if isrec && mis_is_recursive_subset [tyi] recargs then - Some (Detyping.detype (false,env) - (ids_of_context env) (names_of_rel_context env) - (nf_evar (evars_of !isevars) v)) - else - (* Translate into a "match ... with" *) - let rtntypopt, indnalopt = match po with - | None -> None, (Anonymous,None) - | Some p -> - let rec decomp_lam_force n avoid l p = - (* avoid is not exhaustive ! *) - if n = 0 then (List.rev l,p,avoid) else - match p with - | RLambda (_,(Name id as na),_,c) -> - decomp_lam_force (n-1) (id::avoid) (na::l) c - | RLambda (_,(Anonymous as na),_,c) -> - decomp_lam_force (n-1) avoid (na::l) c - | _ -> - let x = Nameops.next_ident_away (id_of_string "x") avoid in - decomp_lam_force (n-1) (x::avoid) (Name x :: l) - (* eta-expansion *) - (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in - let (nal,p,avoid) = - decomp_lam_force (List.length realargs) [] [] p in - let na,rtntyopt,_ = - if dep then decomp_lam_force 1 avoid [] p - else [Anonymous],p,[] in - let intyp = - if nal=[] then None else - let args = List.map (fun _ -> Anonymous) params @ nal in - Some (dummy_loc,ind,args) in - (Some rtntyopt,(List.hd na,intyp)) in - let rawbranches = - array_map3 (fun bj b cstr -> - let rec strip n r = if n=0 then r else - match r with - | RLambda (_,_,_,t) -> strip (n-1) t - | RLetIn (_,_,_,t) -> strip (n-1) t - | _ -> assert false in - let n = rel_context_length cstr.cs_args in - try - let _,ccl = decompose_lam_n_assum n bj.uj_val in - if noccur_between 1 n ccl then Some (strip n b) else None - with _ -> (* Not eta-expanded or not reduced *) None) - lfj lf (get_constructors env indf) in - if st = IfStyle & snd indnalopt = None - & rawbranches.(0) <> None && rawbranches.(1) <> None then - (* Translate into a "if ... then ... else" *) - (* TODO: translate into a "if" even if po is dependent *) - Some (RIf (loc,c,(fst indnalopt,rtntypopt), - out_some rawbranches.(0),out_some rawbranches.(1))) - else - let detype_eqn constr construct_nargs branch = - let name_cons = function - | Anonymous -> fun l -> l - | Name id -> fun l -> id::l in - let make_pat na avoid b ids = - PatVar (dummy_loc,na), - name_cons na avoid,name_cons na ids - in - let rec buildrec ids patlist avoid n b = - if n=0 then - (dummy_loc, ids, - [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], - b) - else - match b with - | RLambda (_,x,_,b) -> - let pat,new_avoid,new_ids = make_pat x avoid b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) b - - | RLetIn (_,x,_,b) -> - let pat,new_avoid,new_ids = make_pat x avoid b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) b - - | RCast (_,c,_,_) -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid n c - - | _ -> (* eta-expansion *) - (* nommage de la nouvelle variable *) - let id = Nameops.next_ident_away (id_of_string "x") avoid in - let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in - let pat,new_avoid,new_ids = - make_pat (Name id) avoid new_b ids in - buildrec new_ids (pat::patlist) new_avoid (n-1) new_b - - in - buildrec [] [] [] construct_nargs branch in - let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in - let get_consnarg j = - let typi = mis_nf_constructor_type (ind,mib,mip) (j+1) in - let _,t = decompose_prod_n_assum mib.mind_nparams typi in - List.rev (fst (decompose_prod_assum t)) in - let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in - let consnargsl = Array.map List.length consnargs in - let constructs = Array.init (Array.length lf) (fun i -> (ind,i+1)) in - let eqns = array_map3 detype_eqn constructs consnargsl lf in - Some (RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],Array.to_list eqns)) in - x := c; - (* End build the Cases form for v8 *) - { uj_val = v; - uj_type = rsty } - | RCases (loc,po,tml,eqns) -> Cases.compile_cases loc ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index dde8490d0..a75f6165f 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -58,11 +58,9 @@ type rawconstr = | RLambda of loc * name * rawconstr * rawconstr | RProd of loc * name * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr - | RCases of loc * (rawconstr option * rawconstr option ref) * - (rawconstr * (name * (loc * inductive * name list) option) ref) list * + | RCases of loc * rawconstr option * + (rawconstr * (name * (loc * inductive * name list) option)) list * (loc * identifier list * cases_pattern list * rawconstr) list - | ROrderedCase of loc * case_style * rawconstr option * rawconstr * - rawconstr array * rawconstr option ref | RLetTuple of loc * name list * (name * rawconstr option) * rawconstr * rawconstr | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr @@ -77,8 +75,8 @@ and rawdecl = name * rawconstr option * rawconstr let cases_predicate_names tml = List.flatten (List.map (function - | (tm,{contents=(na,None)}) -> [na] - | (tm,{contents=(na,Some (_,_,nal))}) -> na::nal) tml) + | (tm,(na,None)) -> [na] + | (tm,(na,Some (_,_,nal))) -> na::nal) tml) (*i - if PRec (_, names, arities, bodies) is in env then arities are typed in env too and bodies are typed in env enriched by the @@ -97,12 +95,10 @@ let map_rawconstr f = function | RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c) | RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c) | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c) - | RCases (loc,(tyopt,rtntypopt),tml,pl) -> - RCases (loc,(option_app f tyopt,ref (option_app f !rtntypopt)), + | RCases (loc,rtntypopt,tml,pl) -> + RCases (loc,option_app f rtntypopt, List.map (fun (tm,x) -> (f tm,x)) tml, List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl) - | ROrderedCase (loc,b,tyopt,tm,bv,x) -> - ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv,ref (option_app f !x)) | RLetTuple (loc,nal,(na,po),b,c) -> RLetTuple (loc,nal,(na,option_app f po),f b,f c) | RIf (loc,c,(na,po),b1,b2) -> @@ -140,8 +136,6 @@ let map_rawconstr_with_binders_loc loc g f e = function let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in RCases (loc,option_app (f e) tyopt,List.map (f e) tml, List.map h pl) - | ROrderedCase (_,b,tyopt,tm,bv) -> - ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv) | RRec (_,fk,idl,tyl,bv) -> let idl',e' = fold_ident g idl e in RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv) @@ -161,12 +155,10 @@ let occur_rawconstr id = | RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c)) - | RCases (loc,(tyopt,rtntypopt),tml,pl) -> - (occur_option tyopt) or (occur_option !rtntypopt) + | RCases (loc,rtntypopt,tml,pl) -> + (occur_option rtntypopt) or (List.exists (fun (tm,_) -> occur tm) tml) or (List.exists occur_pattern pl) - | ROrderedCase (loc,b,tyopt,tm,bv,_) -> - (occur_option tyopt) or (occur tm) or (array_exists occur bv) | RLetTuple (loc,nal,rtntyp,b,c) -> occur_return_type rtntyp id or (occur b) or (not (List.mem (Name id) nal) & (occur c)) @@ -205,7 +197,6 @@ let loc_of_rawconstr = function | RProd (loc,_,_,_) -> loc | RLetIn (loc,_,_,_) -> loc | RCases (loc,_,_,_) -> loc - | ROrderedCase (loc,_,_,_,_,_) -> loc | RLetTuple (loc,_,_,_,_) -> loc | RIf (loc,_,_,_,_) -> loc | RRec (loc,_,_,_,_,_) -> loc diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index 4e4df6b39..014739fcb 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -55,11 +55,9 @@ type rawconstr = | RLambda of loc * name * rawconstr * rawconstr | RProd of loc * name * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr - | RCases of loc * (rawconstr option * rawconstr option ref) * - (rawconstr * (name * (loc * inductive * name list) option) ref) list * + | RCases of loc * rawconstr option * + (rawconstr * (name * (loc * inductive * name list) option)) list * (loc * identifier list * cases_pattern list * rawconstr) list - | ROrderedCase of loc * case_style * rawconstr option * rawconstr * - rawconstr array * rawconstr option ref | RLetTuple of loc * name list * (name * rawconstr option) * rawconstr * rawconstr | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr @@ -73,8 +71,7 @@ type rawconstr = and rawdecl = name * rawconstr option * rawconstr val cases_predicate_names : - (rawconstr * (name * (loc * inductive * name list) option) ref) list -> - name list + (rawconstr * (name * (loc * inductive * name list) option)) list -> name list (*i - if PRec (_, names, arities, bodies) is in env then arities are typed in env too and bodies are typed in env enriched by the diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index 3eccf3d34..b8de1e789 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -56,8 +56,7 @@ type hyp_location_flag = (* To distinguish body and type of local defs *) | InHypTypeOnly | InHypValueOnly -type 'a raw_hyp_location = - 'a * int list * (hyp_location_flag * hyp_location_flag option ref) +type 'a raw_hyp_location = 'a * int list * hyp_location_flag type 'a induction_arg = | ElimOnConstr of 'a @@ -132,12 +131,12 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = (* | TacInstantiate of int * 'constr * (('id * hyp_location_flag,unit) location) *) (* Derived basic tactics *) - | TacSimpleInduction of (quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref) + | TacSimpleInduction of quantified_hypothesis | TacNewInduction of 'constr induction_arg * 'constr with_bindings option - * (intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref) + * intro_pattern_expr option | TacSimpleDestruct of quantified_hypothesis | TacNewDestruct of 'constr induction_arg * 'constr with_bindings option - * (intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref) + * intro_pattern_expr option | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis | TacDecomposeAnd of 'constr diff --git a/tactics/auto.ml b/tactics/auto.ml index e6d1194a5..e8faf862f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -205,12 +205,8 @@ let make_apply_entry env sigma (eapply,verbose) name (c,cty) = in if eapply & (nmiss <> 0) then begin if verbose then - if !Options.v7 then - warn (str "the hint: EApply " ++ prterm c ++ - str " will only be used by EAuto") - else warn (str "the hint: eapply " ++ prterm c ++ - str " will only be used by eauto"); + str " will only be used by eauto"); (hd, { hname = name; pri = nb_hyp cty + nmiss; @@ -388,9 +384,6 @@ let add_unfolds l local dbnames = let add_extern name pri (patmetas,pat) tacast local dbname = (* We check that all metas that appear in tacast have at least one occurence in the left pattern pat *) -(* TODO - let tacmetas = Coqast.collect_metas tacast in -*) let tacmetas = [] in match (list_subtract tacmetas patmetas) with | i::_ -> @@ -482,16 +475,6 @@ let add_hints local dbnames0 h = (**************************************************************************) let fmt_autotactic = - if !Options.v7 then - function - | Res_pf (c,clenv) -> (str"Apply " ++ prterm c) - | ERes_pf (c,clenv) -> (str"EApply " ++ prterm c) - | Give_exact c -> (str"Exact " ++ prterm c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"Apply " ++ prterm c ++ str" ; Trivial") - | Unfold_nth c -> (str"Unfold " ++ pr_evaluable_reference c) - | Extern tac -> (str "Extern " ++ Pptactic.pr_glob_tactic tac) - else function | Res_pf (c,clenv) -> (str"apply " ++ prterm c) | ERes_pf (c,clenv) -> (str"eapply " ++ prterm c) @@ -700,10 +683,7 @@ let trivial dbnames gl = try searchtable_map x with Not_found -> - if !Options.v7 then - error ("Trivial: "^x^": No such Hint database") - else - error ("trivial: "^x^": No such Hint database")) + error ("trivial: "^x^": No such Hint database")) ("core"::dbnames) in tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl @@ -802,10 +782,7 @@ let auto n dbnames gl = try searchtable_map x with Not_found -> - if !Options.v7 then - error ("Auto: "^x^": No such Hint database") - else - error ("auto: "^x^": No such Hint database")) + error ("auto: "^x^": No such Hint database")) ("core"::dbnames) in let hyps = pf_hyps gl in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 6cf0cc981..9eed8ecd3 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -8,8 +8,6 @@ (* $Id$ *) -open Ast -open Coqast open Equality open Hipattern open Names @@ -51,7 +49,8 @@ let print_rewrite_hintdb bas = (fun (c,typ,d,t) -> str (if d then "rewrite -> " else "rewrite <- ") ++ Printer.prterm c ++ str " of type " ++ Printer.prterm typ ++ - str " then use tactic " ++ Pptactic.pr_glob_tactic t) hints) + str " then use tactic " ++ + Pptacticnew.pr_glob_tactic (Global.env()) t) hints) with Not_found -> errorlabstrm "AutoRewrite" diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 32a678410..cd8a59136 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -129,7 +129,6 @@ open Libobject open Library open Pattern open Matching -open Ast open Pcoq open Tacexpr open Libnames @@ -266,11 +265,10 @@ let match_dpat dp cls gls = | ({onhyps=lo;onconcl=false},HypLocation(_,hypd,concld)) -> let hl = match lo with Some l -> l - | None -> List.map (fun id -> (id,[],(InHyp,ref None))) - (pf_ids_of_hyps gls) in + | None -> List.map (fun id -> (id,[],InHyp)) (pf_ids_of_hyps gls) in if not (List.for_all - (fun (id,_,(hl,_)) -> + (fun (id,_,hl) -> let cltyp = pf_get_hyp_typ gls id in let cl = pf_concl gls in (hl=InHyp) & diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index e0cc336ca..232266e26 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -47,11 +47,8 @@ let e_resolve_with_bindings_tac (c,lbind) gl = let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls -(* V8 TACTIC EXTEND eexact +TACTIC EXTEND eexact | [ "eexact" constr(c) ] -> [ e_give_exact c ] -END*) -TACTIC EXTEND Eexact -| [ "EExact" constr(c) ] -> [ e_give_exact c ] END let e_give_exact_constr = h_eexact @@ -61,11 +58,8 @@ let registered_e_assumption gl = (pf_ids_of_hyps gl)) gl (* This automatically define h_eApply (among other things) *) -(*V8 TACTIC EXTEND eapply - [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] -END*) TACTIC EXTEND eapply - [ "EApply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] + [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] END let vernac_e_resolve_constr c = h_eapply (c,NoBindings) @@ -106,33 +100,30 @@ let e_right = e_constructor_tac (Some 2) 2 let e_split = e_constructor_tac (Some 1) 1 (* This automatically define h_econstructor (among other things) *) -(*V8 TACTIC EXTEND eapply - [ "econstructor" integer(n) with_bindings(c) ] -> [ e_constructor_tac None n c ] -END*) TACTIC EXTEND econstructor - [ "EConstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ] - | [ "EConstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ] - | [ "EConstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] + [ "econstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ] +| [ "econstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ] +| [ "econstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] END TACTIC EXTEND eleft - [ "ELeft" "with" bindings(l) ] -> [e_left l] - | [ "ELeft"] -> [e_left NoBindings] + [ "eleft" "with" bindings(l) ] -> [e_left l] +| [ "eleft"] -> [e_left NoBindings] END TACTIC EXTEND eright - [ "ERight" "with" bindings(l) ] -> [e_right l] - | [ "ERight" ] -> [e_right NoBindings] + [ "eright" "with" bindings(l) ] -> [e_right l] +| [ "eright" ] -> [e_right NoBindings] END TACTIC EXTEND esplit - [ "ESplit" "with" bindings(l) ] -> [e_split l] - | [ "ESplit"] -> [e_split NoBindings] + [ "esplit" "with" bindings(l) ] -> [e_split l] +| [ "esplit"] -> [e_split NoBindings] END TACTIC EXTEND eexists - [ "EExists" bindings(l) ] -> [e_split l] + [ "eexists" bindings(l) ] -> [e_split l] END @@ -161,29 +152,10 @@ let prolog_tac l n gl = with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed") -(* V8 TACTIC EXTEND prolog +TACTIC EXTEND prolog | [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] -END*) -TACTIC EXTEND Prolog -| [ "Prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ] END -(* -let vernac_prolog = - let uncom = function - | Constr c -> c - | _ -> assert false - in - let gentac = - hide_tactic "Prolog" - (function - | (Integer n) :: al -> prolog_tac (List.map uncom al) n - | _ -> assert false) - in - fun coms n -> - gentac ((Integer n) :: (List.map (fun com -> (Constr com)) coms)) -*) - open Auto (***************************************************************************) @@ -433,14 +405,7 @@ ARGUMENT EXTEND hintbases | [ ] -> [ Some [] ] END -TACTIC EXTEND EAuto -| [ "EAuto" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] -> +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] -> [ gen_eauto false (make_dimension n p) db ] END - -V7 TACTIC EXTEND EAutodebug -| [ "EAutod" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] -> - [ gen_eauto true (make_dimension n p) db ] -END - - diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 9d19d37e8..1ef4b928d 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -177,12 +177,12 @@ let compare c1 c2 g = (* User syntax *) -TACTIC EXTEND DecideEquality - [ "Decide" "Equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ] -| [ "Decide" "Equality" ] -> [ decideGralEquality ] +TACTIC EXTEND decide_equality + [ "decide" "equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ] +| [ "decide" "equality" ] -> [ decideGralEquality ] END -TACTIC EXTEND Compare -| [ "Compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] END diff --git a/tactics/equality.ml b/tactics/equality.ml index 23e4d311c..04667d306 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -125,7 +125,7 @@ let rewriteRL_clause = function (* Replacing tactics *) -(* eqt,sym_eqt : equality on Type and its symmetry theorem +(* eq,sym_eq : equality on Type and its symmetry theorem c2 c1 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible gl : goal *) @@ -134,8 +134,8 @@ let abstract_replace clause c2 c1 unsafe gl = let t1 = pf_type_of gl c1 and t2 = pf_type_of gl c2 in if unsafe or (pf_conv_x gl t1 t2) then - let e = (build_coq_eqT_data ()).eq in - let sym = (build_coq_eqT_data ()).sym in + let e = (build_coq_eq_data ()).eq in + let sym = (build_coq_eq_data ()).sym in let eq = applist (e, [t1;c1;c2]) in tclTHENS (assert_tac false Anonymous eq) [onLastHyp (fun id -> @@ -1030,8 +1030,7 @@ let unfold_body x gl = | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis") in let aft = afterHyp x gl in - let hl = List.fold_right - (fun (y,yval,_) cl -> (y,[],(InHyp,ref None)) :: cl) aft [] in + let hl = List.fold_right (fun (y,yval,_) cl -> (y,[],InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index a31bc2cf0..5ff27a8e9 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -50,7 +50,8 @@ END let pr_gen prc _prlc _prtac c = prc c -let pr_rawc _prc _prlc _prtac raw = Ppconstr.pr_rawconstr raw +let pr_rawc _prc _prlc _prtac raw = + Ppconstrnew.pr_constr (Constrextern.extern_rawconstr Idset.empty raw) let interp_raw _ _ (t,_) = t diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 3cc73e21d..fbd881789 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -15,127 +15,119 @@ open Pcoq open Genarg open Extraargs open Mod_subst +open Names (* Equality *) open Equality -TACTIC EXTEND Rewrite -| [ "Rewrite" orient(b) constr_with_bindings(c) ] -> +TACTIC EXTEND rewrite +| [ "rewrite" orient(b) constr_with_bindings(c) ] -> [general_rewrite_bindings b c] END -TACTIC EXTEND RewriteIn -| [ "Rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> +TACTIC EXTEND rewrite_in +| [ "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> [general_rewrite_bindings_in b h c] END let h_rewriteLR x = h_rewrite true (x,Rawterm.NoBindings) -TACTIC EXTEND Replace -| [ "Replace" constr(c1) "with" constr(c2) ] -> +TACTIC EXTEND replace +| [ "replace" constr(c1) "with" constr(c2) ] -> [ replace c1 c2 ] END -TACTIC EXTEND ReplaceIn -| [ "Replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> +TACTIC EXTEND replace_in +| [ "replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> [ replace_in h c1 c2 ] END -TACTIC EXTEND Replacetermleft - [ "Replace" "->" constr(c) ] -> [ replace_term_left c ] +TACTIC EXTEND replace_term_left + [ "replace" "->" constr(c) ] -> [ replace_term_left c ] END -TACTIC EXTEND Replacetermright - [ "Replace" "<-" constr(c) ] -> [ replace_term_right c ] +TACTIC EXTEND replace_term_right + [ "replace" "<-" constr(c) ] -> [ replace_term_right c ] END -TACTIC EXTEND Replaceterm - [ "Replace" constr(c) ] -> [ replace_term c ] +TACTIC EXTEND replace_term + [ "replace" constr(c) ] -> [ replace_term c ] END -TACTIC EXTEND ReplacetermInleft - [ "Replace" "->" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in_left + [ "replace" "->" constr(c) "in" hyp(h) ] -> [ replace_term_in_left c h ] END -TACTIC EXTEND ReplacetermInright - [ "Replace" "<-" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in_right + [ "replace" "<-" constr(c) "in" hyp(h) ] -> [ replace_term_in_right c h ] END -TACTIC EXTEND ReplacetermIn - [ "Replace" constr(c) "in" hyp(h) ] +TACTIC EXTEND replace_term_in + [ "replace" constr(c) "in" hyp(h) ] -> [ replace_term_in c h ] END -TACTIC EXTEND DEq - [ "Simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ] +TACTIC EXTEND simplify_eq + [ "simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ] END -TACTIC EXTEND Discriminate - [ "Discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ] +TACTIC EXTEND discriminate + [ "discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ] END let h_discrHyp id = h_discriminate (Some id) -TACTIC EXTEND Injection - [ "Injection" quantified_hypothesis_opt(h) ] -> [ injClause h ] +TACTIC EXTEND injection + [ "injection" quantified_hypothesis_opt(h) ] -> [ injClause h ] END let h_injHyp id = h_injection (Some id) -TACTIC EXTEND ConditionalRewrite -| [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) ] +TACTIC EXTEND conditional_rewrite +| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) ] -> [ conditional_rewrite b (snd tac) c ] -| [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) +| [ "conditional" tactic(tac) "rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] -> [ conditional_rewrite_in b h (snd tac) c ] END -TACTIC EXTEND DependentRewrite -| [ "Dependent" "Rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] -| [ "Dependent" "Rewrite" orient(b) constr(c) "in" hyp(id) ] +TACTIC EXTEND dependent_rewrite +| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] -> [ rewriteInHyp b c id ] END -TACTIC EXTEND CutRewrite -| [ "CutRewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] -| [ "CutRewrite" orient(b) constr(eqn) "in" hyp(id) ] +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] -> [ cutRewriteInHyp b eqn id ] END (* Contradiction *) open Contradiction -TACTIC EXTEND Absurd - [ "Absurd" constr(c) ] -> [ absurd c ] +TACTIC EXTEND absurd + [ "absurd" constr(c) ] -> [ absurd c ] END -TACTIC EXTEND Contradiction - [ "Contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ] +TACTIC EXTEND contradiction + [ "contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ] END (* AutoRewrite *) open Autorewrite -TACTIC EXTEND AutorewriteV7 - [ "AutoRewrite" "[" ne_preident_list(l) "]" ] -> - [ autorewrite Refiner.tclIDTAC l ] -| [ "AutoRewrite" "[" ne_preident_list(l) "]" "using" tactic(t) ] -> - [ autorewrite (snd t) l ] -| [ "AutoRewrite" "[" ne_preident_list(l) "]" "in" ident(id) ] -> - [ autorewrite_in id Refiner.tclIDTAC l ] -| [ "AutoRewrite" "[" ne_preident_list(l) "]" "in" ident(id) "using" tactic(t) ] -> - [ autorewrite_in id (snd t) l ] -END -TACTIC EXTEND AutorewriteV8 - [ "AutoRewrite" "with" ne_preident_list(l) ] -> + +TACTIC EXTEND autorewrite + [ "autorewrite" "with" ne_preident_list(l) ] -> [ autorewrite Refiner.tclIDTAC l ] -| [ "AutoRewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> [ autorewrite (snd t) l ] -| [ "AutoRewrite" "with" ne_preident_list(l) "in" ident(id) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) ] -> [ autorewrite_in id Refiner.tclIDTAC l ] -| [ "AutoRewrite" "with" ne_preident_list(l) "in" ident(id) "using" tactic(t) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) "using" tactic(t) ] -> [ autorewrite_in id (snd t) l ] END @@ -144,17 +136,7 @@ let add_rewrite_hint name ort t lcsr = let f c = Constrintern.interp_constr sigma env c, ort, t in add_rew_rules name (List.map f lcsr) -(* V7 *) -VERNAC COMMAND EXTEND HintRewriteV7 - [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) ] -> - [ add_rewrite_hint b o (Tacexpr.TacId "") l ] -| [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) - "using" tactic(t) ] -> - [ add_rewrite_hint b o t l ] -END - -(* V8 *) -VERNAC COMMAND EXTEND HintRewriteV8 +VERNAC COMMAND EXTEND HintRewrite [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] -> [ add_rewrite_hint b o (Tacexpr.TacId "") l ] | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) @@ -167,8 +149,8 @@ END open Refine -TACTIC EXTEND Refine - [ "Refine" casted_open_constr(c) ] -> [ refine c ] +TACTIC EXTEND refine + [ "refine" casted_open_constr(c) ] -> [ refine c ] END let refine_tac = h_refine @@ -177,33 +159,33 @@ let refine_tac = h_refine open Setoid_replace -TACTIC EXTEND SetoidReplace - [ "Setoid_replace" constr(c1) "with" constr(c2) ] -> +TACTIC EXTEND setoid_replace + [ "setoid_replace" constr(c1) "with" constr(c2) ] -> [ setoid_replace None c1 c2 ~new_goals:[] ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel)] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel)] -> [ setoid_replace (Some rel) c1 c2 ~new_goals:[] ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) ] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) ] -> [ setoid_replace None c1 c2 ~new_goals:l ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> [ setoid_replace (Some rel) c1 c2 ~new_goals:l ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) ] -> [ setoid_replace_in h None c1 c2 ~new_goals:[] ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel)] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel)] -> [ setoid_replace_in h (Some rel) c1 c2 ~new_goals:[] ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> [ setoid_replace_in h None c1 c2 ~new_goals:l ] - | [ "Setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> + | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) ] -> [ setoid_replace_in h (Some rel) c1 c2 ~new_goals:l ] END -TACTIC EXTEND SetoidRewrite - [ "Setoid_rewrite" orient(b) constr(c) ] +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(b) constr(c) ] -> [ general_s_rewrite b c ~new_goals:[] ] - | [ "Setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] + | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ] -> [ general_s_rewrite b c ~new_goals:l ] - | [ "Setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> + | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] -> [ general_s_rewrite_in h b c ~new_goals:[] ] - | [ "Setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> + | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] -> [ general_s_rewrite_in h b c ~new_goals:l ] END @@ -241,17 +223,17 @@ VERNAC COMMAND EXTEND AddRelation3 [ add_relation n a aeq None None (Some t) ] END -TACTIC EXTEND SetoidSymmetry - [ "Setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "Setoid_symmetry" "in" ident(n) ] -> [ setoid_symmetry_in n ] +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" ident(n) ] -> [ setoid_symmetry_in n ] END -TACTIC EXTEND SetoidReflexivity - [ "Setoid_reflexivity" ] -> [ setoid_reflexivity ] +TACTIC EXTEND setoid_reflexivity + [ "setoid_reflexivity" ] -> [ setoid_reflexivity ] END -TACTIC EXTEND SetoidTransitivity - [ "Setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ] END (* Inversion lemmas (Leminv) *) @@ -302,34 +284,27 @@ END (* Subst *) -TACTIC EXTEND Subst -| [ "Subst" ne_var_list(l) ] -> [ subst l ] -| [ "Subst" ] -> [ subst_all ] +TACTIC EXTEND subst +| [ "subst" ne_var_list(l) ] -> [ subst l ] +| [ "subst" ] -> [ subst_all ] END open Evar_tactics (* evar creation *) -TACTIC EXTEND Evar - [ "Evar" "(" ident(id) ":" constr(typ) ")" ] -> - [ let_evar (Names.Name id) typ ] -| [ "Evar" constr(typ) ] -> - [ let_evar Names.Anonymous typ ] +TACTIC EXTEND evar + [ "evar" "(" ident(id) ":" constr(typ) ")" ] -> [ let_evar (Name id) typ ] +| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] END open Tacexpr TACTIC EXTEND instantiate - [ "Instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] -> + [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] -> [instantiate i c hl ] END -V7 TACTIC EXTEND instantiate - [ "Instantiate" integer(i) raw(c) hloc(hl) ] -> - [ instantiate i c hl ] -END - (** Nijmegen "step" tactic for setoid rewriting *) @@ -409,14 +384,14 @@ let add_transitivity_lemma left lem = (* Vernacular syntax *) -TACTIC EXTEND Stepl -| ["Stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ] -| ["Stepl" constr(c) ] -> [ step true c tclIDTAC ] +TACTIC EXTEND stepl +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ] +| ["stepl" constr(c) ] -> [ step true c tclIDTAC ] END -TACTIC EXTEND Stepr -| ["Stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ] -| ["Stepr" constr(c) ] -> [ step false c tclIDTAC ] +TACTIC EXTEND stepr +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ] +| ["stepr" constr(c) ] -> [ step false c tclIDTAC ] END VERNAC COMMAND EXTEND AddStepl diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index 847d0caa7..5c375ddce 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -56,16 +56,14 @@ val h_instantiate : int -> Rawterm.rawconstr -> (* Derived basic tactics *) -val h_simple_induction : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic +val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic val h_new_induction : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + intro_pattern_expr option -> tactic val h_new_destruct : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + intro_pattern_expr option -> tactic val h_specialize : int option -> constr with_bindings -> tactic val h_lapply : constr -> tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index b91222ae9..fd2d5c9c1 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -252,12 +252,12 @@ let rec first_match matcher = function (*** Equality *) -(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *) +(* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *) let coq_eq_pattern_gen eq = lazy (PApp(PRef (Lazy.force eq), [|mkPMeta 1;mkPMeta 2;mkPMeta 3|])) let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref (*let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref*) -let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref +let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref let match_eq eqn eq_pat = match matches (Lazy.force eq_pat) eqn with @@ -268,8 +268,7 @@ let match_eq eqn eq_pat = let equalities = [coq_eq_pattern, build_coq_eq_data; -(* coq_eqT_pattern, build_coq_eqT_data;*) - coq_idT_pattern, build_coq_idT_data] + coq_identity_pattern, build_coq_identity_data] let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *) first_match (match_eq eqn) equalities diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 481b78683..bd5c1bf41 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -258,10 +258,12 @@ let add_inversion_lemma name env sigma t sort dep inv_op = (* inv_op = Inv (derives de complete inv. lemma) * inv_op = InvNoThining (derives de semi inversion lemma) *) -let inversion_lemma_from_goal n na id sort dep_option inv_op = +let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in let gl = nth_goal_of_pftreestate n pts in - let t = pf_get_hyp_typ gl id in + let t = + try pf_get_hyp_typ gl id + with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in (* Pourquoi ??? let fv = global_vars env t in diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 6617edf2c..3e12f770e 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -1,4 +1,4 @@ - +open Util open Names open Term open Rawterm @@ -12,7 +12,7 @@ val lemInv_clause : quantified_hypothesis -> constr -> identifier list -> tactic val inversion_lemma_from_goal : - int -> identifier -> identifier -> sorts -> bool -> + int -> identifier -> identifier located -> sorts -> bool -> (identifier -> tactic) -> unit val add_inversion_lemma_exn : identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index e4177a69a..5f2baf8f8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -32,7 +32,6 @@ open Refiner open Tacmach open Tactic_debug open Topconstr -open Ast open Term open Termops open Tacexpr @@ -47,11 +46,6 @@ open Inductiveops open Syntax_def open Pretyping -let strip_meta id = (* For Grammar v7 compatibility *) - let s = string_of_id id in - if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) - else id - let error_syntactic_metavariables_not_allowed loc = user_err_loc (loc,"out_ident", @@ -131,7 +125,7 @@ let make_hyps = List.map (fun (id,_,typ) -> (id, typ)) let constr_of_id env id = construct_reference (Environ.named_context env) id -(* To embed several objects in Coqast.t *) +(* To embed tactics *) let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t), (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) = create "tactic" @@ -160,7 +154,7 @@ let valueOut = function | ast -> anomalylabstrm "valueOut" (str "Not a Dynamic ast: ") -(* To embed constr in Coqast.t *) +(* To embed constr *) let constrIn t = CDynamic (dummy_loc,constr_in t) let constrOut = function | CDynamic (_,d) -> @@ -170,32 +164,8 @@ let constrOut = function anomalylabstrm "constrOut" (str "Dynamic tag should be constr") | ast -> anomalylabstrm "constrOut" (str "Not a Dynamic ast") -let loc = dummy_loc - -(* Table of interpretation functions *) -let interp_tab = - (Hashtbl.create 17 : (string , interp_sign -> Coqast.t -> value) Hashtbl.t) - -(* Adds an interpretation function *) -let interp_add (ast_typ,interp_fun) = - try - Hashtbl.add interp_tab ast_typ interp_fun - with - Failure _ -> - errorlabstrm "interp_add" - (str "Cannot add the interpretation function for " ++ str ast_typ ++ str " twice") - -(* Adds a possible existing interpretation function *) -let overwriting_interp_add (ast_typ,interp_fun) = - if Hashtbl.mem interp_tab ast_typ then - begin - Hashtbl.remove interp_tab ast_typ; - warning ("Overwriting definition of tactic interpreter command " ^ ast_typ) - end; - Hashtbl.add interp_tab ast_typ interp_fun -(* Finds the interpretation function corresponding to a given ast type *) -let look_for_interp = Hashtbl.find interp_tab +let loc = dummy_loc (* Globalizes the identifier *) @@ -249,14 +219,12 @@ let coerce_to_inductive = function (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) let atomic_mactab = ref Idmap.empty let add_primitive_tactic s tac = - (if not !Options.v7 then - let id = id_of_string s in - atomic_mactab := Idmap.add id tac !atomic_mactab) + let id = id_of_string s in + atomic_mactab := Idmap.add id tac !atomic_mactab let _ = - if not !Options.v7 then - (let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in - List.iter + let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in + List.iter (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t))) [ "red", TacReduce(Red false,nocl); "hnf", TacReduce(Hnf,nocl); @@ -275,12 +243,12 @@ let _ = "reflexivity", TacReflexivity; "symmetry", TacSymmetry nocl ]; - List.iter + List.iter (fun (s,t) -> add_primitive_tactic s t) [ "idtac",TacId ""; "fail", TacFail(ArgArg 0,""); "fresh", TacArg(TacFreshId None) - ]) + ] let lookup_atomic id = Idmap.find id !atomic_mactab let is_atomic id = Idmap.mem id !atomic_mactab @@ -697,18 +665,18 @@ let rec intern_atomic lf ist x = | TacDAuto (n,p) -> TacDAuto (option_app (intern_int_or_var ist) n,p) (* Derived basic tactics *) - | TacSimpleInduction (h,ids) -> - TacSimpleInduction (intern_quantified_hypothesis ist h,ids) - | TacNewInduction (c,cbo,(ids,ids')) -> + | TacSimpleInduction h -> + TacSimpleInduction (intern_quantified_hypothesis ist h) + | TacNewInduction (c,cbo,ids) -> TacNewInduction (intern_induction_arg ist c, option_app (intern_constr_with_bindings ist) cbo, - (option_app (intern_intro_pattern lf ist) ids,ids')) + (option_app (intern_intro_pattern lf ist) ids)) | TacSimpleDestruct h -> TacSimpleDestruct (intern_quantified_hypothesis ist h) - | TacNewDestruct (c,cbo,(ids,ids')) -> + | TacNewDestruct (c,cbo,ids) -> TacNewDestruct (intern_induction_arg ist c, option_app (intern_constr_with_bindings ist) cbo, - (option_app (intern_intro_pattern lf ist) ids,ids')) + (option_app (intern_intro_pattern lf ist) ids)) | TacDoubleInduction (h1,h2) -> let h1 = intern_quantified_hypothesis ist h1 in let h2 = intern_quantified_hypothesis ist h2 in @@ -757,19 +725,13 @@ let rec intern_atomic lf ist x = let _ = lookup_tactic opn in TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l) | TacAlias (loc,s,l,(dir,body)) -> - let l = List.map (fun (id,a) -> (strip_meta id,intern_genarg ist a)) l in + let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in try TacAlias (loc,s,l,(dir,body)) with e -> raise (locate_error_in_file (string_of_dirpath dir) e) and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr) and intern_tactic_seq ist = function - (* Traducteur v7->v8 *) - | TacAtom (_,TacReduce (Unfold [_,Ident (_,id)],_)) - when string_of_id id = "INZ" & !Options.translate_syntax - -> ist.ltacvars, (TacId "") - (* Fin traducteur v7->v8 *) - | TacAtom (loc,t) -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in @@ -833,7 +795,7 @@ and intern_tacarg strict ist = function (* $id can occur in Grammar tactic... *) let id = id_of_string s in if find_ltacvar id ist or Options.do_translate() - then Reference (ArgVar (adjust_loc loc,strip_meta id)) + then Reference (ArgVar (adjust_loc loc,id)) else error_syntactic_metavariables_not_allowed loc | TacCall (loc,f,l) -> TacCall (loc, @@ -881,7 +843,7 @@ and intern_genarg ist x = | IdentArgType -> let lf = ref ([],[]) in in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x)) - | HypArgType -> + | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) | RefArgType -> in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x)) @@ -892,7 +854,7 @@ and intern_genarg ist x = | ConstrMayEvalArgType -> in_gen globwit_constr_may_eval (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x)) - | QuantHypArgType -> + | QuantVarArgType -> in_gen globwit_quant_hyp (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x)) | RedExprArgType -> @@ -1092,8 +1054,8 @@ let id_of_Identifier = variable_of_value (* Extract a constr from a value, if any *) let constr_of_VConstr = constr_of_value -(* Interprets an variable *) -let interp_var ist gl (loc,id) = +(* Interprets a bound variable (especially an existing hypothesis) *) +let interp_hyp ist gl (loc,id) = (* Look first in lfun for a value coercible to a variable *) try let v = List.assoc id ist.lfun in @@ -1108,9 +1070,6 @@ let interp_var ist gl (loc,id) = else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found") -(* Interprets an existing hypothesis (i.e. a declared variable) *) -let interp_hyp = interp_var - let interp_name ist = function | Anonymous -> Anonymous | Name id -> Name (interp_ident ist id) @@ -1637,8 +1596,8 @@ and interp_genarg ist goal x = (interp_intro_pattern ist (out_gen globwit_intro_pattern x)) | IdentArgType -> in_gen wit_ident (interp_ident ist (out_gen globwit_ident x)) - | HypArgType -> - in_gen wit_var (mkVar (interp_hyp ist goal (out_gen globwit_var x))) + | VarArgType -> + in_gen wit_var (interp_hyp ist goal (out_gen globwit_var x)) | RefArgType -> in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x)) | SortArgType -> @@ -1650,7 +1609,7 @@ and interp_genarg ist goal x = in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x)) | ConstrMayEvalArgType -> in_gen wit_constr_may_eval (interp_constr_may_eval ist goal (out_gen globwit_constr_may_eval x)) - | QuantHypArgType -> + | QuantVarArgType -> in_gen wit_quant_hyp (interp_declared_or_quantified_hypothesis ist goal (out_gen globwit_quant_hyp x)) @@ -1770,21 +1729,18 @@ and interp_atomic ist gl = function | TacDAuto (n,p) -> Auto.h_dauto (option_app (interp_int_or_var ist) n,p) (* Derived basic tactics *) - | TacSimpleInduction (h,ids) -> - let h = - if !Options.v7 then interp_declared_or_quantified_hypothesis ist gl h - else interp_quantified_hypothesis ist h in - h_simple_induction (h,ids) - | TacNewInduction (c,cbo,(ids,ids')) -> + | TacSimpleInduction h -> + h_simple_induction (interp_quantified_hypothesis ist h) + | TacNewInduction (c,cbo,ids) -> h_new_induction (interp_induction_arg ist gl c) (option_app (interp_constr_with_bindings ist gl) cbo) - (option_app (interp_intro_pattern ist) ids,ids') + (option_app (interp_intro_pattern ist) ids) | TacSimpleDestruct h -> h_simple_destruct (interp_quantified_hypothesis ist h) - | TacNewDestruct (c,cbo,(ids,ids')) -> + | TacNewDestruct (c,cbo,ids) -> h_new_destruct (interp_induction_arg ist gl c) (option_app (interp_constr_with_bindings ist gl) cbo) - (option_app (interp_intro_pattern ist) ids,ids') + (option_app (interp_intro_pattern ist) ids) | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -1857,8 +1813,8 @@ and interp_atomic ist gl = function VIntroPattern (out_gen globwit_intro_pattern x) | IdentArgType -> VIntroPattern (IntroIdentifier (out_gen globwit_ident x)) - | HypArgType -> - VConstr (mkVar (interp_var ist gl (out_gen globwit_var x))) + | VarArgType -> + VConstr (mkVar (interp_hyp ist gl (out_gen globwit_var x))) | RefArgType -> VConstr (constr_of_global (pf_interp_reference ist gl (out_gen globwit_ref x))) @@ -1872,7 +1828,7 @@ and interp_atomic ist gl = function | TacticArgType n -> val_interp ist gl (out_gen (globwit_tactic n) x) | StringArgType | BoolArgType - | QuantHypArgType | RedExprArgType + | QuantVarArgType | RedExprArgType | OpenConstrArgType _ | ConstrWithBindingsArgType | BindingsArgType | ExtraArgType _ | List0ArgType _ | List1ArgType _ | OptArgType _ | PairArgType _ -> error "This generic type is not supported in alias" @@ -2155,7 +2111,7 @@ and subst_genarg subst (x:glob_generic_argument) = | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x) - | HypArgType -> in_gen globwit_var (out_gen globwit_var x) + | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> in_gen globwit_ref (subst_global_reference subst (out_gen globwit_ref x)) @@ -2165,7 +2121,7 @@ and subst_genarg subst (x:glob_generic_argument) = in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x)) | ConstrMayEvalArgType -> in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x)) - | QuantHypArgType -> + | QuantVarArgType -> in_gen globwit_quant_hyp (subst_declared_or_quantified_hypothesis subst (out_gen globwit_quant_hyp x)) @@ -2280,11 +2236,6 @@ let glob_tactic_env l env x = { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x -let glob_tactic_env_v7 l env x = - intern_tactic - { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env } - x - let interp_redexp env evc r = let ist = { lfun=[]; debug=get_debug () } in let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = evc } in diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 8746da993..a23ce1809 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -119,8 +119,6 @@ val glob_tactic : raw_tactic_expr -> glob_tactic_expr val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr -val glob_tactic_env_v7 : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr - val eval_tactic : glob_tactic_expr -> tactic val interp : raw_tactic_expr -> tactic @@ -131,13 +129,6 @@ val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr val hide_interp : raw_tactic_expr -> tactic option -> tactic -(* Adds an interpretation function *) -val interp_add : string * (interp_sign -> Coqast.t -> value) -> unit - -(* Adds a possible existing interpretation function *) -val overwriting_interp_add : string * (interp_sign -> Coqast.t -> value) -> - unit - (* Declare the default tactic to fill implicit arguments *) val declare_implicit_tactic : tactic -> unit diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 29fd46f3e..05eb17fe7 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -119,15 +119,13 @@ type clause = identifier gclause let allClauses = { onhyps=None; onconcl=true; concl_occs=[] } let allHyps = { onhyps=None; onconcl=false; concl_occs=[] } -let onHyp id = - { onhyps=Some[(id,[],(InHyp, ref None))]; onconcl=false; concl_occs=[] } +let onHyp id = { onhyps=Some[(id,[],InHyp)]; onconcl=false; concl_occs=[] } let onConcl = { onhyps=Some[]; onconcl=true; concl_occs=[] } let simple_clause_list_of cl gls = let hyps = match cl.onhyps with - None -> - List.map (fun id -> Some(id,[],(InHyp,ref None))) (pf_ids_of_hyps gls) + None -> List.map (fun id -> Some(id,[],InHyp)) (pf_ids_of_hyps gls) | Some l -> List.map (fun h -> Some h) l in if cl.onconcl then None::hyps else hyps diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d1a7507c7..5e383c0c0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -147,25 +147,21 @@ type tactic_reduction = env -> evar_map -> constr -> constr let reduct_in_concl (redfun,sty) gl = convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl -let reduct_in_hyp redfun (id,_,(where,where')) gl = +let reduct_in_hyp redfun (id,_,where) gl = let (_,c, ty) = pf_get_hyp gl id in let redfun' = (*under_casts*) (pf_reduce redfun gl) in match c with | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value"); - if Options.do_translate () then where' := Some where; convert_hyp_no_check (id,None,redfun' ty) gl | Some b -> - let where = - if !Options.v7 & where = InHyp then InHypValueOnly else where in let b' = if where <> InHypTypeOnly then redfun' b else b in let ty' = if where <> InHypValueOnly then redfun' ty else ty in - if Options.do_translate () then where' := Some where; convert_hyp_no_check (id,Some b',ty') gl let reduct_option redfun = function - | Some id -> reduct_in_hyp (fst redfun) id + | Some id -> reduct_in_hyp (fst redfun) id | None -> reduct_in_concl redfun (* The following tactic determines whether the reduction @@ -771,12 +767,8 @@ let check_hypotheses_occurrences_list env (_,occl) = let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]} -(* Tactic Assert (b=false) and Pose (b=true): - the behaviour of Pose is corrected by the translator. - not that of Assert *) -let forward b na c = - let wh = if !Options.v7 && b then onConcl else nowhere in - letin_tac b na c wh +(* Tactics "assert (...:=...)" (b=false) and "pose" (b=true) *) +let forward b na c = letin_tac b na c nowhere (********************************************************************) (* Exact tactics *) @@ -1127,96 +1119,49 @@ let rec first_name_buggy = function type elim_arg_kind = RecArg | IndArg | OtherArg -let induct_discharge statuslists destopt avoid' ((avoid7,avoid8),ra) (names,force,rnames) gl = - let avoid7 = avoid7 @ avoid' in - let avoid8 = avoid8 @ avoid' in +let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = + let avoid = avoid @ avoid' in let (lstatus,rstatus) = statuslists in let tophyp = ref None in let rec peel_tac ra names gl = match ra with - | (RecArg,(recvarname7,recvarname8)) :: - (IndArg,(hyprecname7,hyprecname8)) :: ra' -> + | (RecArg,recvarname) :: + (IndArg,hyprecname) :: ra' -> let recpat,hyprec,names = match names with | [] -> - let idrec7 = (fresh_id avoid7 recvarname7 gl) in - let idrec8 = (fresh_id avoid8 recvarname8 gl) in - let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in - let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in - if Options.do_translate() & - (idrec7 <> idrec8 or idhyp7 <> idhyp8) - then force := true; - let idrec = if !Options.v7 then idrec7 else idrec8 in - let idhyp = if !Options.v7 then idhyp7 else idhyp8 in + let idrec = fresh_id avoid recvarname gl in + let idhyp = fresh_id avoid hyprecname gl in (IntroIdentifier idrec, IntroIdentifier idhyp, []) | [IntroIdentifier id as pat] -> - let id7 = next_ident_away (add_prefix "IH" id) avoid7 in - let id8 = next_ident_away (add_prefix "IH" id) avoid8 in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in + let id = next_ident_away (add_prefix "IH" id) avoid in (pat, IntroIdentifier id, []) | [pat] -> - let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in - let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in - if Options.do_translate() & idhyp7 <> idhyp8 then force := true; - let idhyp = if !Options.v7 then idhyp7 else idhyp8 in + let idhyp = (fresh_id avoid hyprecname gl) in (pat, IntroIdentifier idhyp, []) | pat1::pat2::names -> (pat1,pat2,names) in (* This is buggy for intro-or-patterns with different first hypnames *) if !tophyp=None then tophyp := first_name_buggy hyprec; - rnames := !rnames @ [recpat; hyprec]; tclTHENLIST [ intros_pattern destopt [recpat]; intros_pattern None [hyprec]; peel_tac ra' names ] gl - | (IndArg,(hyprecname7,hyprecname8)) :: ra' -> + | (IndArg,hyprecname) :: ra' -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = match names with - | [] -> IntroIdentifier (fresh_id avoid8 hyprecname8 gl), [] + | [] -> IntroIdentifier (fresh_id avoid hyprecname gl), [] | pat::names -> pat,names in - rnames := !rnames @ [pat]; tclTHEN (intros_pattern destopt [pat]) (peel_tac ra' names) gl - | (RecArg,(recvarname7,recvarname8)) :: ra' -> + | (RecArg,recvarname) :: ra' -> let introtac,names = match names with | [] -> - let id8 = fresh_id avoid8 recvarname8 gl in - let i = - if !Options.v7 then IntroAvoid avoid7 else IntroMustBe id8 - in - (* For translator *) - let id7 = fresh_id avoid7 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in - rnames := !rnames @ [IntroIdentifier id]; - intro_gen i destopt false, [] + let id = fresh_id avoid recvarname gl in + intro_gen (IntroMustBe id) destopt false, [] | pat::names -> - rnames := !rnames @ [pat]; intros_pattern destopt [pat],names in tclTHEN introtac (peel_tac ra' names) gl | (OtherArg,_) :: ra' -> let introtac,names = match names with - | [] -> - (* For translator *) - let id7 = fresh_id avoid7 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - let id8 = fresh_id avoid8 (default_id gl - (match kind_of_term (pf_concl gl) with - | Prod (name,t,_) -> (name,None,t) - | LetIn (name,b,t,_) -> (name,Some b,t) - | _ -> raise (RefinerError IntroNeedsProduct))) gl in - if Options.do_translate() & id7 <> id8 then force := true; - let id = if !Options.v7 then id7 else id8 in - let avoid = if !Options.v7 then avoid7 else avoid8 in - rnames := !rnames @ [IntroIdentifier id]; - intro_gen (IntroAvoid avoid) destopt false, [] - | pat::names -> - rnames := !rnames @ [pat]; - intros_pattern destopt [pat],names in + | [] -> intro_gen (IntroAvoid avoid) destopt false, [] + | pat::names -> intros_pattern destopt [pat],names in tclTHEN introtac (peel_tac ra' names) gl | [] -> check_unused_names names; @@ -1400,37 +1345,6 @@ let induction_tac varname typ ((elimc,lbindelimc),elimt) gl = (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in elimination_clause_scheme true elimclause indclause gl -let make_up_names7 n ind (old_style,cname) = - if old_style (* = V6.3 version of Induction on hypotheses *) - then - let recvarname = - if n=1 then - cname - else (* To force renumbering if there is only one *) - make_ident (string_of_id cname ) (Some 1) in - recvarname, add_prefix "Hrec" recvarname, [] - else - let is_hyp = atompart_of_id cname = "H" in - let hyprecname = - add_prefix "IH" (if is_hyp then Nametab.id_of_global ind else cname) in - let avoid = - if n=1 (* Only one recursive argument *) - or - (* Rem: no recursive argument (especially if Destruct) *) - n=0 (* & atompart_of_id cname <> "H" (* for 7.1 compatibility *)*) - then [] - else - (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) - (* in order to get names such as f1, f2, ... *) - let avoid = - (make_ident (string_of_id cname) (Some 0)) ::(*here for 7.1 cmpat*) - (make_ident (string_of_id hyprecname) None) :: - (make_ident (string_of_id hyprecname) (Some 0)) :: [] in - if atompart_of_id cname <> "H" then - (make_ident (string_of_id cname) None) :: avoid - else avoid in - cname, hyprecname, avoid - let make_base n id = if n=0 or n=1 then id else @@ -1438,7 +1352,7 @@ let make_base n id = (* digits *) id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0))) -let make_up_names8 n ind (_,cname) = +let make_up_names n ind (_,cname) = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in let hyprecname = @@ -1519,16 +1433,13 @@ let compute_elim_signature elimt names_info = | (_,None,t)::brs -> (match try Some (check_branch p t) with Exit -> None with | Some l -> - let n7 = List.fold_left - (fun n b -> if b=IndArg then n+1 else n) 0 l in - let n8 = List.fold_left + let n = List.fold_left (fun n b -> if b=RecArg then n+1 else n) 0 l in - let recvarname7, hyprecname7, avoid7 = make_up_names7 n7 indt names_info in - let recvarname8, hyprecname8, avoid8 = make_up_names8 n8 indt names_info in + let recvarname, hyprecname, avoid = + make_up_names n indt names_info in let namesign = List.map - (fun b -> (b,if b=IndArg then (hyprecname7,hyprecname8) - else (recvarname7,recvarname8))) l in - ((avoid7,avoid8),namesign) :: find_branches (p+1) brs + (fun b -> (b,if b=IndArg then hyprecname else recvarname)) l in + (avoid,namesign) :: find_branches (p+1) brs | None -> error_ind_scheme "the branches of") | (_,Some _,_)::_ -> error_ind_scheme "the branches of" | [] -> @@ -1559,7 +1470,7 @@ let find_elim_signature isrec style elim hyp0 gl = let nparams,indref,indsign = compute_elim_signature elimt name_info in (elimc,elimt,nparams,indref,indsign) -let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl = +let induction_from_context isrec elim_info hyp0 names gl = (*test suivant sans doute inutile car refait par le letin_tac*) if List.mem hyp0 (ids_of_named_context (Global.named_context())) then errorlabstrm "induction" @@ -1572,11 +1483,6 @@ let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl = let (statlists,lhyp0,indhyps,deps) = cook_sign hyp0 indvars env in let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in let names = compute_induction_names (Array.length indsign) names in - (* For translator *) - let names' = Array.map ref (Array.make (Array.length indsign) []) in - let b = ref false in - b_rnames := (b,Array.to_list names')::!b_rnames; - let names = array_map2 (fun n n' -> (n,b,n')) names names' in (* End translator *) let dephyps = List.map (fun (id,_,_) -> id) deps in let args = @@ -1647,23 +1553,12 @@ let new_destruct = new_induct_destruct false let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim) let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim) -(* This was Induction in 6.3 (hybrid form) *) -let induction_from_context_old_style hyp b_ids gl = - let elim_info = find_elim_signature true true None hyp gl in - let x = induction_from_context true elim_info hyp (None,b_ids) gl in - (* For translator *) fst (List.hd !b_ids) := true; - x - -let simple_induct_id hyp b_ids = - if !Options.v7 then - tclORELSE (raw_induct hyp) (induction_from_context_old_style hyp b_ids) - else - raw_induct hyp +let simple_induct_id hyp = raw_induct hyp let simple_induct_nodep = raw_induct_nodep let simple_induct = function - | NamedHyp id,b_ids -> simple_induct_id id b_ids - | AnonHyp n,_ -> simple_induct_nodep n + | NamedHyp id -> simple_induct_id id + | AnonHyp n -> simple_induct_nodep n (* Destruction tactics *) @@ -1912,8 +1807,7 @@ let abstract_subproof name tac gls = let na = next_global_ident_away false name (pf_ids_of_hyps gls) in let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in if occur_existential concl then - if !Options.v7 then error "Abstract cannot handle existentials" - else error "\"abstract\" cannot handle existentials"; + error "\"abstract\" cannot handle existentials"; let lemme = start_proof na (IsGlobal (Proof Lemma)) secsign concl (fun _ _ -> ()); let _,(const,kind,_) = @@ -1955,9 +1849,7 @@ let admit_as_an_axiom gls = let name = add_suffix (get_current_proof_name ()) "_admitted" in let na = next_global_ident_away false name (pf_ids_of_hyps gls) in let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in - if occur_existential concl then - if !Options.v7 then error "admit cannot handle existentials" - else error "\"admit\" cannot handle existentials"; + if occur_existential concl then error "\"admit\" cannot handle existentials"; let axiom = let cd = Entries.ParameterEntry concl in let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index f3da4a8c9..91c6731b7 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -175,11 +175,10 @@ val general_elim_in : val default_elim : constr with_bindings -> tactic val simplest_elim : constr -> tactic val elim : constr with_bindings -> constr with_bindings option -> tactic -val simple_induct : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic +val simple_induct : quantified_hypothesis -> tactic val new_induct : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + intro_pattern_expr option -> tactic (*s Case analysis tactics. *) @@ -188,8 +187,7 @@ val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic val new_destruct : constr induction_arg -> constr with_bindings option -> - intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref - -> tactic + intro_pattern_expr option -> tactic (*s Eliminations giving the type instead of the proof. *) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index e62b50bd0..3c65fe159 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -10,8 +10,6 @@ (*i $Id$ i*) -open Ast -open Coqast open Hipattern open Names open Libnames @@ -171,39 +169,11 @@ let tauto g = let default_intuition_tac = interp <:tactic< auto with * >> -let q_elim tac= - <:tactic< - match goal with - x : ?X1, H : ?X1 -> _ |- _ => generalize (H x); clear H; $tac - end >> - -let rec lfo n gl= - if n=0 then (tclFAIL 0 "LinearIntuition failed" gl) else - let p=if n<0 then n else (n-1) in - let lfo_rec=q_elim (Tacexpr.TacArg (valueIn (VTactic(dummy_loc,lfo p)))) in - intuition_gen (interp lfo_rec) gl - -let lfo_wrap n gl= - try lfo n gl - with - Refiner.FailError _ | UserError _ -> - errorlabstrm "LinearIntuition" [< str "LinearIntuition failed." >] - -TACTIC EXTEND Tauto -| [ "Tauto" ] -> [ tauto ] -END -(* Obsolete sinve V8.0 -TACTIC EXTEND TSimplif -| [ "Simplif" ] -> [ simplif_gen ] +TACTIC EXTEND tauto +| [ "tauto" ] -> [ tauto ] END -*) -TACTIC EXTEND Intuition -| [ "Intuition" ] -> [ intuition_gen default_intuition_tac ] -| [ "Intuition" tactic(t) ] -> [ intuition_gen (snd t) ] -END -(* Obsolete since V8.0 -TACTIC EXTEND LinearIntuition -| [ "LinearIntuition" ] -> [ lfo_wrap (-1)] -| [ "LinearIntuition" integer(n)] -> [ lfo_wrap n] + +TACTIC EXTEND intuition +| [ "intuition" ] -> [ intuition_gen default_intuition_tac ] +| [ "intuition" tactic(t) ] -> [ intuition_gen (snd t) ] END -*) diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index d2d180a6a..138df18ed 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -10,7 +10,6 @@ open Pp open Util -open Ast open Indtypes open Type_errors open Pretype_errors @@ -48,8 +47,6 @@ let rec explain_exn_default = function hov 0 (str "Out of memory") | Stack_overflow -> hov 0 (str "Stack overflow") - | Ast.No_match s -> - hov 0 (str "Anomaly: Ast matching error: " ++ str s ++ report ()) | Anomaly (s,pps) -> hov 1 (str "Anomaly: " ++ where s ++ pps ++ report ()) | Match_failure(filename,pos1,pos2) -> diff --git a/toplevel/command.ml b/toplevel/command.ml index 5fc945438..74494429c 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -160,7 +160,6 @@ let declare_definition ident (local,dok) bl red_option c typopt hook = let syntax_definition ident c local onlyparse = let c = snd (interp_aconstr [] [] c) in - let onlyparse = !Options.v7_only or onlyparse in Syntax_def.declare_syntactic_definition local ident onlyparse c (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) @@ -305,7 +304,7 @@ let interp_mutual lparams lnamearconstrs finite = let argsc = compute_arguments_scope fullarity in let ind_impls' = if Impargs.is_implicit_args() then - let impl = Impargs.compute_implicits false env_params fullarity in + let impl = Impargs.compute_implicits env_params fullarity in let paramimpl,_ = list_chop nparamassums impl in let l = List.fold_right (fun imp l -> if Impargs.is_status_implicit imp then @@ -468,7 +467,7 @@ let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) let arity = interp_type sigma env0 arityc in let impl = if Impargs.is_implicit_args() - then Impargs.compute_implicits false env0 arity + then Impargs.compute_implicits env0 arity else [] in let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in (Environ.push_named (recname,None,arity) env, impls', arity::arl)) diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 0df54e626..00cc8be14 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -82,11 +82,8 @@ let init_load_path () = if Sys.file_exists user_contrib then Mltop.add_rec_path user_contrib Nameops.default_root_prefix; (* then standard library *) - let vdirs = - if !Options.v7 then [ "theories7"; "contrib7" ] - else [ "theories"; "contrib" ] in - let dirs = - (if !Options.v7 then "states7" else "states") :: dev @ vdirs in + let vdirs = [ "theories"; "contrib" ] in + let dirs = "states" :: dev @ vdirs in List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in add_ml_include camlp4; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 9fe0f5b74..f74d7efc8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -29,9 +29,8 @@ let get_version_date () = with _ -> Coq_config.date let print_header () = - Printf.printf "Welcome to Coq %s%s (%s)\n" + Printf.printf "Welcome to Coq %s (%s)\n" Coq_config.version - (if !Options.v7 then " (V7 syntax)" else "") (get_version_date ()); flush stdout @@ -268,8 +267,8 @@ let parse_args is_ide = | "-xml" :: rem -> Options.xml_export := true; parse rem (* Scanned in Options! *) - | "-v7" :: rem -> (* Options.v7 := true; *) parse rem - | "-v8" :: rem -> (* Options.v7 := false; *) parse rem + | "-v7" :: rem -> error "This version of Coq does not support v7 syntax" + | "-v8" :: rem -> parse rem | "-no-hash-consing" :: rem -> Options.hash_cons_proofs := false; parse rem diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml index 52a7c0c8a..dd5160f76 100644 --- a/toplevel/fhimsg.ml +++ b/toplevel/fhimsg.ml @@ -278,14 +278,7 @@ let explain_ml_case k ctx mes c ct br brt = hov 0 (str "In ML case expression on " ++ pc ++ ws 1 ++ cut () ++ str "of type" ++ ws 1 ++ pct ++ ws 1 ++ cut () ++ str "which is an inductive predicate." ++ fnl () ++ expln) -(* -let explain_cant_find_case_type loc k ctx c = - let pe = P.pr_term k ctx c in - Ast.user_err_loc - (loc,"pretype", - hov 3 (str "Cannot infer type of whole Case expression on" ++ - ws 1 ++ pe)) -*) + let explain_type_error k ctx = function | UnboundRel n -> explain_unbound_rel k ctx n diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 73924685f..58b6f85c9 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -26,11 +26,10 @@ open Reduction open Cases open Logic open Printer -open Ast open Rawterm open Evd -let quote s = if !Options.v7 then s else h 0 (str "\"" ++ s ++ str "\"") +let quote s = h 0 (str "\"" ++ s ++ str "\"") let prterm c = quote (prterm c) let prterm_env e c = quote (prterm_env e c) @@ -107,16 +106,7 @@ let explain_elim_arity ctx ind aritylst c pj okinds = hov 0 ( str "Incorrect elimination of" ++ spc() ++ pc ++ spc () ++ str "in the inductive type " ++ spc() ++ quote pi ++ - (if !Options.v7 then - let pp = prterm_env ctx pj.uj_val in - let ppar = pr_disjunction (prterm_env ctx) aritylst in - let ppt = prterm_env ctx pj.uj_type in - fnl () ++ - str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ - str "has arity" ++ brk(1,1) ++ ppt ++ fnl () ++ - str "It should be " ++ brk(1,1) ++ ppar - else - let sorts = List.map (fun x -> mkSort (new_sort_in_family x)) + (let sorts = List.map (fun x -> mkSort (new_sort_in_family x)) (list_uniquize (List.map (fun ar -> family_of_sort (destSort (snd (decompose_prod_assum ar)))) aritylst)) in let ppar = pr_disjunction (prterm_env ctx) sorts in @@ -345,14 +335,10 @@ let explain_hole_kind env = function | BinderType Anonymous -> str "a type for this anonymous binder" | ImplicitArg (c,(n,ido)) -> - if !Options.v7 then - str "the " ++ pr_ord n ++ - str " implicit argument of " ++ Nametab.pr_global_env Idset.empty c - else - let id = out_some ido in - str "an instance for the implicit parameter " ++ - pr_id id ++ spc () ++ str "of" ++ - spc () ++ Nametab.pr_global_env Idset.empty c + let id = out_some ido in + str "an instance for the implicit parameter " ++ + pr_id id ++ spc () ++ str "of" ++ + spc () ++ Nametab.pr_global_env Idset.empty c | InternalHole -> str "a term for an internal placeholder" | TomatchTypeParameter (tyi,n) -> diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 24bee11e1..cef0d1dea 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -21,6 +21,8 @@ open Vernacexpr open Pcoq open Rawterm open Libnames +open Lexer +open Egrammar (**********************************************************************) (* Globalisation for constr_expr *) @@ -51,9 +53,6 @@ let rec globalize_constr_expr vars = function map_constr_expr_with_binders globalize_constr_expr (fun id e -> id::e) vars c -let _ = set_constr_globalizer - (fun vars e -> for_grammar (globalize_constr_expr vars) e) - (**********) (* Tokens *) @@ -76,21 +75,16 @@ let make_terminal_status = function | VTerm s -> Some s | VNonTerm _ -> None -let qualified_nterm current_univ = function - | NtQual (univ, en) -> (univ, en) - | NtShort en -> (current_univ, en) - let rec make_tags lev = function | VTerm s :: l -> make_tags lev l | VNonTerm (loc, nt, po) :: l -> - let (u,nt) = qualified_nterm "tactic" nt in - let (etyp, _) = Egrammar.interp_entry_name lev u nt in + let (etyp, _) = Egrammar.interp_entry_name lev "tactic" nt in etyp :: make_tags lev l | [] -> [] let cache_tactic_notation (_,(pa,pp)) = Egrammar.extend_grammar (Egrammar.TacticGrammar pa); - Pptactic.declare_extra_tactic_pprule true (pi1 pp) (pi2 pp, pi3 pp) + Pptactic.declare_extra_tactic_pprule pp let subst_tactic_parule subst (key,n,p,(d,tac)) = (key,n,p,(d,Tacinterp.subst_tactic subst tac)) @@ -148,6 +142,17 @@ let print_grammar univ = function Gram.Entry.print Pcoq.Tactic.tactic_expr; msgnl (str "Entry simple_tactic is"); Gram.Entry.print Pcoq.Tactic.simple_tactic; + | "vernac" -> + msgnl (str "Entry vernac is"); + Gram.Entry.print Pcoq.Vernac_.vernac; + msgnl (str "Entry command is"); + Gram.Entry.print Pcoq.Vernac_.command; + msgnl (str "Entry syntax is"); + Gram.Entry.print Pcoq.Vernac_.syntax; + msgnl (str "Entry gallina is"); + Gram.Entry.print Pcoq.Vernac_.gallina; + msgnl (str "Entry gallina_ext is"); + Gram.Entry.print Pcoq.Vernac_.gallina_ext; | _ -> error "Unknown or unprintable grammar entry" (**********************************************************************) @@ -577,12 +582,12 @@ let make_production etyps symbols = let typ = List.assoc m etyps in NonTerm (typ, Some (m,typ)) :: l | Terminal s -> - Term (Extend.terminal s) :: l + Term (terminal s) :: l | Break _ -> l | SProdList (x,sl) -> let sl = List.flatten - (List.map (function Terminal s -> [Extend.terminal s] + (List.map (function Terminal s -> [terminal s] | Break _ -> [] | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in let y = match List.assoc x etyps with @@ -714,10 +719,6 @@ let interp_modifiers modl = interp assoc level etyps (Some s) l in interp None None [] None modl -let merge_modifiers a n l = - (match a with None -> [] | Some a -> [SetAssoc a]) @ - (match n with None -> [] | Some n -> [SetLevel n]) @ l - let interp_infix_modifiers modl = let (assoc,level,t,b,fmt) = interp_modifiers modl in if t <> [] then diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 869ba00d0..981f2437c 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -19,34 +19,40 @@ open Notation open Topconstr (*i*) -(* Adding parsing and pretty-printing rules in the environment *) - val add_token_obj : string -> unit +(* Adding a tactic notation in the environment *) + val add_tactic_notation : int * grammar_production list * raw_tactic_expr -> unit +(* Adding a (constr) notation in the environment*) + val add_infix : locality_flag -> (string * syntax_modifier list) -> reference -> scope_name option -> unit +val add_notation : locality_flag -> constr_expr -> + (string * syntax_modifier list) -> scope_name option -> unit + +(* Declaring delimiter keys and default scopes *) + val add_delimiters : scope_name -> string -> unit val add_class_scope : scope_name -> Classops.cl_typ -> unit -val add_notation : locality_flag -> constr_expr -> - (string * syntax_modifier list) -> scope_name option -> unit +(* Add only the interpretation of a notation that already has pa/pp rules *) val add_notation_interpretation : string -> Constrintern.implicits_env -> constr_expr -> scope_name option -> unit +(* Add only the parsing/printing rule of a notation *) + val add_syntax_extension : locality_flag -> (string * syntax_modifier list) -> unit -val print_grammar : string -> string -> unit +(* Print the Camlp4 state of a grammar *) -val merge_modifiers : Gramext.g_assoc option -> int option -> - syntax_modifier list -> syntax_modifier list +val print_grammar : string -> string -> unit -val interp_infix_modifiers : syntax_modifier list -> - Gramext.g_assoc option * precedence option * bool * string located option +(* Removes quotes in a notation *) val standardize_locatable_notation : string -> string diff --git a/toplevel/record.ml b/toplevel/record.ml index 45f063232..2378edf6d 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -20,7 +20,6 @@ open Declarations open Entries open Declare open Nametab -open Coqast open Constrintern open Command open Inductive diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ea9bce69e..9232584cc 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -15,7 +15,6 @@ open Lexer open Util open Options open System -open Coqast open Vernacexpr open Vernacinterp open Ppvernacnew @@ -122,8 +121,7 @@ let pre_printing = function | VernacSolve (i,tac,deftac) when Options.do_translate () -> (try let (_,env) = Pfedit.get_goal_context i in - let t = Options.with_option Options.translate_syntax - (Tacinterp.glob_tactic_env_v7 [] env) tac in + let t = Tacinterp.glob_tactic_env [] env tac in let pfts = Pfedit.get_pftreestate () in let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in Some (env,t,Pfedit.focus(),List.length gls) @@ -148,9 +146,6 @@ let pr_new_syntax loc ocom = if !translate_file then set_formatter_translator(); let fs = States.freeze () in let com = match ocom with - | Some (VernacV7only _) -> - Options.v7_only := true; - mt() | Some VernacNop -> mt() | Some com -> pr_vernac com | None -> mt() in @@ -159,8 +154,6 @@ let pr_new_syntax loc ocom = else msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; - Constrintern.set_temporary_implicits_in []; - Constrextern.set_temporary_implicits_out []; Format.set_formatter_out_channel stdout let rec vernac_com interpfun (loc,com) = @@ -203,22 +196,10 @@ let rec vernac_com interpfun (loc,com) = msgnl (str"Finished transaction in " ++ System.fmt_time_difference tstart tend) - (* To be interpreted in v7 or translator input only *) - | VernacV7only v -> - Options.v7_only := true; - if !Options.v7 || Options.do_translate() then interp v; - Options.v7_only := false - - (* To be interpreted in translator output only *) - | VernacV8only v -> - if not !Options.v7 && not (do_translate()) then - interp v - | v -> if not !just_parsing then interpfun v in try - Options.v7_only := false; if do_translate () then match pre_printing com with None -> @@ -235,7 +216,6 @@ let rec vernac_com interpfun (loc,com) = interp com with e -> Format.set_formatter_out_channel stdout; - Options.v7_only := false; raise (DuringCommandInterp (loc, e)) and vernac interpfun input = diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fb9bb4496..4be7c9305 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -501,45 +501,9 @@ let vernac_end_segment id = | _,Lib.OpenedSection _ -> vernac_end_section id | _ -> anomaly "No more opened things" - -let is_obsolete_module (_,qid) = - match repr_qualid qid with - | dir, id when dir = empty_dirpath -> - (match string_of_id id with - | ("Refine" | "Inv" | "Equality" | "EAuto" | "AutoRewrite" - | "EqDecide" | "Xml" | "Extraction" | "Tauto" | "Setoid_replace" - | "Elimdep" - | "DatatypesSyntax" | "LogicSyntax" | "Logic_TypeSyntax" - | "SpecifSyntax" | "PeanoSyntax" | "TypeSyntax" | "PolyListSyntax") - -> true - | _ -> false) - | _ -> false - -let test_renamed_module (_,qid) = - match repr_qualid qid with - | dir, id when dir = empty_dirpath -> - (match string_of_id id with - | "List" -> warning "List has been renamed into MonoList" - | "PolyList" -> warning "PolyList has been renamed into List and old List into MonoList" - | _ -> ()) - | _ -> () - let vernac_require import _ qidl = let qidl = List.map qualid_of_reference qidl in - try - Library.require_library qidl import - with e -> - (* Compatibility message *) - let qidl' = List.filter is_obsolete_module qidl in - if qidl' = qidl then - List.iter - (fun (_,qid) -> - warning ("Module "^(string_of_qualid qid)^ - " is now built-in and shouldn't be required")) qidl - else - (if not !Options.v7 then List.iter test_renamed_module qidl; - raise e) - + Library.require_library qidl import let vernac_canonical locqid = Recordops.declare_canonical_structure (Nametab.global locqid) @@ -698,13 +662,11 @@ let _ = optread = Impargs.is_implicit_args; optwrite = Impargs.make_implicit_args } -let impargs = if !Options.v7 then "Implicits" else "Implicit" - let _ = declare_bool_option - { optsync = false; (* synchronisation is in Impargs *) + { optsync = true; optname = "strict implicit arguments"; - optkey = (SecondaryTable ("Strict",impargs)); + optkey = (SecondaryTable ("Strict","Implicit")); optread = Impargs.is_strict_implicit_args; optwrite = Impargs.make_strict_implicit_args } @@ -712,7 +674,7 @@ let _ = declare_bool_option { optsync = true; optname = "contextual implicit arguments"; - optkey = (SecondaryTable ("Contextual",impargs)); + optkey = (SecondaryTable ("Contextual","Implicit")); optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } @@ -728,7 +690,7 @@ let _ = declare_bool_option { optsync = true; optname = "implicit arguments printing"; - optkey = (SecondaryTable ("Printing",impargs)); + optkey = (SecondaryTable ("Printing","Implicit")); optread = (fun () -> !Constrextern.print_implicits); optwrite = (fun b -> Constrextern.print_implicits := b) } @@ -744,7 +706,7 @@ let _ = declare_bool_option { optsync = true; optname = "notations printing"; - optkey = (SecondaryTable ("Printing",if !Options.v7 then "Symbols" else "Notations")); + optkey = (SecondaryTable ("Printing","Notations")); optread = (fun () -> not !Constrextern.print_no_symbol); optwrite = (fun b -> Constrextern.print_no_symbol := not b) } @@ -1099,7 +1061,6 @@ let vernac_debug b = let interp c = match c with (* Control (done in vernac) *) | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false - | (VernacV7only _ | VernacV8only _) -> assert false (* Syntax *) | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e) diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index ab05f7d0d..a0ea22413 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -160,6 +160,10 @@ type local_decl_expr = type module_binder = bool option * lident list * module_type_ast +type grammar_production = + | VTerm of string + | VNonTerm of loc * string * Names.identifier option + type proof_end = | Admitted | Proved of opacity_flag * (lident * theorem_kind option) option @@ -283,10 +287,6 @@ type vernac_expr = (* Toplevel control *) | VernacToplevelControl of exn - (* For translation from V7 to V8 syntax *) - | VernacV8only of vernac_expr - | VernacV7only of vernac_expr - (* For extension *) | VernacExtend of string * raw_generic_argument list diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index bacd8fab2..fc9ed778a 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -15,10 +15,7 @@ open Libnames open Himsg open Proof_type open Tacinterp -open Coqast open Vernacexpr -open Ast -open Extend let disable_drop e = if e <> Drop then e diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 636704571..42eec8c03 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -141,7 +141,7 @@ let rec uri_of_constr c = uri_of_constr b; url_string " in "; uri_of_constr c | RCast (_,c,_,t) -> uri_of_constr c; url_string ":"; uri_of_constr t - | RRec _ | RIf _ | RLetTuple _ | ROrderedCase _ | RCases _ -> + | RRec _ | RIf _ | RLetTuple _ | RCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint" | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ -> anomaly "Written w/o parenthesis" diff --git a/translate/ppconstrnew.ml b/translate/ppconstrnew.ml index 422b25343..2d6dd5f70 100644 --- a/translate/ppconstrnew.ml +++ b/translate/ppconstrnew.ml @@ -9,22 +9,18 @@ (* $Id$ *) (*i*) -open Ast open Util open Pp open Nametab open Names open Nameops open Libnames -open Coqast open Ppextend open Topconstr open Term open Pattern (*i*) -let pr_id id = Nameops.pr_id (Constrextern.v7_to_v8_id id) - let sep_p = fun _ -> str"." let sep_v = fun _ -> str"," ++ spc() let sep_pp = fun _ -> str":" @@ -141,6 +137,8 @@ let pr_opt_type_spc pr = function | CHole _ -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t +let pr_id = pr_id + let pr_name = function | Anonymous -> str"_" | Name id -> pr_id id @@ -258,10 +256,7 @@ let rec extract_lam_binders = function LocalRawAssum (nal,t) :: bl, c | c -> [], c -let pr_global vars ref = - (* pr_global_env vars ref *) - let s = string_of_qualid (Constrextern.shortest_qualid_of_v7_global vars ref) in - (str s) +let pr_global vars ref = pr_global_env vars ref let split_lambda = function | CLambdaN (loc,[[na],t],c) -> (na,t,c) @@ -531,7 +526,7 @@ let rec pr sep inherited a = else p, lproj | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp - | CCases (_,(po,rtntypopt),c,eqns) -> + | CCases (_,rtntypopt,c,eqns) -> v 0 (hv 0 (str "match" ++ brk (1,2) ++ hov 0 ( @@ -561,36 +556,6 @@ let rec pr sep inherited a = hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), lif - | COrderedCase (_,st,po,c,[b1;b2]) when st = IfStyle -> - (* On force les parenthèses autour d'un "if" sous-terme (même si le - parsing est lui plus tolérant) *) - hv 0 ( - hov 1 (str "if " ++ pr mt ltop c ++ - pr_return_type (pr mt) po) ++ spc () ++ - hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++ - hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), - lif - | COrderedCase (_,st,po,c,[CLambdaN(_,[nal,_],b)]) when st = LetStyle -> - hv 0 ( - str "let " ++ - hov 0 (str "(" ++ - prlist_with_sep sep_v (fun (_,n) -> pr_name n) nal ++ - str ")" ++ - pr_return_type (pr mt) po ++ str " :=" ++ - pr spc ltop c ++ str " in") ++ - pr spc ltop b), - lletin - - | COrderedCase (_,style,po,c,bl) -> - hv 0 ( - str (if style=MatchStyle then "old_match " else "match ") ++ - pr mt ltop c ++ - pr_return_type (pr_dangling_with_for mt) po ++ - str " with" ++ brk (1,0) ++ - hov 0 (prlist - (fun b -> str "| ??? =>" ++ pr spc ltop b ++ fnl ()) bl) ++ - str "end"), - latom | CHole _ -> str "_", latom | CEvar (_,n) -> str (Evd.string_of_existential n), latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom @@ -663,53 +628,15 @@ let rec strip_context n iscast t = LocalRawDef (na,b) :: bl', c | _ -> anomaly "ppconstrnew: strip_context" -let transf istype env iscast bl c = - let c' = - if istype then prod_constr_expr c bl - else abstract_constr_expr c bl in - if Options.do_translate() then - let r = - Constrintern.for_grammar - (Constrintern.intern_gen istype Evd.empty env) c' in - begin try - (* Try to infer old case and type annotations *) - let _ = Pretyping.understand_tcc Evd.empty env r in - (*msgerrnl (str "Typage OK");*) () - with e -> (*msgerrnl (str "Warning: can't type")*) () end; - let c = - (if istype then Constrextern.extern_rawtype - else Constrextern.extern_rawconstr) - (Termops.vars_of_env env) r in - let n = local_binders_length bl in - strip_context n iscast c - else bl, c - -let pr_constr_env env c = pr lsimple (snd (transf false env false [] c)) -let pr_lconstr_env env c = pr ltop (snd (transf false env false [] c)) +let pr_constr_env env c = pr lsimple c +let pr_lconstr_env env c = pr ltop c let pr_constr c = pr_constr_env (Global.env()) c let pr_lconstr c = pr_lconstr_env (Global.env()) c let pr_binders = pr_undelimited_binders (pr ltop) -let is_Eval_key c = - Options.do_translate () & - (let f id = let s = string_of_id id in s = "Eval" in - let g = function - | Ident(_,id) -> f id - | Qualid (_,qid) -> let d,id = repr_qualid qid in d = empty_dirpath & f id - in - match c with - | CRef ref | CApp (_,(_,CRef ref),_) when g ref -> true - | _ -> false) - -let pr_protect_eval c = - if is_Eval_key c then h 0 (str "(" ++ pr ltop c ++ str ")") else pr ltop c - -let pr_lconstr_env_n env iscast bl c = - let bl, c = transf false env iscast bl c in - bl, pr_protect_eval c -let pr_type_env_n env bl c = pr ltop (snd (transf true env false bl c)) -let pr_type c = pr ltop (snd (transf true (Global.env()) false [] c)) +let pr_lconstr_env_n env iscast bl c = bl, pr ltop c +let pr_type c = pr ltop c let transf_pattern env c = if Options.do_translate() then @@ -797,11 +724,6 @@ let rec pr_may_eval test prc prlc pr2 = function let pr_may_eval a = pr_may_eval (fun _ -> false) a -let pr_rawconstr_env_no_translate env c = - pr lsimple (Constrextern.extern_rawconstr (Termops.vars_of_env env) c) -let pr_lrawconstr_env_no_translate env c = - pr ltop (Constrextern.extern_rawconstr (Termops.vars_of_env env) c) - (* Printing reference with translation *) let pr_reference r = @@ -839,130 +761,3 @@ let pr_constr_pattern_env env c = let pr_constr_pattern t = pr lsimple (Constrextern.extern_pattern (Global.env()) Termops.empty_names_context t) - - -(************************************************************************) -(* Automatic standardisation of names in Arith and ZArith by translator *) -(* Very not robust *) - -let is_to_rename dir id = - let dirs = List.map string_of_id (repr_dirpath dir) in - match List.rev dirs with - | "Coq"::"Arith"::"Between"::_ -> false - | "Coq"::"ZArith":: - ("Wf_Z"|"Zpower"|"Zlogarithm"|"Zbinary"|"Zdiv"|"Znumtheory")::_ -> false - | "Coq"::("Arith"|"NArith"|"ZArith")::_ -> true - | "Coq"::"Init"::"Peano"::_ -> true - | "Coq"::"Init"::"Logic"::_ when string_of_id id = "iff_trans" -> true - | "Coq"::"Reals"::"RIneq"::_ -> true - | _ -> false - -let is_ref_to_rename ref = - let sp = sp_of_global ref in - is_to_rename (dirpath sp) (basename sp) - -let get_name (ln,lp,lz,ll,lr,lr') id refbase n = - let id' = string_of_id n in - (match id' with - | "nat" -> (id_of_string (List.hd ln),(List.tl ln,lp,lz,ll,lr,lr')) - | "positive" -> (id_of_string (List.hd lp),(ln,List.tl lp,lz,ll,lr,lr')) - | "Z" -> (id_of_string (List.hd lz),(ln,lp,List.tl lz,ll,lr,lr')) - | "Prop" when List.mem (string_of_id id) ["a";"b";"c"] -> - (* pour iff_trans *) - (id_of_string (List.hd ll),(ln,lp,lz,List.tl ll,lr,lr')) - | "R" when (* Noms r,r1,r2 *) - refbase = "Rle_refl" or - refbase = "Rlt_monotony_contra" or - refbase = "Rmult_le_reg_l" or - refbase = "Rle_monotony_contra" or - refbase = "Rge_monotony" -> - (id_of_string (List.hd lr')),(ln,lp,lz,ll,lr,List.tl lr') - | "R" when (* Noms r1,r2,r3,r4 *) - List.mem (string_of_id id) - ["x";"y";"x'";"y'";"z";"t";"n";"m";"a";"b";"c";"p";"q"] - & refbase <> "sum_inequa_Rle_lt" - -> - (id_of_string (List.hd lr),(ln,lp,lz,ll,List.tl lr,lr')) - | _ -> id,(ln,lp,lz,ll,lr,lr')) - -let get_name_constr names id refbase t = match kind_of_term t with - | Ind ind -> - let n = basename (sp_of_global (IndRef ind)) in - get_name names id refbase n - | Const sp -> - let n = basename (sp_of_global (ConstRef sp)) in - get_name names id refbase n - | Sort _ -> get_name names id refbase (id_of_string "Prop") - | _ -> id,names - -let names = - (["n";"m";"p";"q"],["p";"q";"r";"s"],["n";"m";"p";"q"],["A";"B";"C"], - ["r1";"r2";"r3";"r4"],["r";"r1";"r2"]) - -let znames refbase t = - let rec aux c names = match kind_of_term c with - | Prod (Name id as na,t,c) -> - let (id,names) = get_name_constr names id refbase t in - (na,id) :: aux c names - | Prod (Anonymous,t,c) -> - (Anonymous,id_of_string "ZZ") :: aux c names - | _ -> [] - in aux t names - -let get_name_raw names id refbase t = match t with - | CRef(Ident (_,n)) -> get_name names id refbase n - | CSort _ -> get_name names id refbase (id_of_string "Prop") - | _ -> id,names - -let rename_bound_variables id0 t = - if is_to_rename (Lib.library_dp()) id0 then - let refbase = string_of_id id0 in - let rec aux c names subst = match c with - | CProdN (loc,bl,c) -> - let rec aux2 names subst = function - | (nal,t)::bl -> - let rec aux3 names subst = function - | (loc,Name id)::nal -> - let (id',names) = get_name_raw names id refbase t in - let (nal,names,subst) = aux3 names ((id,id')::subst) nal in - (loc,Name id')::nal, names, subst - | x::nal -> - let (nal,names,subst) = aux3 names subst nal in - x::nal,names,subst - | [] -> [],names,subst in - let t = replace_vars_constr_expr subst t in - let nal,names,subst = aux3 names subst nal in - let bl,names,subst = aux2 names subst bl in - (nal,t)::bl, names, subst - | [] -> [],names,subst in - let bl,names,subst = aux2 names subst bl in - CProdN (loc,bl,aux c names subst) - | CArrow (loc,t,u) -> - let u = aux u names subst in - CArrow (loc,replace_vars_constr_expr subst t,u) - | _ -> replace_vars_constr_expr subst c - in aux t names [] - else t - -let translate_binding kn n ebl = - let t = Retyping.get_type_of (Global.env()) Evd.empty (mkConst kn) in - let subst= znames (string_of_id (basename (sp_of_global (ConstRef kn)))) t in - try - let _,subst' = list_chop n subst in - List.map (function - | (x,NamedHyp id,c) -> (x,NamedHyp (List.assoc (Name id) subst'),c) - | x -> x) ebl - with _ -> ebl - -let translate_with_bindings c bl = - match bl with - | ExplicitBindings l -> - let l = match c with - | RRef (_,(ConstRef kn as ref)) when is_ref_to_rename ref -> - translate_binding kn 0 l - | RApp (_,RRef (_,(ConstRef kn as ref)),args) when is_ref_to_rename ref - -> translate_binding kn (List.length args) l - | _ -> - l - in ExplicitBindings l - | x -> x diff --git a/translate/ppconstrnew.mli b/translate/ppconstrnew.mli index 9ebdbfb8e..67cb51b5a 100644 --- a/translate/ppconstrnew.mli +++ b/translate/ppconstrnew.mli @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -14,8 +15,6 @@ open Term open Libnames open Pcoq open Rawterm -open Extend -open Coqast open Topconstr open Names open Util @@ -65,9 +64,6 @@ val pr_constr : constr_expr -> std_ppcmds val pr_lconstr : constr_expr -> std_ppcmds val pr_constr_env : env -> constr_expr -> std_ppcmds val pr_lconstr_env : env -> constr_expr -> std_ppcmds -val pr_lconstr_env_n : env -> bool -> local_binder list -> constr_expr -> - local_binder list * std_ppcmds -val pr_type_env_n : env -> local_binder list -> constr_expr -> std_ppcmds val pr_type : constr_expr -> std_ppcmds val pr_cases_pattern : cases_pattern_expr -> std_ppcmds val pr_may_eval : @@ -80,9 +76,6 @@ val prod_constr_expr : constr_expr -> local_binder list -> constr_expr val pr_rawconstr_env : env -> rawconstr -> std_ppcmds val pr_lrawconstr_env : env -> rawconstr -> std_ppcmds -val pr_rawconstr_env_no_translate : env -> rawconstr -> std_ppcmds -val pr_lrawconstr_env_no_translate : env -> rawconstr -> std_ppcmds - val pr_reference : reference -> std_ppcmds (** constr printers *) @@ -94,7 +87,3 @@ val pr_lterm : constr -> std_ppcmds val pr_constr_pattern_env : env -> Pattern.constr_pattern -> std_ppcmds val pr_constr_pattern : Pattern.constr_pattern -> std_ppcmds - -(* To translate names in ZArith *) -val translate_with_bindings : rawconstr -> 'a bindings -> 'a bindings -val rename_bound_variables : identifier -> constr_expr -> constr_expr diff --git a/translate/pptacticnew.ml b/translate/pptacticnew.ml index c7b01607f..64a960417 100644 --- a/translate/pptacticnew.ml +++ b/translate/pptacticnew.ml @@ -13,7 +13,6 @@ open Names open Nameops open Environ open Util -open Extend open Ppextend open Ppconstrnew open Tacexpr @@ -41,8 +40,8 @@ let strip_prod_binders_expr n ty = strip_ty [] n ty -(* In v8 syntax only double quote char is escaped by repeating it *) -let rec escape_string_v8 s = +(* In new syntax only double quote char is escaped by repeating it *) +let rec escape_string s = let rec escape_at s i = if i<0 then s else if s.[i] == '"' then @@ -51,116 +50,25 @@ let rec escape_string_v8 s = else escape_at s (i-1) in escape_at s (String.length s - 1) -let qstringnew s = str ("\""^escape_string_v8 s^"\"") -let qsnew = qstringnew - -let translate_v7_ltac = function - | "DiscrR" -> "discrR" - | "Sup0" -> "prove_sup0" - | "SupOmega" -> "omega_sup" - | "Sup" -> "prove_sup" - | "RCompute" -> "Rcompute" - | "IntroHypG" -> "intro_hyp_glob" - | "IntroHypL" -> "intro_hyp_pt" - | "IsDiff_pt" -> "is_diff_pt" - | "IsDiff_glob" -> "is_diff_glob" - | "IsCont_pt" -> "is_cont_pt" - | "IsCont_glob" -> "is_cont_glob" - | "RewTerm" -> "rew_term" - | "ConsProof" -> "deriv_proof" - | "SimplifyDerive" -> "simplify_derive" - | "Reg" -> "reg" (* ??? *) - | "SplitAbs" -> "split_case_Rabs" - | "SplitAbsolu" -> "split_Rabs" - | "SplitRmult" -> "split_Rmult" - | "CaseEqk" -> "case_eq" - | "SqRing" -> "ring_Rsqr" - | "TailSimpl" -> "tail_simpl" - | "CoInduction" -> "coinduction" - | "ElimCompare" -> "elim_compare" - | "CCsolve" -> "CCsolve" (* ?? *) - | "ArrayAccess" -> "array_access" - | "MemAssoc" -> "mem_assoc" - | "SeekVarAux" -> "seek_var_aux" - | "SeekVar" -> "seek_var" - | "NumberAux" -> "number_aux" - | "Number" -> "number" - | "BuildVarList" -> "build_varlist" - | "Assoc" -> "assoc" - | "Remove" -> "remove" - | "Union" -> "union" - | "RawGiveMult" -> "raw_give_mult" - | "GiveMult" -> "give_mult" - | "ApplyAssoc" -> "apply_assoc" - | "ApplyDistrib" -> "apply_distrib" - | "GrepMult" -> "grep_mult" - | "WeakReduce" -> "weak_reduce" - | "Multiply" -> "multiply" - | "ApplyMultiply" -> "apply_multiply" - | "ApplyInverse" -> "apply_inverse" - | "StrongFail" -> "strong_fail" - | "InverseTestAux" -> "inverse_test_aux" - | "InverseTest" -> "inverse_test" - | "ApplySimplif" -> "apply_simplif" - | "Unfolds" -> "unfolds" - | "Reduce" -> "reduce" - | "Field_Gen_Aux" -> "field_gen_aux" - | "Field_Gen" -> "field_gen" - | "EvalWeakReduce" -> "eval_weak_reduce" - | "Field_Term" -> "field_term" - | "Fourier" -> "fourier" (* ou Fourier ?? *) - | "FourierEq" -> "fourier_eq" - | "S_to_plus" -> "rewrite_S_to_plus_term" - | "S_to_plus_eq" -> "rewrite_S_to_plus" - | "NatRing" -> "ring_nat" - | "Solve1" -> "solve1" - | "Solve2" -> "solve2" - | "Elim_eq_term" -> "elim_eq_term" - | "Elim_eq_Z" -> "elim_eq_Z" - | "Elim_eq_pos" -> "elim_eq_pos" - | "Elim_Zcompare" -> "elim_Zcompare" - | "ProveStable" -> "prove_stable" - | "interp_A" -> "interp_A" - | "InitExp" -> "init_exp" - | "SimplInv" -> "simpl_inv" - | "Map" -> "map_tactic" - | "BuildMonomAux" -> "build_monom_aux" - | "BuildMonom" -> "build_monom" - | "SimplMonomAux" -> "simpl_monom_aux" - | "SimplMonom" -> "simpl_monom" - | "SimplAllMonoms" -> "simpl_all_monomials" - | "AssocDistrib" -> "assoc_distrib" - | "NowShow" -> "now_show" - | ("subst"|"simpl"|"elim"|"destruct"|"apply"|"intro" (* ... *)) as x -> - let x' = x^"_" in - msgerrnl - (str ("Warning: '"^ - x^"' is now a primitive tactic; it has been translated to '"^x'^"'")); - x' - | x -> x - -let id_of_ltac_v7_id id = - id_of_string (translate_v7_ltac (string_of_id id)) +let qstring s = str ("\""^escape_string s^"\"") +let qsnew = qstring let pr_ltac_or_var pr = function | ArgArg x -> pr x - | ArgVar (loc,id) -> - pr_with_comments loc (pr_id (id_of_ltac_v7_id id)) + | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) let pr_arg pr x = spc () ++ pr x let pr_ltac_constant sp = - (* Source de bug: le nom le plus court n'est pas forcement correct - apres renommage *) - let qid = Nametab.shortest_qualid_of_tactic sp in - let dir,id = repr_qualid qid in - pr_qualid (make_qualid dir (id_of_ltac_v7_id id)) + pr_qualid (Nametab.shortest_qualid_of_tactic sp) let pr_evaluable_reference_env env = function - | EvalVarRef id -> pr_id (Constrextern.v7_to_v8_id id) - | EvalConstRef sp -> pr_global (Termops.vars_of_env env) (Libnames.ConstRef sp) + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> + Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) -let pr_inductive vars ind = pr_global vars (Libnames.IndRef ind) +let pr_inductive env ind = + Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.IndRef ind) let pr_quantified_hypothesis = function | AnonHyp n -> int n @@ -168,12 +76,6 @@ let pr_quantified_hypothesis = function let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h -(* -let pr_binding prc = function - | NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) - | AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) -*) - let pr_esubst prc l = let pr_qhyp = function (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" @@ -196,12 +98,7 @@ let pr_bindings_gen for_ex prlc prc = function let pr_bindings prlc prc = pr_bindings_gen false prlc prc let pr_with_bindings prlc prc (c,bl) = - if Options.do_translate () then - (* translator calls pr_with_bindings on rawconstr: we cast it! *) - let bl' = translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in - hov 1 (prc c ++ pr_bindings prlc prc bl') - else - hov 1 (prc c ++ pr_bindings prlc prc bl) + hov 1 (prc c ++ pr_bindings prlc prc bl) let pr_with_constr prc = function | None -> mt () @@ -237,13 +134,6 @@ let pr_hyp_location pr_id = function | id, occs, InHypValueOnly -> spc () ++ pr_occs (str "(value of " ++ pr_id id ++ str ")") occs -let pr_hyp_location pr_id (id,occs,(hl,hl')) = - if !hl' <> None then pr_hyp_location pr_id (id,occs,out_some !hl') - else - (if hl = InHyp && Options.do_translate () then - msgerrnl (h 0 (str "Translator warning: Unable to detect if " ++ pr_id id ++ spc () ++ str "denotes a local definition")); - pr_hyp_location pr_id (id,occs,hl)) - let pr_in pp = spc () ++ hov 0 (str "in" ++ pp) let pr_simple_clause pr_id = function @@ -332,32 +222,6 @@ let pr_seq_body pr tl = prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ str " ]") -let pr_as_names_force force ids (pp,ids') = - pr_with_names - (if (!pp or force) & List.exists ((<>) (ref [])) ids' - then Some (IntroOrAndPattern (List.map (fun x -> !x) ids')) - else ids) - -let duplicate force nodup ids pr = function - | [] -> pr (pr_as_names_force force ids (ref false,[])) - | x::l when List.for_all (fun y -> snd x=snd y) l -> - pr (pr_as_names_force force ids x) - | l -> - if List.exists (fun (b,ids) -> !b) l & (force or - List.exists (fun (_,ids) -> ids <> (snd (List.hd l))) (List.tl l)) - then - if nodup then begin - msgerrnl - (h 0 (str "Translator warning: Unable to enforce v7 names while translating Induction/NewDestruct/NewInduction. Names in the different branches are") ++ brk (0,0) ++ - hov 0 (prlist_with_sep spc - (fun id -> hov 0 (pr_as_names_force true ids id)) - (List.rev l))); - pr (pr_as_names_force force ids (ref false,[])) - end - else - pr_seq_body (fun x -> pr (pr_as_names_force force ids x)) (List.rev l) - else pr (pr_as_names_force force ids (ref false,[])) - let pr_hintbases = function | None -> spc () ++ str "with *" | Some [] -> mt () @@ -403,15 +267,26 @@ let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq open Closure -let make_pr_tac (pr_tac_level,pr_constr,pr_lconstr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend,strip_prod_binders) = +let make_pr_tac + (pr_tac_level,pr_constr,pr_lconstr,pr_pat, + pr_cst,pr_ind,pr_ref,pr_ident, + pr_extend,strip_prod_binders) = + +let pr_bindings env = + pr_bindings (pr_lconstr env) (pr_constr env) in +let pr_ex_bindings env = + pr_bindings_gen true (pr_lconstr env) (pr_constr env) in +let pr_with_bindings env = + pr_with_bindings (pr_lconstr env) (pr_constr env) in +let pr_eliminator env cb = + str "using" ++ pr_arg (pr_with_bindings env) cb in +let pr_extend env = + pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) in +let pr_red_expr env = + pr_red_expr (pr_constr env,pr_lconstr env,pr_cst env) in -let pr_bindings env = pr_bindings (pr_lconstr env) (pr_constr env) in -let pr_ex_bindings env = pr_bindings_gen true (pr_lconstr env) (pr_constr env) in -let pr_with_bindings env = pr_with_bindings (pr_lconstr env) (pr_constr env) in -let pr_eliminator env cb = str "using" ++ pr_arg (pr_with_bindings env) cb in let pr_constrarg env c = spc () ++ pr_constr env c in let pr_lconstrarg env c = spc () ++ pr_lconstr env c in - let pr_intarg n = spc () ++ int n in let pr_binder_fix env (nal,t) = @@ -467,8 +342,6 @@ let rec pr_atom0 env = function | TacAnyConstructor None -> str "constructor" | TacTrivial (Some []) -> str "trivial" | TacAuto (None,Some []) -> str "auto" -(* | TacAutoTDB None -> str "autotdb" - | TacDestructConcl -> str "dconcl"*) | TacReflexivity -> str "reflexivity" | t -> str "(" ++ pr_atom1 env t ++ str ")" @@ -480,12 +353,9 @@ and pr_atom1 env = function "LinearIntuition"),_) -> errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0") | TacExtend (loc,s,l) -> - pr_with_comments loc - (pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) 1 s l) + pr_with_comments loc (pr_extend env 1 s l) | TacAlias (loc,s,l,_) -> - pr_with_comments loc - (pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) 1 s - (List.map snd l)) + pr_with_comments loc (pr_extend env 1 s (List.map snd l)) (* Basic tactics *) | TacIntroPattern [] as t -> pr_atom0 env t @@ -529,17 +399,8 @@ and pr_atom1 env = function hov 1 (str"(" ++ pr_name na ++ str " :=" ++ pr_lconstrarg env c ++ str")")) | TacForward (true,Anonymous,c) -> - if Options.do_translate () then - (* Pose was buggy and was wrongly substituted in conclusion in v7 *) - hov 1 (str "set" ++ pr_constrarg env c) - else - hov 1 (str "pose" ++ pr_constrarg env c) + hov 1 (str "pose" ++ pr_constrarg env c) | TacForward (true,Name id,c) -> - if Options.do_translate () then - hov 1 (str "set" ++ spc() ++ - hov 1 (str"(" ++ pr_id id ++ str " :=" ++ - pr_lconstrarg env c ++ str")")) - else hov 1 (str "pose" ++ spc() ++ hov 1 (str"(" ++ pr_id id ++ str " :=" ++ pr_lconstrarg env c ++ str")")) @@ -567,25 +428,18 @@ and pr_atom1 env = function ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) *) (* Derived basic tactics *) - | TacSimpleInduction (h,l) -> - if List.exists (fun (pp,_) -> !pp) !l then - duplicate true true None (fun pnames -> - hov 1 (str "induction" ++ pr_arg pr_quantified_hypothesis h ++ - pnames)) !l - else + | TacSimpleInduction h -> hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h) - | TacNewInduction (h,e,(ids,l)) -> - duplicate false true ids (fun pnames -> + | TacNewInduction (h,e,ids) -> hov 1 (str "induction" ++ spc () ++ - pr_induction_arg (pr_constr env) h ++ pnames ++ - pr_opt (pr_eliminator env) e)) !l + pr_induction_arg (pr_constr env) h ++ pr_with_names ids ++ + pr_opt (pr_eliminator env) e) | TacSimpleDestruct h -> hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h) - | TacNewDestruct (h,e,(ids,l)) -> - duplicate false true ids (fun pnames -> + | TacNewDestruct (h,e,ids) -> hov 1 (str "destruct" ++ spc () ++ - pr_induction_arg (pr_constr env) h ++ pnames ++ - pr_opt (pr_eliminator env) e)) !l + pr_induction_arg (pr_constr env) h ++ pr_with_names ids ++ + pr_opt (pr_eliminator env) e) | TacDoubleInduction (h1,h2) -> hov 1 (str "double induction" ++ @@ -596,12 +450,12 @@ and pr_atom1 env = function | TacDecomposeOr c -> hov 1 (str "decompose sum" ++ pr_constrarg env c) | TacDecompose (l,c) -> - let vars = Termops.vars_of_env env in hov 1 (str "decompose" ++ spc () ++ - hov 0 (str "[" ++ prlist_with_sep spc (pr_ind vars) l + hov 0 (str "[" ++ prlist_with_sep spc (pr_ind env) l ++ str "]" ++ pr_constrarg env c)) | TacSpecialize (n,c) -> - hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ pr_with_bindings env c) + hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ + pr_with_bindings env c) | TacLApply c -> hov 1 (str "lapply" ++ pr_constrarg env c) @@ -611,16 +465,6 @@ and pr_atom1 env = function | TacAuto (None,Some []) as x -> pr_atom0 env x | TacAuto (n,db) -> hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ pr_hintbases db) -(* | TacAutoTDB None as x -> pr_atom0 env x - | TacAutoTDB (Some n) -> hov 0 (str "autotdb" ++ spc () ++ int n) - | TacDestructHyp (true,id) -> - hov 0 (str "cdhyp" ++ spc () ++ pr_lident id) - | TacDestructHyp (false,id) -> - hov 0 (str "dhyp" ++ spc () ++ pr_lident id) - | TacDestructConcl as x -> pr_atom0 env x - | TacSuperAuto (n,l,b1,b2) -> - hov 1 (str "superauto" ++ pr_opt int n ++ pr_autoarg_adding l ++ - pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2)*) | TacDAuto (n,p) -> hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ pr_opt int p) @@ -650,19 +494,17 @@ and pr_atom1 env = function hov 1 (str "constructor" ++ pr_arg (pr_tac_level env (latom,E)) t) | TacAnyConstructor None as t -> pr_atom0 env t | TacConstructor (n,l) -> - hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++ - pr_bindings env l) + hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings env l) (* Conversion *) | TacReduce (r,h) -> - hov 1 (pr_red_expr (pr_constr env,pr_lconstr env,pr_cst env) r ++ + hov 1 (pr_red_expr env r ++ pr_clauses pr_ident h) | TacChange (occ,c,h) -> hov 1 (str "change" ++ brk (1,1) ++ (match occ with None -> mt() - | Some([],c1) -> - hov 1 (pr_constr env c1 ++ spc() ++ str "with ") + | Some([],c1) -> hov 1 (pr_constr env c1 ++ spc() ++ str "with ") | Some(ocl,c1) -> hov 1 (pr_constr env c1 ++ spc() ++ str "at " ++ prlist_with_sep spc int ocl) ++ spc() ++ @@ -728,6 +570,7 @@ let rec pr_tac env inherited tac = ++ fnl() ++ str "end"), lmatch | TacFun (lvar,body) -> +(* let env = List.fold_right (option_fold_right Idset.add) lvar env in*) hov 2 (str "fun" ++ prlist pr_funvar lvar ++ str " =>" ++ spc () ++ pr_tac env (lfun,E) body), @@ -737,37 +580,15 @@ let rec pr_tac env inherited tac = pr_seq_body (pr_tac env ltop) tl), lseq | TacThen (t1,t2) -> - let pp2 = - (* Hook for translation names in induction/destruct *) - match t2 with - | TacAtom (_,TacSimpleInduction (h,l)) -> - if List.exists (fun (pp,ids) -> !pp) !l then - duplicate true false None (fun pnames -> - hov 1 - (str "induction" ++ pr_arg pr_quantified_hypothesis h ++ - pnames)) !l - else - hov 1 - (str "simple induction" ++ pr_arg pr_quantified_hypothesis h) - | TacAtom (_,TacNewInduction (h,e,(ids,l))) -> - duplicate false false ids (fun pnames -> - hov 1 (str "induction" ++ spc () ++ - pr_induction_arg (pr_constr env) h ++ pnames ++ - pr_opt (pr_eliminator env) e)) !l - | TacAtom (_,TacNewDestruct (h,e,(ids,l))) -> - duplicate false false ids (fun pnames -> - hov 1 (str "destruct" ++ spc () ++ - pr_induction_arg (pr_constr env) h ++ pnames ++ - pr_opt (pr_eliminator env) e)) !l - (* end hook *) - | _ -> pr_tac env (lseq,L) t2 in - hov 1 (pr_tac env (lseq,E) t1 ++ pr_then () ++ spc () ++ pp2), + hov 1 (pr_tac env (lseq,E) t1 ++ pr_then () ++ spc () ++ + pr_tac env (lseq,L) t2), lseq | TacTry t -> hov 1 (str "try" ++ spc () ++ pr_tac env (ltactical,E) t), ltactical | TacDo (n,t) -> - hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ pr_tac env (ltactical,E) t), + hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ + pr_tac env (ltactical,E) t), ltactical | TacRepeat t -> hov 1 (str "repeat" ++ spc () ++ pr_tac env (ltactical,E) t), @@ -785,18 +606,17 @@ let rec pr_tac env inherited tac = | TacFail (ArgArg 0,"") -> str "fail", latom | TacFail (n,s) -> str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ - (if s="" then mt() else (spc() ++ qsnew s)), latom + (if s="" then mt() else (spc() ++ qstring s)), latom | TacFirst tl -> str "first" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet | TacSolve tl -> str "solve" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet | TacId "" -> str "idtac", latom - | TacId s -> str "idtac" ++ (qsnew s), latom + | TacId s -> str "idtac" ++ (qstring s), latom | TacAtom (loc,TacAlias (_,s,l,_)) -> pr_with_comments loc - (pr_extend (pr_constr env) (pr_lconstr env) (pr_tac_level env) - (level_of inherited) s - (List.map snd l)), latom + (pr_extend env (level_of inherited) s (List.map snd l)), + latom | TacAtom (loc,t) -> pr_with_comments loc (hov 1 (pr_atom1 env t)), ltatom | TacArg(Tacexp e) -> pr_tac_level env (latom,E) e, latom @@ -804,7 +624,7 @@ let rec pr_tac env inherited tac = str "constr:" ++ pr_constr env c, latom | TacArg(ConstrMayEval c) -> pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c, leval - | TacArg(TacFreshId sopt) -> str "fresh" ++ pr_opt qsnew sopt, latom + | TacArg(TacFreshId sopt) -> str "fresh" ++ pr_opt qstring sopt, latom | TacArg(Integer n) -> int n, latom | TacArg(TacCall(loc,f,l)) -> pr_with_comments loc @@ -825,10 +645,10 @@ and pr_tacarg env = function | Reference r -> pr_ref r | ConstrMayEval c -> pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c - | TacFreshId sopt -> str "fresh" ++ pr_opt qsnew sopt + | TacFreshId sopt -> str "fresh" ++ pr_opt qstring sopt | TacExternal (_,com,req,la) -> - str "external" ++ spc() ++ qsnew com ++ spc() ++ qsnew req ++ spc() ++ - prlist_with_sep spc (pr_tacarg env) la + str "external" ++ spc() ++ qstring com ++ spc() ++ qstring req ++ + spc() ++ prlist_with_sep spc (pr_tacarg env) la | (TacCall _|Tacexp _|Integer _) as a -> str "ltac:" ++ pr_tac env (latom,E) (TacArg a) @@ -852,13 +672,15 @@ let strip_prod_binders_constr n ty = | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty +let drop_env f _env = f + let rec raw_printers = (pr_raw_tactic_level, - Ppconstrnew.pr_constr_env, - Ppconstrnew.pr_lconstr_env, + drop_env Ppconstrnew.pr_constr, + drop_env Ppconstrnew.pr_lconstr, Ppconstrnew.pr_pattern, - (fun _ -> pr_reference), - (fun _ -> pr_reference), + drop_env pr_reference, + drop_env pr_reference, pr_reference, pr_or_metaid pr_lident, Pptactic.pr_raw_extend, @@ -872,14 +694,13 @@ and pr_raw_match_rule env t = let pr_and_constr_expr pr (c,_) = pr c - let rec glob_printers = (pr_glob_tactic_level, - (fun env -> pr_and_constr_expr (Ppconstrnew.pr_rawconstr_env_no_translate env)), - (fun env -> pr_and_constr_expr (Ppconstrnew.pr_lrawconstr_env_no_translate env)), + (fun env -> pr_and_constr_expr (Ppconstrnew.pr_rawconstr_env env)), + (fun env -> pr_and_constr_expr (Ppconstrnew.pr_lrawconstr_env env)), (fun c -> Ppconstrnew.pr_constr_pattern_env (Global.env()) c), (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))), - (fun vars -> pr_or_var (pr_inductive vars)), + (fun env -> pr_or_var (pr_inductive env)), pr_ltac_or_var (pr_located pr_ltac_constant), pr_lident, Pptactic.pr_glob_extend, @@ -909,24 +730,13 @@ let pr_glob_tactic env = pr_glob_tactic_level env ltop let pr_tactic env = pr_tactic_level env ltop let _ = Tactic_debug.set_tactic_printer - (fun x -> - if !Options.v7 then Pptactic.pr_glob_tactic x - else pr_glob_tactic (Global.env()) x) + (fun x -> pr_glob_tactic (Global.env()) x) let _ = Tactic_debug.set_match_pattern_printer (fun env hyp -> - if !Options.v7 then - Pptactic.pr_match_pattern - (Printer.pr_pattern_env env (Termops.names_of_rel_context env)) hyp - else - pr_match_pattern - (Printer.pr_pattern_env env (Termops.names_of_rel_context env)) hyp) + pr_match_pattern + (Printer.pr_pattern_env env (Termops.names_of_rel_context env)) hyp) let _ = Tactic_debug.set_match_rule_printer (fun rl -> - if !Options.v7 then - Pptactic.pr_match_rule false - Printer.pr_pattern Pptactic.pr_glob_tactic rl - else - pr_match_rule false - (pr_glob_tactic (Global.env())) Printer.pr_pattern rl) + pr_match_rule false (pr_glob_tactic (Global.env())) Printer.pr_pattern rl) diff --git a/translate/pptacticnew.mli b/translate/pptacticnew.mli index 3dafb3615..fa959fdb4 100644 --- a/translate/pptacticnew.mli +++ b/translate/pptacticnew.mli @@ -28,5 +28,3 @@ val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds - -val id_of_ltac_v7_id : identifier -> identifier diff --git a/translate/ppvernacnew.ml b/translate/ppvernacnew.ml index 77b523333..ce07001de 100644 --- a/translate/ppvernacnew.ml +++ b/translate/ppvernacnew.ml @@ -18,10 +18,8 @@ open Vernacexpr open Ppconstrnew open Pptacticnew open Rawterm -open Coqast open Genarg open Pcoq -open Ast open Libnames open Ppextend open Topconstr @@ -52,7 +50,7 @@ let pr_lname = function (loc,Name id) -> pr_lident (loc,id) | lna -> pr_located pr_name lna -let pr_ltac_id id = Nameops.pr_id (id_of_ltac_v7_id id) +let pr_ltac_id = Nameops.pr_id let pr_module r = let update_ref s = match r with @@ -92,8 +90,9 @@ let pr_raw_tactic_env l env t = Pptacticnew.pr_glob_tactic env (Tacinterp.glob_tactic_env l env t) let pr_gen env t = - Pptactic.pr_raw_generic (Ppconstrnew.pr_constr_env env) - (Ppconstrnew.pr_lconstr_env env) + Pptactic.pr_raw_generic + Ppconstrnew.pr_constr + Ppconstrnew.pr_lconstr (Pptacticnew.pr_raw_tactic_level env) pr_reference t let pr_raw_tactic tac = @@ -141,19 +140,14 @@ let pr_set_entry_type = function | ETBigint -> str "bigint" | ETConstrList _ -> failwith "Internal entry type" -let pr_non_terminal = function - | NtQual (u,nt) -> (* no more qualified entries *) str nt - | NtShort "constrarg" -> str "constr" - | NtShort nt -> str nt - let strip_meta id = let s = string_of_id id in if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) else id let pr_production_item = function - | VNonTerm (loc,nt,Some p) -> pr_non_terminal nt ++ str"(" ++ pr_id (strip_meta p) ++ str")" - | VNonTerm (loc,nt,None) -> pr_non_terminal nt + | VNonTerm (loc,nt,Some p) -> str nt ++ str"(" ++ pr_id (strip_meta p) ++ str")" + | VNonTerm (loc,nt,None) -> str nt | VTerm s -> qsnew s let pr_comment pr_c = function @@ -292,26 +286,13 @@ let rec pr_module_expr = function pr_module_expr me1 ++ spc() ++ hov 1 (str"(" ++ pr_module_expr me2 ++ str")") -(* -let pr_opt_casted_constr pr_c = function - | CCast (loc,c,t) -> pr_c c ++ str":" ++ pr_c t - | _ as c -> pr_c c -*) - let pr_type_option pr_c = function | CHole loc -> mt() | _ as c -> brk(0,2) ++ str":" ++ pr_c c -let without_translation f x = - let old = Options.do_translate () in - let oldv7 = !Options.v7 in - Options.make_translate false; - try let r = f x in Options.make_translate old; Options.v7:=oldv7; r - with e -> Options.make_translate old; Options.v7:=oldv7; raise e - let pr_decl_notation prc = pr_opt (fun (ntn,c,scopt) -> fnl () ++ - str "where " ++ qsnew ntn ++ str " := " ++ without_translation prc c ++ + str "where " ++ qsnew ntn ++ str " := " ++ prc c ++ pr_opt (fun sc -> str ": " ++ str sc) scopt) let pr_vbinders l = @@ -321,7 +302,6 @@ let pr_binders_arg = pr_ne_sep spc pr_binders let pr_and_type_binders_arg bl = - let bl, _ = pr_lconstr_env_n (Global.env()) false bl (CHole dummy_loc) in pr_binders_arg bl let pr_onescheme (id,dep,ind,s) = @@ -422,7 +402,7 @@ let pr_paren_reln_or_extern = function | Some pprim,Any -> qsnew pprim | Some pprim,Prec p -> qsnew pprim ++ spc() ++ str":" ++ spc() ++ int p | _ -> mt() - +(* let rec pr_next_hunks = function | UNP_FNL -> str"FNL" | UNP_TAB -> str"TAB" @@ -444,7 +424,7 @@ let pr_syntax_rule (nm,s,u) = str nm ++ spc() ++ str"[" ++ pr_astpat s ++ str"]" let pr_syntax_entry (p,rl) = str"level" ++ spc() ++ int p ++ str" :" ++ fnl() ++ prlist_with_sep (fun _ -> fnl() ++ str"| ") pr_syntax_rule rl - +*) let pr_vernac_solve (i,env,tac,deftac) = (if i = 1 then mt() else int i ++ str ": ") ++ Pptacticnew.pr_glob_tactic env tac @@ -579,24 +559,14 @@ let rec pr_vernac = function pr_red_expr (pr_constr, pr_lconstr, pr_reference) r ++ str" in" ++ spc() in let pr_def_body = function - | DefineBody (bl,red,c,d) -> - let (bl2,body,ty) = match d with - | None -> - let bl2,body = extract_lam_binders c in - (bl2,body,mt()) - | Some ty -> - let bl2,body,ty' = extract_def_binders c ty in - (bl2,CCast (dummy_loc,body,Term.DEFAULTcast,ty'), - spc() ++ str":" ++ - pr_sep_com spc - (pr_type_env_n (Global.env()) (bl@bl2)) ty') in - let iscast = d <> None in - let bindings,ppred = - pr_lconstr_env_n (Global.env()) iscast (bl@bl2) body in - (pr_binders_arg bindings,ty,Some (pr_reduce red ++ ppred)) + | DefineBody (bl,red,body,d) -> + let ty = match d with + | None -> mt() + | Some ty -> spc() ++ str":" ++ pr_sep_com spc pr_lconstr ty + in + (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) | ProveBody (bl,t) -> - (pr_and_type_binders_arg bl, str" :" ++ pr_spc_type t, None) - in + (pr_binders_arg bl, str" :" ++ pr_spc_type t, None) in let (binds,typ,c) = pr_def_body b in hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++ (match c with @@ -608,7 +578,7 @@ let rec pr_vernac = function (match bl with | [] -> mt() | _ -> pr_binders bl ++ spc()) - ++ str":" ++ pr_spc_type (rename_bound_variables (snd id) c)) + ++ str":" ++ pr_spc_type c) | VernacEndProof Admitted -> str"Admitted" | VernacEndProof (Proved (opac,o)) -> (match o with | None -> if opac then str"Qed" else str"Defined" @@ -618,72 +588,16 @@ let rec pr_vernac = function | VernacExactProof c -> hov 2 (str"Proof" ++ pr_lconstrarg c) | VernacAssumption (stre,l) -> + let n = List.length (List.flatten (List.map fst (List.map snd l))) in hov 2 - (pr_assumption_token (List.length l > 1) stre ++ spc() ++ + (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_type l) | VernacInductive (f,l) -> - (* Copie simplifiée de command.ml pour recalculer les implicites, *) - (* les notations, et le contexte d'evaluation *) - let lparams = match l with [] -> assert false | (_,_,la,_,_)::_ -> la in - let sigma = Evd.empty - and env0 = Global.env() in - let (env_params,params) = - List.fold_left - (fun (env,params) d -> match d with - | LocalRawAssum (nal,t) -> - let t = Constrintern.interp_type sigma env t in - let ctx = list_map_i (fun i (_,na) -> (na,None,Term.lift i t)) 0 nal - in let ctx = List.rev ctx in - (Environ.push_rel_context ctx env, ctx@params) - | LocalRawDef ((_,na),c) -> - let c = Constrintern.interp_constr_judgment sigma env c in - let d = (na, Some c.Environ.uj_val, c.Environ.uj_type) in - (Environ.push_rel d env,d::params)) - (env0,[]) lparams in - - let (ind_env,ind_impls,arityl) = - List.fold_left - (fun (env, ind_impls, arl) ((_,recname), _, _, arityc, _) -> - let arity = Constrintern.interp_type sigma env_params arityc in - let fullarity = Termops.it_mkProd_or_LetIn arity params in - let env' = Termops.push_rel_assum (Name recname,fullarity) env in - let impls = - if Impargs.is_implicit_args() - then Impargs.compute_implicits false env_params fullarity - else [] in - (env', (recname,impls)::ind_impls, (arity::arl))) - (env0, [], []) l - in - let notations = - List.fold_right (fun (_,ntnopt,_,_,_) l ->option_cons ntnopt l) l [] in - let ind_env_params = Environ.push_rel_context params ind_env in - - let impl = List.map - (fun ((_,recname),_,_,arityc,_) -> - let arity = Constrintern.interp_type sigma env_params arityc in - let fullarity = - Termops.prod_it arity (List.map (fun (id,_,ty) -> (id,ty)) params) - in - let impl_in = - if Impargs.is_implicit_args() - then Impargs.compute_implicits false env_params fullarity - else [] in - let impl_out = - if Impargs.is_implicit_args_out() - then Impargs.compute_implicits true env_params fullarity - else [] in - (recname,impl_in,impl_out)) l in - let impls_in = List.map (fun (id,a,_) -> (id,a)) impl in - let impls_out = List.map (fun (id,_,a) -> (id,a)) impl in - Constrintern.set_temporary_implicits_in impls_in; - Constrextern.set_temporary_implicits_out impls_out; - (* Fin calcul implicites *) - let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ - pr_sep_com spc (pr_type_env_n ind_env_params []) c) in + pr_sep_com spc pr_type c) in let pr_constructor_list l = match l with | [] -> mt() | _ -> @@ -699,55 +613,12 @@ let rec pr_vernac = function str" :=") ++ pr_constructor_list lc ++ pr_decl_notation pr_constr ntn in - (* Copie simplifiée de command.ml pour déclarer les notations locales *) - List.iter (fun (df,c,scope) -> - Metasyntax.add_notation_interpretation df [] c scope) notations; - hov 1 (pr_oneind (if f then "Inductive" else "CoInductive") (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) | VernacFixpoint (recs,b) -> - - (* Copie simplifiée de command.ml pour recalculer les implicites *) - (* les notations, et le contexte d'evaluation *) - let sigma = Evd.empty - and env0 = Global.env() in - let notations = - List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) recs [] in - let impl = List.map - (fun ((recname,_, bl, arityc,_),_) -> - let arity = - Constrintern.interp_type sigma env0 - (prod_constr_expr arityc bl) in - let impl_in = - if Impargs.is_implicit_args() - then Impargs.compute_implicits false env0 arity - else [] in - let impl_out = - if Impargs.is_implicit_args_out() - then Impargs.compute_implicits true env0 arity - else [] in - (recname,impl_in,impl_out)) recs in - let impls_in = List.map (fun (id,a,_) -> (id,a)) impl in - let impls_out = List.map (fun (id,_,a) -> (id,a)) impl in - Constrintern.set_temporary_implicits_in impls_in; - Constrextern.set_temporary_implicits_out impls_out; - - (* Copie simplifiée de command.ml pour déclarer les notations locales *) - List.iter (fun (df,c,scope) -> - Metasyntax.add_notation_interpretation df [] c None) notations; - - let rec_sign = - List.fold_left - (fun env ((recname,_,bl,arityc,_),_) -> - let arity = - Constrintern.interp_type sigma env0 - (prod_constr_expr arityc bl) in - Environ.push_named (recname,None,arity) env) - (Global.env()) recs in - let name_of_binder = function | LocalRawAssum (nal,_) -> nal | LocalRawDef (_,_) -> [] in @@ -767,12 +638,9 @@ let rec pr_vernac = function if List.length ids > 1 then spc() ++ str "{struct " ++ pr_name name ++ str"}" else mt() in - let bl,ppc = - pr_lconstr_env_n rec_sign true bl - (CCast(dummy_loc,def,Term.DEFAULTcast,type_)) in pr_id id ++ pr_binders_arg bl ++ annot ++ spc() ++ pr_type_option (fun c -> spc() ++ pr_type c) type_ - ++ str" :=" ++ brk(1,1) ++ ppc ++ + ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ pr_decl_notation pr_constr ntn in let start = if b then "Boxed Fixpoint" else "Fixpoint" in @@ -1040,8 +908,6 @@ let rec pr_vernac = function (* For extension *) | VernacExtend (s,c) -> pr_extend s c - | VernacV7only _ -> mt() - | VernacV8only com -> pr_vernac com | VernacProof Tacexpr.TacId _ -> str "Proof" | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te @@ -1050,16 +916,6 @@ and pr_extend s cl = try pr_gen (Global.env()) a with Failure _ -> str ("<error in "^s^">") in try - (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *) - let s = - let n = String.length s in - if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "V7" - then String.sub s 0 (n-2) ^ "V8" - else s in - (* "Hint Rewrite in using" changes the order of its args in v8 !! *) - let cl = match s, cl with - | "HintRewriteV8", [a;b;c;d] -> [a;b;d;c] - | _ -> cl in let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in let (pp,_) = @@ -1072,7 +928,6 @@ and pr_extend s cl = | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args)) (mt(),cl) rl in hov 1 pp - ++ (if s = "Correctness" then sep_end () ++ fnl() ++ str "Proof" else mt()) with Not_found -> hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")") diff --git a/translate/ppvernacnew.mli b/translate/ppvernacnew.mli index 1b1639939..e76f1b579 100644 --- a/translate/ppvernacnew.mli +++ b/translate/ppvernacnew.mli @@ -15,13 +15,10 @@ open Names open Nameops open Nametab open Util -open Extend open Ppconstr open Pptactic open Rawterm -open Coqast open Pcoq -open Ast open Libnames open Ppextend open Topconstr |