diff options
Diffstat (limited to 'contrib/interface')
31 files changed, 0 insertions, 12081 deletions
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT deleted file mode 100644 index 23aeb6bb..00000000 --- a/contrib/interface/COPYRIGHT +++ /dev/null @@ -1,23 +0,0 @@ -(*****************************************************************************) -(* *) -(* Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq *) -(* *) -(* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *) -(* Copyright (C) 2006,2007 Lionel Elie Mamane *) -(* *) -(*****************************************************************************) - -The current directory contrib/interface implements Coq support for the -Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot -with contributions from Loïc Pottier and Laurence Rideau. - -Modifications by Lionel Elie Mamane <lionel@mamane.lu> for -generalising the protocol to suit other Coq interfaces. - -The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq) -is developed by the Lemme team at INRIA Sophia-Antipolis (see -http://www-sop.inria.fr/lemme) - -The files of the current directory are distributed under the terms of -the GNU Lesser General Public License Version 2.1. - diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli deleted file mode 100644 index 2eb2c381..00000000 --- a/contrib/interface/ascent.mli +++ /dev/null @@ -1,795 +0,0 @@ -type ct_AST = - CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT - | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING - | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE - | CT_astnode of ct_ID * ct_AST_LIST - | CT_astpath of ct_ID_LIST - | CT_astslam of ct_ID_OPT * ct_AST -and ct_AST_LIST = - CT_ast_list of ct_AST list -and ct_BINARY = - CT_binary of int -and ct_BINDER = - CT_coerce_DEF_to_BINDER of ct_DEF - | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA - | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA -and ct_BINDER_LIST = - CT_binder_list of ct_BINDER list -and ct_BINDER_NE_LIST = - CT_binder_ne_list of ct_BINDER * ct_BINDER list -and ct_BINDING = - CT_binding of ct_ID_OR_INT * ct_FORMULA -and ct_BINDING_LIST = - CT_binding_list of ct_BINDING list -and t_BOOL = - CT_false - | CT_true -and ct_CASE = - CT_case of string -and ct_CLAUSE = - CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT -and ct_COERCION_OPT = - CT_coerce_NONE_to_COERCION_OPT of ct_NONE - | CT_coercion_atm -and ct_COFIXTAC = - CT_cofixtac of ct_ID * ct_FORMULA -and ct_COFIX_REC = - CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA -and ct_COFIX_REC_LIST = - CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list -and ct_COFIX_TAC_LIST = - CT_cofix_tac_list of ct_COFIXTAC list -and ct_COMMAND = - CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST - | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD - | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN - | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL - | CT_abort of ct_ID_OPT_OR_ALL - | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST - | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT - | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_addpath of ct_STRING * ct_ID_OPT - | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST - | CT_bind_scope of ct_ID * ct_ID_NE_LIST - | CT_cd of ct_STRING_OPT - | CT_check of ct_FORMULA - | CT_class of ct_ID - | CT_close_scope of ct_ID - | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID - | CT_cofix_decl of ct_COFIX_REC_LIST - | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT - | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR - | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT - | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT - | CT_delim_scope of ct_ID * ct_ID - | CT_delpath of ct_STRING - | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE - | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID - | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE - | CT_explain_proof of ct_INT_LIST - | CT_explain_prooftree of ct_INT_LIST - | CT_export_id of ct_ID_NE_LIST - | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST - | CT_extraction of ct_ID_OPT - | CT_fix_decl of ct_FIX_REC_LIST - | CT_focus of ct_INT_OPT - | CT_go of ct_INT_OR_LOCN - | CT_guarded - | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST - | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM - | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST - | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_implicits of ct_ID * ct_ID_LIST_OPT - | CT_import_id of ct_ID_NE_LIST - | CT_ind_scheme of ct_SCHEME_SPEC_LIST - | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT - | CT_inline of ct_ID_NE_LIST - | CT_inspect of ct_INT - | CT_kill_node of ct_INT - | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING - | CT_local_close_scope of ct_ID - | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT - | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST - | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT - | CT_local_open_scope of ct_ID - | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST - | CT_locate of ct_ID - | CT_locate_file of ct_STRING - | CT_locate_lib of ct_ID - | CT_locate_notation of ct_STRING - | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST - | CT_ml_add_path of ct_STRING - | CT_ml_declare_modules of ct_STRING_NE_LIST - | CT_ml_print_modules - | CT_ml_print_path - | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR - | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT - | CT_no_inline of ct_ID_NE_LIST - | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE - | CT_open_scope of ct_ID - | CT_print - | CT_print_about of ct_ID - | CT_print_all - | CT_print_classes - | CT_print_ltac of ct_ID - | CT_print_coercions - | CT_print_grammar of ct_GRAMMAR - | CT_print_graph - | CT_print_hint of ct_ID_OPT - | CT_print_hintdb of ct_ID_OR_STAR - | CT_print_rewrite_hintdb of ct_ID - | CT_print_id of ct_ID - | CT_print_implicit of ct_ID - | CT_print_loadpath - | CT_print_module of ct_ID - | CT_print_module_type of ct_ID - | CT_print_modules - | CT_print_natural of ct_ID - | CT_print_natural_feature of ct_NATURAL_FEATURE - | CT_print_opaqueid of ct_ID - | CT_print_path of ct_ID * ct_ID - | CT_print_proof of ct_ID - | CT_print_setoids - | CT_print_scope of ct_ID - | CT_print_scopes - | CT_print_section of ct_ID - | CT_print_states - | CT_print_tables - | CT_print_universes of ct_STRING_OPT - | CT_print_visibility of ct_ID_OPT - | CT_proof of ct_FORMULA - | CT_proof_no_op - | CT_proof_with of ct_TACTIC_COM - | CT_pwd - | CT_quit - | CT_read_module of ct_ID - | CT_rec_ml_add_path of ct_STRING - | CT_recaddpath of ct_STRING * ct_ID_OPT - | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST - | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING - | CT_reserve of ct_ID_NE_LIST * ct_FORMULA - | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST - | CT_reset of ct_ID - | CT_reset_section of ct_ID - | CT_restart - | CT_restore_state of ct_ID - | CT_resume of ct_ID_OPT - | CT_save of ct_THM_OPT * ct_ID_OPT - | CT_scomments of ct_SCOMMENT_CONTENT_LIST - | CT_search of ct_ID * ct_IN_OR_OUT_MODULES - | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES - | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_section_end of ct_ID - | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND - | CT_set_natural of ct_ID - | CT_set_natural_default - | CT_set_option of ct_TABLE - | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE - | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST - | CT_sethyp of ct_INT - | CT_setundo of ct_INT - | CT_show_existentials - | CT_show_goal of ct_INT_OPT - | CT_show_implicit of ct_INT - | CT_show_intro - | CT_show_intros - | CT_show_node - | CT_show_proof - | CT_show_proofs - | CT_show_script - | CT_show_tree - | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT - | CT_strategy of ct_LEVEL_LIST - | CT_suspend - | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT - | CT_tactic_definition of ct_TAC_DEF_NE_LIST - | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT - | CT_time of ct_COMMAND - | CT_undo of ct_INT_OPT - | CT_unfocus - | CT_unset_option of ct_TABLE - | CT_unsethyp - | CT_unsetundo - | CT_user_vernac of ct_ID * ct_VARG_LIST - | CT_variable of ct_VAR * ct_BINDER_NE_LIST - | CT_write_module of ct_ID * ct_STRING_OPT -and ct_LEVEL_LIST = - CT_level_list of (ct_LEVEL * ct_ID_LIST) list -and ct_LEVEL = - CT_Opaque - | CT_Level of ct_INT - | CT_Expand -and ct_COMMAND_LIST = - CT_command_list of ct_COMMAND * ct_COMMAND list -and ct_COMMENT = - CT_comment of string -and ct_COMMENT_S = - CT_comment_s of ct_COMMENT list -and ct_CONSTR = - CT_constr of ct_ID * ct_FORMULA - | CT_constr_coercion of ct_ID * ct_FORMULA -and ct_CONSTR_LIST = - CT_constr_list of ct_CONSTR list -and ct_CONTEXT_HYP_LIST = - CT_context_hyp_list of ct_PREMISE_PATTERN list -and ct_CONTEXT_PATTERN = - CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA - | CT_context of ct_ID_OPT * ct_FORMULA -and ct_CONTEXT_RULE = - CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM - | CT_def_context_rule of ct_TACTIC_COM -and ct_CONVERSION_FLAG = - CT_beta - | CT_delta - | CT_evar - | CT_iota - | CT_zeta -and ct_CONVERSION_FLAG_LIST = - CT_conversion_flag_list of ct_CONVERSION_FLAG list -and ct_CONV_SET = - CT_unf of ct_ID list - | CT_unfbut of ct_ID list -and ct_CO_IND = - CT_co_ind of string -and ct_DECL_NOTATION_OPT = - CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE - | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT -and ct_DEF = - CT_def of ct_ID_OPT * ct_FORMULA -and ct_DEFN = - CT_defn of string -and ct_DEFN_OR_THM = - CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN - | CT_coerce_THM_to_DEFN_OR_THM of ct_THM -and ct_DEF_BODY = - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN - | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD - | CT_type_of of ct_FORMULA -and ct_DEF_BODY_OPT = - CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY - | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT -and ct_DEP = - CT_dep of string -and ct_DESTRUCTING = - CT_coerce_NONE_to_DESTRUCTING of ct_NONE - | CT_destructing -and ct_DESTRUCT_LOCATION = - CT_conclusion_location - | CT_discardable_hypothesis - | CT_hypothesis_location -and ct_DOTDOT_OPT = - CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE - | CT_dotdot -and ct_EQN = - CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA -and ct_EQN_LIST = - CT_eqn_list of ct_EQN list -and ct_EVAL_CMD = - CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA -and ct_FIXTAC = - CT_fixtac of ct_ID * ct_INT * ct_FORMULA -and ct_FIX_BINDER = - CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC - | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA -and ct_FIX_BINDER_LIST = - CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list -and ct_FIX_REC = - CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT * - ct_FORMULA * ct_FORMULA -and ct_FIX_REC_LIST = - CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list -and ct_FIX_TAC_LIST = - CT_fix_tac_list of ct_FIXTAC list -and ct_FORMULA = - CT_coerce_BINARY_to_FORMULA of ct_BINARY - | CT_coerce_ID_to_FORMULA of ct_ID - | CT_coerce_NUM_to_FORMULA of ct_NUM - | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE - | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA - | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST - | CT_arrowc of ct_FORMULA * ct_FORMULA - | CT_bang of ct_FORMULA - | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST - | CT_cofixc of ct_ID * ct_COFIX_REC_LIST - | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST - | CT_existvarc - | CT_fixc of ct_ID * ct_FIX_BINDER_LIST - | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA - | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA - | CT_labelled_arg of ct_ID * ct_FORMULA - | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA - | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA - | CT_letin of ct_DEF * ct_FORMULA - | CT_notation of ct_STRING * ct_FORMULA_LIST - | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA - | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA - | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST -and ct_FORMULA_LIST = - CT_formula_list of ct_FORMULA list -and ct_FORMULA_NE_LIST = - CT_formula_ne_list of ct_FORMULA * ct_FORMULA list -and ct_FORMULA_OPT = - CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA - | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT -and ct_FORMULA_OR_INT = - CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA - | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT -and ct_GRAMMAR = - CT_grammar_none -and ct_HYP_LOCATION = - CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD - | CT_intype of ct_ID * ct_INT_LIST - | CT_invalue of ct_ID * ct_INT_LIST -and ct_HYP_LOCATION_LIST_OR_STAR = - CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR - | CT_hyp_location_list of ct_HYP_LOCATION list -and ct_ID = - CT_ident of string - | CT_metac of ct_INT - | CT_metaid of string -and ct_IDENTITY_OPT = - CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE - | CT_identity -and ct_ID_LIST = - CT_id_list of ct_ID list -and ct_ID_LIST_LIST = - CT_id_list_list of ct_ID_LIST list -and ct_ID_LIST_OPT = - CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST - | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE -and ct_ID_NE_LIST = - CT_id_ne_list of ct_ID * ct_ID list -and ct_ID_NE_LIST_OR_STAR = - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST - | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR -and ct_ID_NE_LIST_OR_STRING = - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST - | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING -and ct_ID_OPT = - CT_coerce_ID_to_ID_OPT of ct_ID - | CT_coerce_NONE_to_ID_OPT of ct_NONE -and ct_ID_OPT_LIST = - CT_id_opt_list of ct_ID_OPT list -and ct_ID_OPT_NE_LIST = - CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list -and ct_ID_OPT_OR_ALL = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT - | CT_all -and ct_ID_OR_INT = - CT_coerce_ID_to_ID_OR_INT of ct_ID - | CT_coerce_INT_to_ID_OR_INT of ct_INT -and ct_ID_OR_INT_OPT = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT - | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT - | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT -and ct_ID_OR_STAR = - CT_coerce_ID_to_ID_OR_STAR of ct_ID - | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR -and ct_ID_OR_STRING = - CT_coerce_ID_to_ID_OR_STRING of ct_ID - | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING -and ct_ID_OR_STRING_NE_LIST = - CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list -and ct_IMPEXP = - CT_coerce_NONE_to_IMPEXP of ct_NONE - | CT_export - | CT_import -and ct_IND_SPEC = - CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT -and ct_IND_SPEC_LIST = - CT_ind_spec_list of ct_IND_SPEC list -and ct_INT = - CT_int of int -and ct_INTRO_PATT = - CT_coerce_ID_to_INTRO_PATT of ct_ID - | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list -and ct_INTRO_PATT_LIST = - CT_intro_patt_list of ct_INTRO_PATT list -and ct_INTRO_PATT_OPT = - CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT - | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT -and ct_INT_LIST = - CT_int_list of ct_INT list -and ct_INT_NE_LIST = - CT_int_ne_list of ct_INT * ct_INT list -and ct_INT_OPT = - CT_coerce_INT_to_INT_OPT of ct_INT - | CT_coerce_NONE_to_INT_OPT of ct_NONE -and ct_INT_OR_LOCN = - CT_coerce_INT_to_INT_OR_LOCN of ct_INT - | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN -and ct_INT_OR_NEXT = - CT_coerce_INT_to_INT_OR_NEXT of ct_INT - | CT_next_level -and ct_INV_TYPE = - CT_inv_clear - | CT_inv_regular - | CT_inv_simple -and ct_IN_OR_OUT_MODULES = - CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE - | CT_in_modules of ct_ID_NE_LIST - | CT_out_modules of ct_ID_NE_LIST -and ct_LET_CLAUSE = - CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE -and ct_LET_CLAUSES = - CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list -and ct_LET_VALUE = - CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY - | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM -and ct_LOCAL_OPT = - CT_coerce_NONE_to_LOCAL_OPT of ct_NONE - | CT_local -and ct_LOCN = - CT_locn of string -and ct_MATCHED_FORMULA = - CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA - | CT_formula_as of ct_FORMULA * ct_ID_OPT - | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA - | CT_formula_in of ct_FORMULA * ct_FORMULA -and ct_MATCHED_FORMULA_NE_LIST = - CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list -and ct_MATCH_PATTERN = - CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT - | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM - | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST - | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT - | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN - | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST -and ct_MATCH_PATTERN_LIST = - CT_match_pattern_list of ct_MATCH_PATTERN list -and ct_MATCH_PATTERN_NE_LIST = - CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list -and ct_MATCH_TAC_RULE = - CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE -and ct_MATCH_TAC_RULES = - CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list -and ct_MODIFIER = - CT_entry_type of ct_ID * ct_ID - | CT_format of ct_STRING - | CT_lefta - | CT_nona - | CT_only_parsing - | CT_righta - | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT - | CT_set_level of ct_INT -and ct_MODIFIER_LIST = - CT_modifier_list of ct_MODIFIER list -and ct_MODULE_BINDER = - CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE -and ct_MODULE_BINDER_LIST = - CT_module_binder_list of ct_MODULE_BINDER list -and ct_MODULE_EXPR = - CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT - | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR -and ct_MODULE_TYPE = - CT_coerce_ID_to_MODULE_TYPE of ct_ID - | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID_LIST * ct_FORMULA - | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID_LIST * ct_ID -and ct_MODULE_TYPE_CHECK = - CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT - | CT_only_check of ct_MODULE_TYPE -and ct_MODULE_TYPE_OPT = - CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT - | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE -and ct_NATURAL_FEATURE = - CT_contractible - | CT_implicit - | CT_nat_transparent -and ct_NONE = - CT_none -and ct_NUM = - CT_int_encapsulator of string -and ct_NUM_TYPE = - CT_num_type of string -and ct_OMEGA_FEATURE = - CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING - | CT_flag_action - | CT_flag_system - | CT_flag_time -and ct_OMEGA_MODE = - CT_set - | CT_switch - | CT_unset -and ct_ORIENTATION = - CT_lr - | CT_rl -and ct_PATTERN = - CT_pattern_occ of ct_INT_LIST * ct_FORMULA -and ct_PATTERN_NE_LIST = - CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list -and ct_PATTERN_OPT = - CT_coerce_NONE_to_PATTERN_OPT of ct_NONE - | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN -and ct_PREMISE = - CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA - | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA - | CT_premise of ct_ID * ct_FORMULA -and ct_PREMISES_LIST = - CT_premises_list of ct_PREMISE list -and ct_PREMISE_PATTERN = - CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN -and ct_PROOF_SCRIPT = - CT_proof_script of ct_COMMAND list -and ct_RECCONSTR = - CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT - | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT - | CT_recconstr of ct_ID_OPT * ct_FORMULA - | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA -and ct_RECCONSTR_LIST = - CT_recconstr_list of ct_RECCONSTR list -and ct_REC_TACTIC_FUN = - CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM -and ct_REC_TACTIC_FUN_LIST = - CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list -and ct_RED_COM = - CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET - | CT_fold of ct_FORMULA_LIST - | CT_hnf - | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET - | CT_pattern of ct_PATTERN_NE_LIST - | CT_red - | CT_cbvvm - | CT_simpl of ct_PATTERN_OPT - | CT_unfold of ct_UNFOLD_NE_LIST -and ct_RETURN_INFO = - CT_coerce_NONE_to_RETURN_INFO of ct_NONE - | CT_as_and_return of ct_ID_OPT * ct_FORMULA - | CT_return of ct_FORMULA -and ct_RULE = - CT_rule of ct_PREMISES_LIST * ct_FORMULA -and ct_RULE_LIST = - CT_rule_list of ct_RULE list -and ct_SCHEME_SPEC = - CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE -and ct_SCHEME_SPEC_LIST = - CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list -and ct_SCOMMENT_CONTENT = - CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA - | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING -and ct_SCOMMENT_CONTENT_LIST = - CT_scomment_content_list of ct_SCOMMENT_CONTENT list -and ct_SECTION_BEGIN = - CT_section of ct_ID -and ct_SECTION_BODY = - CT_section_body of ct_COMMAND list -and ct_SIGNED_INT = - CT_coerce_INT_to_SIGNED_INT of ct_INT - | CT_minus of ct_INT -and ct_SIGNED_INT_LIST = - CT_signed_int_list of ct_SIGNED_INT list -and ct_SINGLE_OPTION_VALUE = - CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT - | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING -and ct_SORT_TYPE = - CT_sortc of string -and ct_SPEC_LIST = - CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST - | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST -and ct_SPEC_OPT = - CT_coerce_NONE_to_SPEC_OPT of ct_NONE - | CT_spec -and ct_STAR = - CT_star -and ct_STAR_OPT = - CT_coerce_NONE_to_STAR_OPT of ct_NONE - | CT_coerce_STAR_to_STAR_OPT of ct_STAR -and ct_STRING = - CT_string of string -and ct_STRING_NE_LIST = - CT_string_ne_list of ct_STRING * ct_STRING list -and ct_STRING_OPT = - CT_coerce_NONE_to_STRING_OPT of ct_NONE - | CT_coerce_STRING_to_STRING_OPT of ct_STRING -and ct_TABLE = - CT_coerce_ID_to_TABLE of ct_ID - | CT_table of ct_ID * ct_ID -and ct_TACTIC_ARG = - CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD - | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT - | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM - | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE - | CT_void -and ct_TACTIC_ARG_LIST = - CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list -and ct_TACTIC_COM = - CT_abstract of ct_ID_OPT * ct_TACTIC_COM - | CT_absurd of ct_FORMULA - | CT_any_constructor of ct_TACTIC_OPT - | CT_apply of ct_FORMULA * ct_SPEC_LIST - | CT_assert of ct_ID_OPT * ct_FORMULA - | CT_assumption - | CT_auto of ct_INT_OPT - | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR - | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT - | CT_autotdb of ct_INT_OPT - | CT_case_type of ct_FORMULA - | CT_casetac of ct_FORMULA * ct_SPEC_LIST - | CT_cdhyp of ct_ID - | CT_change of ct_FORMULA * ct_CLAUSE - | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE - | CT_clear of ct_ID_NE_LIST - | CT_clear_body of ct_ID_NE_LIST - | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST - | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_constructor of ct_INT * ct_SPEC_LIST - | CT_contradiction - | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST - | CT_cut of ct_FORMULA - | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT - | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT - | CT_dauto of ct_INT_OPT * ct_INT_OPT - | CT_dconcl - | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA - | CT_decompose_record of ct_FORMULA - | CT_decompose_sum of ct_FORMULA - | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT - | CT_deprewrite_lr of ct_ID - | CT_deprewrite_rl of ct_ID - | CT_destruct of ct_ID_OR_INT - | CT_dhyp of ct_ID - | CT_discriminate_eq of ct_ID_OR_INT_OPT - | CT_do of ct_ID_OR_INT * ct_TACTIC_COM - | CT_eapply of ct_FORMULA * ct_SPEC_LIST - | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT - | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR - | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING - | CT_elim_type of ct_FORMULA - | CT_exact of ct_FORMULA - | CT_exact_no_check of ct_FORMULA - | CT_vm_cast_no_check of ct_FORMULA - | CT_exists of ct_SPEC_LIST - | CT_fail of ct_ID_OR_INT * ct_STRING_OPT - | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_firstorder of ct_TACTIC_OPT - | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST - | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST - | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST - | CT_formula_marker of ct_FORMULA - | CT_fresh of ct_STRING_OPT - | CT_generalize of ct_FORMULA_NE_LIST - | CT_generalize_dependent of ct_FORMULA - | CT_idtac of ct_STRING_OPT - | CT_induction of ct_ID_OR_INT - | CT_info of ct_TACTIC_COM - | CT_injection_eq of ct_ID_OR_INT_OPT - | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE - | CT_intro of ct_ID_OPT - | CT_intro_after of ct_ID_OPT * ct_ID - | CT_intros of ct_INTRO_PATT_LIST - | CT_intros_until of ct_ID_OR_INT - | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST - | CT_left of ct_SPEC_LIST - | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE - | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE - | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list - | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list - | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES - | CT_move_after of ct_ID * ct_ID - | CT_new_destruct of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT - | CT_new_induction of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT - | CT_omega - | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM - | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_pose of ct_ID_OPT * ct_FORMULA - | CT_progress of ct_TACTIC_COM - | CT_prolog of ct_FORMULA_LIST * ct_INT - | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM - | CT_reduce of ct_RED_COM * ct_CLAUSE - | CT_refine of ct_FORMULA - | CT_reflexivity - | CT_rename of ct_ID * ct_ID - | CT_repeat of ct_TACTIC_COM - | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT - | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE - | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE - | CT_right of ct_SPEC_LIST - | CT_ring of ct_FORMULA_LIST - | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST - | CT_simplify_eq of ct_ID_OR_INT_OPT - | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST - | CT_split of ct_SPEC_LIST - | CT_subst of ct_ID_LIST - | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB - | CT_symmetry of ct_CLAUSE - | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT - | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM - | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_transitivity of ct_FORMULA - | CT_trivial - | CT_trivial_with of ct_ID_NE_LIST_OR_STAR - | CT_truecut of ct_ID_OPT * ct_FORMULA - | CT_try of ct_TACTIC_COM - | CT_use of ct_FORMULA - | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST - | CT_user_tac of ct_ID * ct_TARG_LIST -and ct_TACTIC_OPT = - CT_coerce_NONE_to_TACTIC_OPT of ct_NONE - | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM -and ct_TAC_DEF = - CT_tac_def of ct_ID * ct_TACTIC_COM -and ct_TAC_DEF_NE_LIST = - CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list -and ct_TARG = - CT_coerce_BINDING_to_TARG of ct_BINDING - | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC - | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC - | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT - | CT_coerce_PATTERN_to_TARG of ct_PATTERN - | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT - | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST - | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE - | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST - | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM - | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST - | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD - | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST -and ct_TARG_LIST = - CT_targ_list of ct_TARG list -and ct_TERM_CHANGE = - CT_check_term of ct_FORMULA - | CT_inst_term of ct_ID * ct_FORMULA -and ct_TEXT = - CT_coerce_ID_to_TEXT of ct_ID - | CT_text_formula of ct_FORMULA - | CT_text_h of ct_TEXT list - | CT_text_hv of ct_TEXT list - | CT_text_op of ct_TEXT list - | CT_text_path of ct_SIGNED_INT_LIST - | CT_text_v of ct_TEXT list -and ct_THEOREM_GOAL = - CT_goal of ct_FORMULA - | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA -and ct_THM = - CT_thm of string -and ct_THM_OPT = - CT_coerce_NONE_to_THM_OPT of ct_NONE - | CT_coerce_THM_to_THM_OPT of ct_THM -and ct_TYPED_FORMULA = - CT_typed_formula of ct_FORMULA * ct_FORMULA -and ct_UNFOLD = - CT_coerce_ID_to_UNFOLD of ct_ID - | CT_unfold_occ of ct_ID * ct_INT_NE_LIST -and ct_UNFOLD_NE_LIST = - CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list -and ct_USING = - CT_coerce_NONE_to_USING of ct_NONE - | CT_using of ct_FORMULA * ct_SPEC_LIST -and ct_USINGTDB = - CT_coerce_NONE_to_USINGTDB of ct_NONE - | CT_usingtdb -and ct_VAR = - CT_var of string -and ct_VARG = - CT_coerce_AST_to_VARG of ct_AST - | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST - | CT_coerce_BINDER_to_VARG of ct_BINDER - | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST - | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST - | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST - | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT - | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT - | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL - | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT - | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST - | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT - | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT - | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT - | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST -and ct_VARG_LIST = - CT_varg_list of ct_VARG list -and ct_VERBOSE_OPT = - CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE - | CT_verbose -;; diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml deleted file mode 100644 index 483453cb..00000000 --- a/contrib/interface/blast.ml +++ /dev/null @@ -1,627 +0,0 @@ -(* Une tactique qui tente de démontrer toute seule le but courant, - interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A) -*) -open Termops;; -open Nameops;; -open Auto;; -open Clenv;; -open Command;; -open Declarations;; -open Declare;; -open Eauto;; -open Environ;; -open Equality;; -open Evd;; -open Hipattern;; -open Inductive;; -open Names;; -open Pattern;; -open Pbp;; -open Pfedit;; -open Pp;; -open Printer -open Proof_trees;; -open Proof_type;; -open Rawterm;; -open Reduction;; -open Refiner;; -open Sign;; -open String;; -open Tacmach;; -open Tacred;; -open Tacticals;; -open Tactics;; -open Term;; -open Typing;; -open Util;; -open Vernacentries;; -open Vernacinterp;; - - -let parse_com = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac t = - try (Pcoq.parse_string Pcoq.Tactic.tactic t) - with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t)); - failwith "tactic") -;; - -let is_free () = - let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in - let c=input_char st in - close_in st; - c = 'A' -;; - -(* marche pas *) -(* -let is_free () = - msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]); - let s = Stream.of_channel stdin in - msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]); - try (Stream.empty s; - msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]); - true) - with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]); - false) -;; -*) -let free_try tac g = - if is_free() - then (tac g) - else (failwith "not free") -;; -let adrel (x,t) e = - match x with - Name(xid) -> Environ.push_rel (x,None,t) e - | Anonymous -> Environ.push_rel (x,None,t) e -(* les constantes ayant une définition apparaissant dans x *) -let rec def_const_in_term_rec vl x = - match (kind_of_term x) with - Prod(n,t,c)-> - let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c - | Lambda(n,t,c) -> - let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c - | App(f,args) -> def_const_in_term_rec vl f - | Sort(Prop(Null)) -> Prop(Null) - | Sort(c) -> c - | Ind(ind) -> - let (mib, mip) = Global.lookup_inductive ind in - new_sort_in_family (inductive_sort_family mip) - | Construct(c) -> - def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) - -> def_const_in_term_rec vl x - | Cast(x,_,t)-> def_const_in_term_rec vl t - | Const(c) -> def_const_in_term_rec vl (Typeops.type_of_constant vl c) - | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x) -;; -let def_const_in_term_ x = - def_const_in_term_rec (Global.env()) (strip_outer_cast x) -;; -(************************************************************************* - recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli - modif de print_info_script avec pr_bar -*) - -let pr_bar () = str "|" - -let rec print_info_script sigma osign pf = - let {evar_hyps=sign; evar_concl=cl} = pf.goal in - match pf.ref with - | None -> (mt ()) - | Some(r,spfl) -> - Tactic_printer.pr_rule r ++ - match spfl with - | [] -> - (str " " ++ fnl()) - | [pf1] -> - if pf1.ref = None then - (str " " ++ fnl()) - else - (str";" ++ brk(1,3) ++ - print_info_script sigma sign pf1) - | _ -> ( str";[" ++ fnl() ++ - prlist_with_sep pr_bar - (print_info_script sigma sign) spfl ++ - str"]") - -let format_print_info_script sigma osign pf = - hov 0 (print_info_script sigma osign pf) - -let print_subscript sigma sign pf = - (* if is_tactic_proof pf then - format_print_info_script sigma sign (subproof_of_proof pf) - else *) - format_print_info_script sigma sign pf -(****************) - -let pp_string x = - msgnl_with Format.str_formatter x; - Format.flush_str_formatter () -;; - -(*********************************************************************** - copié de tactics/eauto.ml -*) - -(***************************************************************************) -(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) -(***************************************************************************) - -let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) - -let unify_e_resolve (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false clenv' gls in - Hiddentac.h_simplest_eapply c gls - -let rec e_trivial_fail_db db_list local_db goal = - let tacl = - registered_e_assumption :: - (tclTHEN Tactics.intro - (function g'-> - let d = pf_last_hyp g' in - let hintl = make_resolve_hyp (pf_env g') (project g') d in - (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: - (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -and e_my_find_search db_list local_db hdc concl = - let hdc = head_of_constr_reference hdc in - let hintl = - if occur_existential concl then - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, ({pri=b; pat = p; code=t} as _patac)) -> - (b, - let tac = - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve (term,cl) - | Give_exact (c) -> e_give_exact_constr c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> Auto.conclPattern concl p tacast - in - (free_try tac,pr_autotactic t)) - (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); - try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); - raise e) - i*) - in - List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) - with Bound | Not_found -> [] - -let e_possible_resolve db_list local_db gl = - try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) - with Bound | Not_found -> [] - -let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) - -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -(*s The following module [SearchProblem] is used to instantiate the generic - exploration functor [Explore.Make]. *) - -module MySearchProblem = struct - - type state = { - depth : int; (*r depth of search before failing *) - tacres : goal list sigma * validation; - last_tactic : std_ppcmds; - dblist : Auto.hint_db list; - localdb : Auto.hint_db list } - - let success s = (sig_it (fst s.tacres)) = [] - - let rec filter_tactics (glls,v) = function - | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in - let v' p = v (ptl p) in - ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl - with e when Logic.catchable_exception e -> - filter_tactics (glls,v) tacl - - (* Ordering of states is lexicographic on depth (greatest first) then - number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let nbgoals s = List.length (sig_it (fst s.tacres)) in - if d <> 0 then d else nbgoals s - nbgoals s' - - let branching s = - if s.depth = 0 then - [] - else - let lg = fst s.tacres in - let nbgl = List.length (sig_it lg) in - assert (nbgl > 0); - let g = find_first_goal lg in - let assumption_tacs = - let l = - filter_tactics s.tacres - (List.map - (fun id -> (e_give_exact_constr (mkVar id), - (str "Exact" ++ spc()++ pr_id id))) - (pf_ids_of_hyps g)) - in - List.map (fun (res,pp) -> { depth = s.depth; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb }) l - in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) - in - let rec_tacs = - let l = - filter_tactics s.tacres - (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) - in - List.map - (fun ((lgls,_) as res, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; tacres = res; last_tactic = pp; - dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; - dblist = s.dblist; last_tactic = pp; - localdb = - list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) - l - in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - - let pp s = - msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ - s.last_tactic ++ str "\n")) - -end - -module MySearch = Explore.Make(MySearchProblem) - -let make_initial_state n gl dblist localdb = - { MySearchProblem.depth = n; - MySearchProblem.tacres = tclIDTAC gl; - MySearchProblem.last_tactic = (mt ()); - MySearchProblem.dblist = dblist; - MySearchProblem.localdb = [localdb] } - -let e_depth_search debug p db_list local_db gl = - try - let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in - let s = tac (make_initial_state p gl db_list local_db) in - s.MySearchProblem.tacres - with Not_found -> error "EAuto: depth first search failed" - -let e_breadth_search debug n db_list local_db gl = - try - let tac = - if debug then MySearch.debug_breadth_first else MySearch.breadth_first - in - let s = tac (make_initial_state n gl db_list local_db) in - s.MySearchProblem.tacres - with Not_found -> error "EAuto: breadth first search failed" - -let e_search_auto debug (n,p) db_list gl = - let local_db = make_local_hint_db true [] gl in - if n = 0 then - e_depth_search debug p db_list local_db gl - else - e_breadth_search debug n db_list local_db gl - -let eauto debug np dbnames = - let db_list = - List.map - (fun x -> - try searchtable_map x - with Not_found -> error ("EAuto: "^x^": No such Hint database")) - ("core"::dbnames) - in - tclTRY (e_search_auto debug np db_list) - -let full_eauto debug n gl = - let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map searchtable_map dbnames in - let _local_db = make_local_hint_db true [] gl in - tclTRY (e_search_auto debug n db_list) gl - -let my_full_eauto n gl = full_eauto false (n,0) gl - -(********************************************************************** - copié de tactics/auto.ml on a juste modifié search_gen -*) - -(* local_db is a Hint database containing the hypotheses of current goal *) -(* Papageno : cette fonction a été pas mal simplifiée depuis que la base - de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) - -let rec trivial_fail_db db_list local_db gl = - let intro_tac = - tclTHEN intro - (fun g'-> - let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') - in - tclFIRST - (assumption::intro_tac:: - (List.map tclCOMPLETE - (trivial_resolve db_list local_db (pf_concl gl)))) gl - -and my_find_search db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - List.map - (fun (st, {pri=b; pat=p; code=t} as _patac) -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve st (term,cl)) - (trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl p tacast)) - tacl - -and trivial_resolve db_list local_db cl = - try - let hdconstr = fst (head_constr_bound cl) in - priority - (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> - [] - -(**************************************************************************) -(* The classical Auto tactic *) -(**************************************************************************) - -let possible_resolve db_list local_db cl = - try - let hdconstr = fst (head_constr_bound cl) in - List.map snd - (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> - [] - -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let t = head_constr typc in - if Hipattern.is_conjunction (applist t) then - simplest_case c gls - else - errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") - -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls - else - errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") - - -(* decomp is an natural number giving an indication on decomposition - of conjunction in hypotheses, 0 corresponds to no decomposition *) -(* n is the max depth of search *) -(* local_db contains the local Hypotheses *) - -let rec search_gen decomp n db_list local_db extra_sign goal = - if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> - (tclTRY_sign decomp_empty_term extra_sign) - :: - (List.map - (fun id -> tclTHEN (decomp_unary_term (mkVar id)) - (tclTHEN - (clear [id]) - (free_try (search_gen decomp p db_list local_db [])))) - (pf_ids_of_hyps goal)) - in - let intro_tac = - tclTHEN intro - (fun g' -> - let (hid,_,htyp as d) = pf_last_hyp g' in - let hintl = - try - [make_apply_entry (pf_env g') (project g') - (true,true,false) - None - (mkVar hid,htyp)] - with Failure _ -> [] - in - (free_try - (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d]) - g')) - in - let rec_tacs = - List.map - (fun ntac -> - tclTHEN ntac - (free_try - (search_gen decomp (n-1) db_list local_db empty_named_context))) - (possible_resolve db_list local_db (pf_concl goal)) - in - tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal - - -let search = search_gen 0 - -let default_search_depth = ref 5 - -let full_auto n gl = - let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map searchtable_map dbnames in - let hyps = pf_hyps gl in - tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl - -let default_full_auto gl = full_auto !default_search_depth gl -(************************************************************************) - -let blast_tactic = ref (free_try default_full_auto) -;; - -let blast_auto = (free_try default_full_auto) -(* (tclTHEN (free_try default_full_auto) - (free_try (my_full_eauto 2))) -*) -;; -let blast_simpl = (free_try (reduce (Simpl None) onConcl)) -;; -let blast_induction1 = - (free_try (tclTHEN (tclTRY intro) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; -let blast_induction2 = - (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; -let blast_induction3 = - (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; - -blast_tactic := - (tclORELSE (tclCOMPLETE blast_auto) - (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto)) - (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1 - (tclTHEN blast_simpl blast_auto))) - (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2 - (tclTHEN blast_simpl blast_auto))) - (tclCOMPLETE (tclTHEN blast_induction3 - (tclTHEN blast_simpl blast_auto))))))) -;; -(* -blast_tactic := (tclTHEN (free_try default_full_auto) - (free_try (my_full_eauto 4))) -;; -*) - -let vire_extvar s = - let interro = ref false in - let interro_pos = ref 0 in - for i=0 to (length s)-1 do - if get s i = '?' - then (interro := true; - interro_pos := i) - else if (!interro && - (List.mem (get s i) - ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) - then set s i ' ' - else interro:=false - done; - s -;; - -let blast gls = - let leaf g = { - open_subgoals = 1; - goal = g; - ref = None } in - try (let (sgl,v) as _res = !blast_tactic gls in - let {it=lg} = sgl in - if lg = [] - then (let pf = v (List.map leaf (sig_it sgl)) in - let sign = (sig_it gls).evar_hyps in - let x = print_subscript - (sig_sig gls) sign pf in - msgnl (hov 0 (str"Blast ==> " ++ x)); - let x = print_subscript - (sig_sig gls) sign pf in - let tac_string = - pp_string (hov 0 x ) in - (* on remplace les ?1 ?2 ... de refine par ? *) - parse_tac ((vire_extvar tac_string) - ^ ".") - ) - else (msgnl (hov 0 (str"Blast failed to prove the goal...")); - failwith "echec de blast")) - with _ -> failwith "echec de blast" -;; - -let blast_tac display_function = function - | (n::_) as _l -> - (function g -> - let exp_ast = (blast g) in - (display_function exp_ast; - tclIDTAC g)) - | _ -> failwith "expecting other arguments";; - -let blast_tac_txt = - blast_tac - (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));; - -(* Obsolète ? -overwriting_add_tactic "Blast1" blast_tac_txt;; -*) - -(* -Grammar tactic ne_numarg_list : list := - ne_numarg_single [numarg($n)] ->[$n] -| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ]. -Grammar tactic simple_tactic : ast := - blast1 [ "Blast1" ne_numarg_list($ns) ] -> - [ (Blast1 ($LIST $ns)) ]. - - - -PATH=/usr/local/bin:/usr/bin:$PATH -COQTOP=d:/Tools/coq-7.0-3mai -CAMLLIB=/usr/local/lib/ocaml -CAMLP4LIB=/usr/local/lib/camlp4 -export CAMLLIB -export COQTOP -export CAMLP4LIB -d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe -Drop. -#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; -*) diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli deleted file mode 100644 index f6701943..00000000 --- a/contrib/interface/blast.mli +++ /dev/null @@ -1,3 +0,0 @@ -val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - int list -> Proof_type.tactic - diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 deleted file mode 100644 index 51dce4f7..00000000 --- a/contrib/interface/centaur.ml4 +++ /dev/null @@ -1,885 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* - * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu> - * to implement the following features - * - Terms (optionally) as pretty-printed string and not trees - * - (Optionally) give most commands their usual Coq semantics - * - Add the backtracking information to the status message. - * in the following time period - * - May-November 2006 - * and - * - Make use of new Command.save_hook to generate dependencies at - * save-time. - * in - * - June 2007 - *) - -(*Toplevel loop for the communication between Coq and Centaur *) -open Names;; -open Nameops;; -open Util;; -open Term;; -open Pp;; -open Ppconstr;; -open Prettyp;; -open Libnames;; -open Libobject;; -open Library;; -open Vernacinterp;; -open Evd;; -open Proof_trees;; -open Tacmach;; -open Pfedit;; -open Proof_type;; -open Parsing;; -open Environ;; -open Declare;; -open Declarations;; -open Rawterm;; -open Reduction;; -open Classops;; -open Vernacinterp;; -open Vernac;; -open Command;; -open Protectedtoplevel;; -open Line_oriented_parser;; -open Xlate;; -open Vtp;; -open Ascent;; -open Translate;; -open Name_to_ast;; -open Pbp;; -open Blast;; -(* open Dad;; *) -open Debug_tac;; -open Search;; -open Constrintern;; -open Nametab;; -open Showproof;; -open Showproof_ct;; -open Tacexpr;; -open Vernacexpr;; -open Printer;; - -let pcoq_started = ref None;; - -let if_pcoq f a = - if !pcoq_started <> None then f a else error "Pcoq is not started";; - -let text_proof_flag = ref "en";; - -let pcoq_history = ref true;; - -let assert_pcoq_history f a = - if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";; - -let current_proof_name () = - try - string_of_id (get_current_proof_name ()) - with - UserError("Pfedit.get_proof", _) -> "";; - -let current_goal_index = ref 0;; - -let guarded_force_eval_stream (s : std_ppcmds) = - let l = ref [] in - let f elt = l:= elt :: !l in - (try Stream.iter f s with - | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); - Stream.of_list (List.rev !l);; - - -let rec string_of_path p = - match p with [] -> "\n" - | i::p -> (string_of_int i)^" "^ (string_of_path p) -;; -let print_path p = - output_results_nl (str "Path:" ++ str (string_of_path p)) -;; - -let kill_proof_node index = - let paths = History.historical_undo (current_proof_name()) index in - let _ = List.iter - (fun path -> (traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - traverse_to [])) - paths in - History.border_length (current_proof_name());; - - -type vtp_tree = - | P_rl of ct_RULE_LIST - | P_r of ct_RULE - | P_s_int of ct_SIGNED_INT_LIST - | P_pl of ct_PREMISES_LIST - | P_cl of ct_COMMAND_LIST - | P_t of ct_TACTIC_COM - | P_text of ct_TEXT - | P_ids of ct_ID_LIST;; - -let print_tree t = - (match t with - | P_rl x -> fRULE_LIST x - | P_r x -> fRULE x - | P_s_int x -> fSIGNED_INT_LIST x - | P_pl x -> fPREMISES_LIST x - | P_cl x -> fCOMMAND_LIST x - | P_t x -> fTACTIC_COM x - | P_text x -> fTEXT x - | P_ids x -> fID_LIST x) - ++ (str "e\nblabla\n");; - - -(*Message functions, the text of these messages is recognized by the protocols *) -(*of CtCoq *) -let ctf_header message_name request_id = - str "message" ++ fnl() ++ str message_name ++ fnl() ++ - int request_id ++ fnl();; - -let ctf_acknowledge_command request_id command_count opt_exn = - let goal_count, goal_index = - if refining() then - let g_count = - List.length - (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in - g_count, !current_goal_index - else - (0, 0) - and statnum = Lib.current_command_label () - and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0 - and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in - (ctf_header "acknowledge" request_id ++ - int command_count ++ fnl() ++ - int goal_count ++ fnl () ++ - int goal_index ++ fnl () ++ - str (current_proof_name()) ++ fnl() ++ - int statnum ++ fnl() ++ - print_tree (P_ids pending) ++ - int dpth ++ fnl() ++ - (match opt_exn with - Some e -> Cerrors.explain_exn e - | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; - -let ctf_undoResults = ctf_header "undo_results";; - -let ctf_TextMessage = ctf_header "text_proof";; - -let ctf_SearchResults = ctf_header "search_results";; - -let ctf_OtherGoal = ctf_header "other_goal";; - -let ctf_Location = ctf_header "location";; - -let ctf_StateMessage = ctf_header "state";; - -let ctf_PathGoalMessage () = - fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();; - -let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; - -let ctf_GoalsReqIdMessage = ctf_header "goals_state";; - -let ctf_NewStateMessage = ctf_header "fresh_state";; - -let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ - str "saved" ++ fnl();; - -let ctf_KilledMessage req_id ngoals = - ctf_header "killed" req_id ++ int ngoals ++ fnl ();; - -let ctf_AbortedAllMessage () = - fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; - -let ctf_AbortedMessage request_id na = - ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; - -let ctf_UserErrorMessage request_id stream = - let stream = guarded_force_eval_stream stream in - ctf_header "user_error" request_id ++ stream ++ fnl() ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - -let ctf_ResetInitialMessage () = - fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();; - -let ctf_ResetIdentMessage request_id s = - ctf_header "reset_ident" request_id ++ str s ++ fnl () ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - - -let break_happened = ref false;; - -let output_results stream vtp_tree = - let _ = Sys.signal Sys.sigint - (Sys.Signal_handle(fun i -> (break_happened := true;()))) in - msg (stream ++ - (match vtp_tree with - Some t -> print_tree t - | None -> mt()));; - -let output_results_nl stream = - let _ = Sys.signal Sys.sigint - (Sys.Signal_handle(fun i -> break_happened := true;())) - in - msgnl stream;; - - -let rearm_break () = - let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break)) - in ();; - -let check_break () = - if (!break_happened) then - begin - break_happened := false; - raise Sys.Break - end - else ();; - -let print_past_goal index = - let path = History.get_path_for_rank (current_proof_name()) index in - try traverse_to path; - let pf = proof_of_pftreestate (get_pftreestate ()) in - output_results (ctf_PathGoalMessage ()) - (Some (P_r (translate_goal pf.goal))) - with - | Invalid_argument s -> - ((try traverse_to [] with _ -> ()); - error "No focused proof (No proof-editing in progress)") - | e -> (try traverse_to [] with _ -> ()); raise e -;; - -let show_nth n = - try - output_results (ctf_GoalReqIdMessage !global_request_id - ++ pr_nth_open_subgoal n) - None - with - | Invalid_argument s -> - error "No focused proof (No proof-editing in progress)";; - -let show_subgoals () = - try - output_results (ctf_GoalReqIdMessage !global_request_id - ++ pr_open_subgoals ()) - None - with - | Invalid_argument s -> - error "No focused proof (No proof-editing in progress)";; - -(* The rest of the file contains commands that are changed from the plain - Coq distribution *) - -let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);; - -(* -let filter_by_module_from_varg_list l = - let dir_list, b = Vernacentries.interp_search_restriction l in - Search.filter_by_module_from_list (dir_list, b);; -*) - -let add_search (global_reference:global_reference) assumptions cstr = - try - let id_string = - string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty - global_reference) in - let ast = - try - CT_premise (CT_ident id_string, translate_constr false assumptions cstr) - with Not_found -> - CT_premise (CT_ident id_string, - CT_coerce_ID_to_FORMULA( - CT_ident ("Error printing" ^ id_string))) in - ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST - with e -> msgnl (str "add_search raised an exception"); raise e;; - -(* -let make_error_stream node_string = - str "The syntax of " ++ str node_string ++ - str " is inconsistent with the vernac interpreter entry";; -*) - -let ctf_EmptyGoalMessage id = - fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; - - -let print_check env judg = - ((ctf_SearchResults !global_request_id) ++ - print_judgment env judg, - None);; - -let ct_print_eval red_fun env evmap ast judg = - (if refining() then traverse_to []); - let {uj_val=value; uj_type=typ} = judg in - let nvalue = (red_fun env evmap) value - (* // Attention , ici il faut peut être utiliser des environnemenst locaux *) - and ntyp = nf_betaiota typ in - print_tree - (P_pl - (CT_premises_list - [CT_eval_result - (xlate_formula ast, - translate_constr false env nvalue, - translate_constr false env ntyp)]));; - -let pbp_tac_pcoq = - pbp_tac (function (x:raw_tactic_expr) -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; - -let blast_tac_pcoq = - blast_tac (function (x:raw_tactic_expr) -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; - -(* <\cpa> -let dad_tac_pcoq = - dad_tac(function x -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; -</cpa> *) - -let search_output_results () = - (* LEM: See comments for pcoq_search *) - output_results - (ctf_SearchResults !global_request_id) - (Some (P_pl (CT_premises_list - (List.rev !ctv_SEARCH_LIST))));; - - -let debug_tac2_pcoq tac = - (fun g -> - let the_goal = ref (None : goal sigma option) in - let the_ast = ref tac in - let the_path = ref ([] : int list) in - try - let _result = report_error tac the_goal the_ast the_path [] g in - (errorlabstrm "DEBUG TACTIC" - (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++ - fnl () ++ str "the tactic is" ++ fnl () ++ - Pptactic.pr_glob_tactic (Global.env()) tac) (* -Caution, this is in the middle of what looks like dead code. ; - result *)) - with - e -> - match !the_goal with - None -> raise e - | Some g -> - (output_results - (ctf_Location !global_request_id) - (Some (P_s_int - (CT_signed_int_list - (List.map - (fun n -> CT_coerce_INT_to_SIGNED_INT - (CT_int n)) - (clean_path tac - (List.rev !the_path))))))); - (output_results - (ctf_OtherGoal !global_request_id) - (Some (P_r (translate_goal (sig_it g))))); - raise e);; - -let rec selectinspect n env = - match env with - [] -> [] - | a::tl -> - if n = 0 then - [] - else - match a with - (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl) - | _ -> (selectinspect n tl);; - -open Term;; - -let inspect n = - let env = Global.env() in - let add_search2 x y = add_search x env y in - let l = selectinspect n (Lib.contents_after None) in - ctv_SEARCH_LIST := []; - List.iter - (fun a -> - try - (match a with - oname, Lib.Leaf lobj -> - (match oname, object_tag lobj with - (sp,_), "VARIABLE" -> - let (_, _, v) = Global.lookup_named (basename sp) in - add_search2 (Nametab.locate (qualid_of_sp sp)) v - | (sp,kn), "CONSTANT" -> - let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in - add_search2 (Nametab.locate (qualid_of_sp sp)) typ - | (sp,kn), "MUTUALINDUCTIVE" -> - add_search2 (Nametab.locate (qualid_of_sp sp)) - (Pretyping.Default.understand Evd.empty (Global.env()) - (RRef(dummy_loc, IndRef(kn,0)))) - | _ -> failwith ("unexpected value 1 for "^ - (string_of_id (basename (fst oname))))) - | _ -> failwith "unexpected value") - with e -> ()) - l; - output_results - (ctf_SearchResults !global_request_id) - (Some - (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; - -let ct_int_to_TARG n = - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; - -let pair_list_to_ct l = - CT_user_tac(CT_ident "pair_int_list", - CT_targ_list - (List.map (fun (a,b) -> - CT_coerce_TACTIC_COM_to_TARG - (CT_user_tac - (CT_ident "pair_int", - CT_targ_list - [ct_int_to_TARG a; ct_int_to_TARG b]))) - l));; - -(* Annule toutes les commandes qui s'appliquent sur les sous-buts du - but auquel a été appliquée la n-ième tactique *) -let logical_kill n = - let path = History.get_path_for_rank (current_proof_name()) n in - begin - traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - (let kept_cmds, undone_cmds, remaining_goals, current_goal = - History.logical_undo (current_proof_name()) n in - output_results (ctf_undoResults !global_request_id) - (Some - (P_t - (CT_user_tac - (CT_ident "log_undo_result", - CT_targ_list - [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds); - CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds); - ct_int_to_TARG remaining_goals; - ct_int_to_TARG current_goal]))))); - traverse_to [] - end;; - -let simulate_solve n tac = - let path = History.get_nth_open_path (current_proof_name()) n in - solve_nth n (Tacinterp.hide_interp tac (get_end_tac())); - traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - traverse_to [] - -let kill_node_verbose n = - let ngoals = kill_proof_node n in - output_results_nl (ctf_KilledMessage !global_request_id ngoals) - -let set_text_mode s = text_proof_flag := s - -let pcoq_reset_initial() = - output_results(ctf_AbortedAllMessage()) None; - Vernacentries.abort_refine Lib.reset_initial (); - output_results(ctf_ResetInitialMessage()) None;; - -let pcoq_reset x = - if refining() then - output_results (ctf_AbortedAllMessage ()) None; - Vernacentries.abort_refine Lib.reset_name (dummy_loc,x); - output_results - (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; - - -VERNAC ARGUMENT EXTEND text_mode -| [ "fr" ] -> [ "fr" ] -| [ "en" ] -> [ "en" ] -| [ "Off" ] -> [ "off" ] -END - -VERNAC COMMAND EXTEND TextMode -| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ] -END - -VERNAC COMMAND EXTEND OutputGoal - [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ] -END - -VERNAC COMMAND EXTEND OutputGoal - [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ] -END - -VERNAC COMMAND EXTEND KillProofAfter -| [ "Kill" "Proof" "after" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] -END - -VERNAC COMMAND EXTEND KillProofAt -| [ "Kill" "Proof" "at" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] -END - -VERNAC COMMAND EXTEND KillSubProof - [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ] -END - -VERNAC COMMAND EXTEND PcoqReset - [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ] -END - -VERNAC COMMAND EXTEND PcoqResetInitial - [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ] -END - -let start_proof_hook () = - if !pcoq_history then History.start_proof (current_proof_name()); - current_goal_index := 1 - -let solve_hook n = - current_goal_index := n; - if !pcoq_history then - let name = current_proof_name () in - let old_n_count = History.border_length name in - let pf = proof_of_pftreestate (get_pftreestate ()) in - let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in - History.push_command name n n_goals - -let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) - -let interp_search_about_item = function - | SearchSubPattern pat -> - let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in - GlobSearchSubPattern pat - | SearchString (s,_) -> - warning "Notation case not taken into account"; - GlobSearchString s - -let pcoq_search s l = - (* LEM: I don't understand why this is done in this way (redoing the - * match on s here) instead of making the code in - * parsing/search.ml call the right function instead of - * "plain_display". Investigates this later. - * TODO - *) - ctv_SEARCH_LIST:=[]; - begin match s with - | SearchAbout sl -> - raw_search_about (filter_by_module_from_list l) add_search - (List.map (on_snd interp_search_about_item) sl) - | SearchPattern c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in - raw_pattern_search (filter_by_module_from_list l) add_search pat - | SearchRewrite c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in - raw_search_rewrite (filter_by_module_from_list l) add_search pat; - | SearchHead locqid -> - filtered_search - (filter_by_module_from_list l) add_search (Nametab.global locqid) - end; - search_output_results() - -(* Check sequentially whether the pattern is one of the premises *) -let rec hyp_pattern_filter pat name a c = - let _c1 = strip_outer_cast c in - match kind_of_term c with - | Prod(_, hyp, c2) -> - (try -(* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in - let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) - if Matching.is_matching pat hyp then - (msgnl (str "ok"); true) - else - false - with UserError _ -> false) or - hyp_pattern_filter pat name a c2 - | _ -> false;; - -let hyp_search_pattern c l = - let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in - ctv_SEARCH_LIST := []; - gen_filtered_search - (fun s a c -> (filter_by_module_from_list l s a c && - (if hyp_pattern_filter pat s a c then - (msgnl (str "ok2"); true) else false))) - (fun s a c -> (msgnl (str "ok3"); add_search s a c)); - output_results - (ctf_SearchResults !global_request_id) - (Some - (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; -let pcoq_print_name ref = - output_results - (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref ) - None - -let pcoq_print_check env j = - let a,b = print_check env j in output_results a b - -let pcoq_print_eval redfun env evmap c j = - output_results - (ctf_SearchResults !global_request_id - ++ Prettyp.print_eval redfun env evmap c j) - None;; - -open Vernacentries - -let pcoq_show_goal = function - | Some n -> show_nth n - | None -> show_subgoals () -;; - -let pcoq_hook = { - start_proof = start_proof_hook; - solve = solve_hook; - abort = abort_hook; - search = pcoq_search; - print_name = pcoq_print_name; - print_check = pcoq_print_check; - print_eval = pcoq_print_eval; - show_goal = pcoq_show_goal -} - -let pcoq_term_pr = { - pr_constr_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_constr_expr c)); - (* In future translate_constr false (Global.env()) - * Except with right bool/env which I'll get :) - *) - pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")"); - pr_constr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr c)); - pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lconstr_pattern_expr c)) -} - -let start_pcoq_trees () = - set_term_pr pcoq_term_pr - -(* BEGIN functions for object_pr *) - -(* These functions in general mirror what name_to_ast does in a subcase, - and then print the corresponding object as a PCoq tree. *) - -let object_to_ast_template object_to_ast_list sp = - let l = object_to_ast_list sp in - VernacList (List.map (fun x -> (dummy_loc, x)) l) - -let pcoq_print_object_template object_to_ast_list sp = - let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in - print_tree (P_cl results) - -(* This function mirror what print_check does *) - -let pcoq_print_typed_value_in_env env (value, typ) = - let value_ct_ast = - (try translate_constr false (Global.env()) value - with UserError(f,str) -> - raise(UserError(f,Printer.pr_lconstr value ++ - fnl () ++ str ))) in - let type_ct_ast = - (try translate_constr false (Global.env()) typ - with UserError(f,str) -> - raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in - print_tree - (P_pl - (CT_premises_list - [CT_coerce_TYPED_FORMULA_to_PREMISE - (CT_typed_formula(value_ct_ast,type_ct_ast) - )])) -;; - -(* This function mirrors what show_nth does *) - -let pcoq_pr_subgoal n gl = - try - print_tree - (if (!text_proof_flag<>"off") then - (* This is a horrendeous hack; it ignores the "gl" argument - and just takes the currently focused proof. This will bite - us back one day. - TODO: Fix this. - *) - ( - if not !pcoq_history then error "Text mode requires Pcoq history tracking."; - if n=0 - then (P_text (show_proof !text_proof_flag [])) - else - let path = History.get_nth_open_path (current_proof_name()) n in - (P_text (show_proof !text_proof_flag path))) - else - (let goal = List.nth gl (n - 1) in - (P_r (translate_goal goal)))) - with - | Invalid_argument _ - | Failure "nth" - | Not_found -> error "No such goal";; - -let pcoq_pr_subgoals close_cmd evar gl = - (*LEM: TODO: we should check for evar emptiness or not, and do something *) - try - print_tree - (if (!text_proof_flag<>"off") then - raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented")) - else - (P_rl (translate_goals gl))) - with - | Invalid_argument _ - | Failure "nth" - | Not_found -> error "No such goal";; - - -(* END functions for object_pr *) - -let pcoq_object_pr = { - print_inductive = pcoq_print_object_template inductive_to_ast_list; - (* TODO: Check what that with_infos means, and adapt accordingly *) - print_constant_with_infos = pcoq_print_object_template constant_to_ast_list; - print_section_variable = pcoq_print_object_template variable_to_ast_list; - print_syntactic_def = pcoq_print_object_template (fun x -> errorlabstrm "print" - (str "printing of syntax definitions not implemented in PCoq syntax")); - (* TODO: These are placeholders only; write them *) - print_module = (fun x y -> str "pcoq_print_module not implemented"); - print_modtype = (fun x -> str "pcoq_print_modtype not implemented"); - print_named_decl = (fun x -> str "pcoq_print_named_decl not implemented"); - (* TODO: Find out what the first argument x (a bool) is about and react accordingly *) - print_leaf_entry = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list); - print_library_entry = (fun x y -> Some (str "pcoq_print_library_entry not implemented")); - print_context = (fun x y z -> str "pcoq_print_context not implemented"); - print_typed_value_in_env = pcoq_print_typed_value_in_env; - Prettyp.print_eval = ct_print_eval; -};; - -let pcoq_printer_pr = { - pr_subgoals = pcoq_pr_subgoals; - pr_subgoal = pcoq_pr_subgoal; - pr_goal = (fun x -> str "pcoq_pr_goal not implemented"); -};; - - -let start_pcoq_objects () = - set_object_pr pcoq_object_pr; - set_printer_pr pcoq_printer_pr - -let start_default_objects () = - set_object_pr default_object_pr; - set_printer_pr default_printer_pr - -let full_name_of_ref r = - (match r with - | VarRef _ -> str "VAR" - | ConstRef _ -> str "CST" - | IndRef _ -> str "IND" - | ConstructRef _ -> str "CSR") - ++ str " " ++ (pr_sp (Nametab.sp_of_global r)) - (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *) - -let string_of_ref = - (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*) - Depends.o Libnames.string_of_path Nametab.sp_of_global - -let print_depends compute_depends ptree = - output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl()) - (str "This object depends on:" ++ fnl()) - (compute_depends ptree)) - None - -let output_depends compute_depends ptree = - (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *) - output_results (ctf_header "depends" !global_request_id ++ - print_tree (P_ids (CT_id_list (List.map - (fun x -> CT_ident (string_of_ref x)) - (compute_depends ptree))))) - None - -let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' = - Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[])); - Command.set_declare_assumption_hook (print_depends (fun (c:types) -> Depends.depends_of_constr c [])); - Command.set_start_hook (print_depends (fun c -> Depends.depends_of_constr c [])); - Command.set_save_hook (print_depends'' (Depends.depends_of_pftreestate Depends.depends_of_pftree)); - Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt [])) - -let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends - -let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends - -TACTIC EXTEND pbp -| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> - [ if_pcoq pbp_tac_pcoq idopt nl ] -END - -TACTIC EXTEND ct_debugtac -| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] -END - -TACTIC EXTEND ct_debugtac2 -| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] -END - - -let start_pcoq_mode debug = - begin - pcoq_started := Some debug; -(* <\cpa> - start_dad(); -</cpa> *) -(* The following ones are added to enable rich comments in pcoq *) -(* TODO ... - add_tactic "Image" (fun _ -> tclIDTAC); -*) -(* "Comments" moved to Vernacentries, other obsolete ? - List.iter (fun (a,b) -> vinterp_add a b) command_creations; -*) -(* Now hooks in Vernacentries - List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes; - if not debug then - List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes; -*) - set_pcoq_hook pcoq_hook; - start_pcoq_objects(); - Flags.print_emacs := false; Pp.make_pp_nonemacs(); - end;; - - -let start_pcoq () = - start_pcoq_mode false; - set_acknowledge_command ctf_acknowledge_command; - set_start_marker "CENTAUR_RESERVED_TOKEN_start_command"; - set_end_marker "CENTAUR_RESERVED_TOKEN_end_command"; - raise Vernacexpr.ProtectedLoop;; - -let start_pcoq_debug () = - start_pcoq_mode true; - set_acknowledge_command ctf_acknowledge_command; - set_start_marker "--->"; - set_end_marker "<---"; - raise Vernacexpr.ProtectedLoop;; - -VERNAC COMMAND EXTEND HypSearchPattern - [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ] -END - -VERNAC COMMAND EXTEND StartPcoq - [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ] -END - -VERNAC COMMAND EXTEND Pcoq_inspect - [ "Pcoq_inspect" ] -> [ inspect 15 ] -END - -VERNAC COMMAND EXTEND StartPcoqDebug -| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ] -END - -VERNAC COMMAND EXTEND StartPcoqTerms -| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ] -END - -VERNAC COMMAND EXTEND StartPcoqObjects -| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ] -END - -VERNAC COMMAND EXTEND StartDefaultObjects -| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ] -END - -VERNAC COMMAND EXTEND StartDependencyDumps -| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ] -END - -VERNAC COMMAND EXTEND StopPcoqHistory -| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ] -END diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml deleted file mode 100644 index c2ab2dc8..00000000 --- a/contrib/interface/dad.ml +++ /dev/null @@ -1,382 +0,0 @@ -(* This file contains an ml version of drag-and-drop. *) - -(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *) - -open Names;; -open Term;; -open Rawterm;; -open Util;; -open Environ;; -open Tactics;; -open Tacticals;; -open Pattern;; -open Matching;; -open Reduction;; -open Constrextern;; -open Constrintern;; -open Vernacinterp;; -open Libnames;; -open Nametab - -open Proof_type;; -open Proof_trees;; -open Tacmach;; -open Typing;; -open Pp;; - -open Paths;; - -open Topconstr;; -open Genarg;; -open Tacexpr;; -open Rawterm;; - -(* In a first approximation, drag-and-drop rules are like in CtCoq - 1/ a pattern, - 2,3/ Two paths: start and end positions, - 4/ the degree: the number of steps the algorithm should go up from the - longest common prefix, - 5/ the tail path: the suffix of the longest common prefix of length the - degree, - 6/ the command pattern, where meta variables are represented by objects - of the form Node(_,"META"; [Num(_,i)]) -*) - - -type dad_rule = - constr_expr * int list * int list * int * int list - * raw_atomic_tactic_expr;; - -(* This value will be used systematically when constructing objects *) - -let zz = Util.dummy_loc;; - -(* This function receives a length n, a path p, and a term and returns a - couple whose first component is the subterm designated by the prefix - of p of length n, and the second component is the rest of the path *) - -let rec get_subterm (depth:int) (path: int list) (constr:constr) = - match depth, path, kind_of_term constr with - 0, l, c -> (constr,l) - | n, 2::a::tl, App(func,arr) -> - get_subterm (n - 2) tl arr.(a-1) - | _,l,_ -> failwith (int_list_to_string - "wrong path or wrong form of term" - l);; - -(* This function maps a substitution on an abstract syntax tree. The - first argument, an object of type env, is necessary to - transform constr terms into abstract syntax trees. The second argument is - the substitution, a list of pairs linking an integer and a constr term. *) - -let rec map_subst (env :env) (subst:patvar_map) = function - | CPatVar (_,(_,i)) -> - let constr = List.assoc i subst in - extern_constr false env constr - | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;; - -let map_subst_tactic env subst = function - | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> - let c,bl = out_gen rawwit_constr_with_bindings cbl in - assert (bl = NoBindings); - let c = (map_subst env subst c,NoBindings) in - TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c]) - | _ -> failwith "map_subst_tactic: unsupported tactic" - -(* This function is really the one that is important. *) -let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = - match l with - [] -> failwith "nothing happens" - | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl -> - let length = List.length p in - try - if deg > length then - failwith "internal" - else - let term_to_match, p_r = - try - get_subterm (length - deg) p constr - with - Failure s -> failwith "internal" in - let _, constr_pat = - intern_constr_pattern Evd.empty (Global.env()) - ((*ct_to_ast*) pat) in - let subst = matches constr_pat term_to_match in - if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then - TacAtom (zz, map_subst_tactic env subst cmd) - else - failwith "internal" - with - Failure "internal" -> find_cmd tl env constr p p1 p2 - | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;; - - -let dad_rule_list = ref ([]: (string * dad_rule) list);; - -(* -(* \\ This function is also used in pbp. *) -let rec tactic_args_to_ints = function - [] -> [] - | (Integer n)::l -> n::(tactic_args_to_ints l) - | _ -> failwith "expecting only numbers";; - -(* We assume that the two lists of integers for the tactic are simply - given in one list, separated by a dummy tactic. *) -let rec part_tac_args l = function - [] -> l,[] - | (Tacexp a)::tl -> l, (tactic_args_to_ints tl) - | (Integer n)::tl -> part_tac_args (n::l) tl - | _ -> failwith "expecting only numbers and the word \"to\"";; - - -(* The dad_tac tactic takes a display_function as argument. This makes - it possible to use it in pcoq, but also in other contexts, just by - changing the output routine. *) -let dad_tac display_function = function - l -> let p1, p2 = part_tac_args [] l in - (function g -> - let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in - (display_function - (find_cmd (!dad_rule_list) (pf_env g) - (pf_concl g) p_a p1prime p2prime)); - tclIDTAC g);; -*) -let dad_tac display_function p1 p2 g = - let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in - (display_function - (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); - tclIDTAC g;; - -(* Now we enter dad rule list management. *) - -let add_dad_rule name patt p1 p2 depth pr command = - dad_rule_list := (name, - (patt, p1, p2, depth, pr, command))::!dad_rule_list;; - -let rec remove_if_exists name = function - [] -> false, [] - | ((a,b) as rule1)::tl -> if a = name then - let result1, l = (remove_if_exists name tl) in - true, l - else - let result1, l = remove_if_exists name tl in - result1, (rule1::l);; - -let remove_dad_rule name = - let result1, result2 = remove_if_exists name !dad_rule_list in - if result1 then - failwith("No such name among the drag and drop rules " ^ name) - else - dad_rule_list := result2;; - -let dad_rule_names () = - List.map (function (s,_) -> s) !dad_rule_list;; - -(* this function is inspired from matches_core in pattern.ml *) -let constrain ((n : patvar),(pat : constr_pattern)) sigma = - if List.mem_assoc n sigma then - if pat = (List.assoc n sigma) then sigma - else failwith "internal" - else - (n,pat)::sigma - -(* This function is inspired from matches_core in pattern.ml *) -let more_general_pat pat1 pat2 = - let rec match_rec sigma p1 p2 = - match p1, p2 with - | PMeta (Some n), m -> constrain (n,m) sigma - - | PMeta None, m -> sigma - - | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma - - | PVar v1, PVar v2 when v1 = v2 -> sigma - - | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma - - | PRel n1, PRel n2 when n1 = n2 -> sigma - - | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma - - | PSort (RType _), PSort (RType _) -> sigma - - | PApp (c1,arg1), PApp (c2,arg2) -> - (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 - with Invalid_argument _ -> failwith "internal") - | _ -> failwith "unexpected case in more_general_pat" in - try let _ = match_rec [] pat1 pat2 in true - with Failure "internal" -> false;; - -let more_general r1 r2 = - match r1,r2 with - (_,(patt1,p11,p12,_,_,_)), - (_,(patt2,p21,p22,_,_,_)) -> - (more_general_pat patt1 patt2) & - (is_prefix p11 p21) & (is_prefix p12 p22);; - -let not_less_general r1 r2 = - not (match r1,r2 with - (_,(patt1,p11,p12,_,_,_)), - (_,(patt2,p21,p22,_,_,_)) -> - (more_general_pat patt1 patt2) & - (is_prefix p21 p11) & (is_prefix p22 p12));; - -let rec add_in_list_sorting rule1 = function - [] -> [rule1] - | (b::tl) as this_list -> - if more_general rule1 b then - b::(add_in_list_sorting rule1 tl) - else if not_less_general rule1 b then - let tl2 = add_in_list_sorting_aux rule1 tl in - (match tl2 with - [] -> rule1::this_list - | _ -> b::tl2) - else - rule1::this_list -and add_in_list_sorting_aux rule1 = function - [] -> [] - | b::tl -> - if more_general rule1 b then - b::(add_in_list_sorting rule1 tl) - else - let tl2 = add_in_list_sorting_aux rule1 tl in - (match tl2 with - [] -> [] - | _ -> rule1::tl2);; - -let rec sort_list = function - [] -> [] - | a::l -> add_in_list_sorting a (sort_list l);; - -let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; -let mk_rewrite lr ast = - let b = in_gen rawwit_bool lr in - let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in - TacExtend (zz,"Rewrite",[b;cb]) - -open Vernacexpr - -let dad_status = ref false;; - -let start_dad () = dad_status := true;; - -let add_dad_rule_fn name pat p1 p2 tac = - let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in - add_dad_rule name pat p1 p2 (List.length pr) pr tac;; - -(* To be parsed by camlp4 - -(*i camlp4deps: "parsing/grammar.cma" i*) - -VERNAC COMMAND EXTEND AddDadRule - [ "Add" "Dad" "Rule" string(name) constr(pat) - "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] -> - [ add_dad_rule_fn name pat p1 p2 tac ] -END - -*) - -let mk_id s = mkIdentC (id_of_string s);; -let mkMetaC = mk_dad_meta;; - -add_dad_rule "distributivity-inv" -(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "distributivity1-r" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) -[2; 2; 2; 2] -[] -0 -[] -(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "distributivity1-l" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) -[2; 1; 2; 2] -[] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "associativity" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) -[2; 1] -[] -0 -[] -(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "minus-identity-lr" -(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) -[2; 1] -[2; 2] -1 -[2] -(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); - -add_dad_rule "minus-identity-rl" -(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); - -add_dad_rule "plus-sym-rl" -(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "plus-sym-lr" -(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) -[2; 1] -[2; 2] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "absorb-0-r-rl" -(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) -[2; 2] -[1] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); - -add_dad_rule "absorb-0-r-lr" -(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) -[1] -[2; 2] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); - -add_dad_rule "plus-permute-lr" -(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) -[2; 1] -[2; 2; 2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "plus-permute-rl" -(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) -[2; 2; 2; 1] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; - -vinterp_add "StartDad" - (function - | [] -> - (function () -> start_dad()) - | _ -> errorlabstrm "StartDad" (mt()));; diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli deleted file mode 100644 index f556c192..00000000 --- a/contrib/interface/dad.mli +++ /dev/null @@ -1,10 +0,0 @@ -open Proof_type;; -open Tacmach;; -open Topconstr;; - -val dad_rule_names : unit -> string list;; -val start_dad : unit -> unit;; -val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma -> - goal list sigma * validation;; -val add_dad_rule : string -> constr_expr -> (int list) -> (int list) -> - int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;; diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 deleted file mode 100644 index aad3a765..00000000 --- a/contrib/interface/debug_tac.ml4 +++ /dev/null @@ -1,458 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Tacmach;; -open Tacticals;; -open Proof_trees;; -open Pp;; -open Pptactic;; -open Util;; -open Proof_type;; -open Tacexpr;; -open Genarg;; - -let pr_glob_tactic = Pptactic.pr_glob_tactic (Global.env()) - -(* Compacting and uncompacting proof commands *) - -type report_tree = - Report_node of bool *int * report_tree list - | Mismatch of int * int - | Tree_fail of report_tree - | Failed of int;; - -type report_card = - Ngoals of int - | Goals_mismatch of int - | Recursive_fail of report_tree - | Fail;; - -type card_holder = report_card ref;; -type report_holder = report_tree list ref;; - -(* This tactical receives an integer and a tactic and checks that the - tactic produces that number of goals. It never fails but signals failure - by updating the boolean reference given as third argument to false. - It is especially suited for use in checked_thens below. *) - -let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic = - fun card_holder count flag t g -> - try - let (gls, v) as result = t g in - let len = List.length (sig_it gls) in - card_holder := - (if len = count then - (flag := true; - Ngoals count) - else - (flag := false; - Goals_mismatch len)); - result - with - e -> card_holder := Fail; - flag := false; - tclIDTAC g;; - -let no_failure = function - [Report_node(true,_,_)] -> true - | _ -> false;; - -let check_subgoals_count2 - : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = - fun card_holder count flag t g -> - let new_report_holder = ref ([] : report_tree list) in - let (gls, v) as result = t new_report_holder g in - let succeeded = no_failure !new_report_holder in - let len = List.length (sig_it gls) in - card_holder := - (if (len = count) & succeeded then - (flag := true; - Ngoals count) - else - (flag := false; - Recursive_fail (List.hd !new_report_holder))); - result;; - -let traceable = function - | TacThen _ | TacThens _ -> true - | _ -> false;; - -let rec collect_status = function - Report_node(true,_,_)::tl -> collect_status tl - | [] -> true - | _ -> false;; - -(* This tactical receives a tactic and executes it, reporting information - about success in the report holder and a boolean reference. *) - -let count_subgoals : card_holder -> bool ref -> tactic -> tactic = - fun card_holder flag t g -> - try - let (gls, _) as result = t g in - card_holder := (Ngoals(List.length (sig_it gls))); - flag := true; - result - with - e -> card_holder := Fail; - flag := false; - tclIDTAC g;; - -let count_subgoals2 - : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = - fun card_holder flag t g -> - let new_report_holder = ref([] : report_tree list) in - let (gls, v) as result = t new_report_holder g in - let succeeded = no_failure !new_report_holder in - if succeeded then - (flag := true; - card_holder := Ngoals (List.length (sig_it gls))) - else - (flag := false; - card_holder := Recursive_fail(List.hd !new_report_holder)); - result;; - -let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function - TacThens (a,l) -> - (fun report_holder -> checked_thens report_holder a l) - | TacThen (a,[||],b,[||]) -> - (fun report_holder -> checked_then report_holder a b) - | t -> - (fun report_holder g -> - try - let (gls, _) as result = Tacinterp.eval_tactic t g in - report_holder := (Report_node(true, List.length (sig_it gls), [])) - ::!report_holder; - result - with e -> (report_holder := (Failed 1)::!report_holder; - tclIDTAC g)) - - -(* This tactical receives a tactic and a list of tactics as argument. - It applies the first tactic and then maps the list of tactics to - various produced sub-goals. This tactic will never fail, but reports - are added in the report_holder in the following way: - - In case of partial success, a new report_tree is added to the report_holder - - In case of failure of the first tactic, with no more indications - then Failed 0 is added to the report_holder, - - In case of partial failure of the first tactic then (Failed n) is added to - the report holder. - - In case of success of the first tactic, but count mismatch, then - Mismatch n is added to the report holder. *) - -and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = - (fun report_holder t1 l g -> - let flag = ref true in - let traceable_t1 = traceable t1 in - let card_holder = ref Fail in - let new_holder = ref ([]:report_tree list) in - let tac_t1 = - if traceable_t1 then - (check_subgoals_count2 card_holder (List.length l) - flag (local_interp t1)) - else - (check_subgoals_count card_holder (List.length l) - flag (Tacinterp.eval_tactic t1)) in - let (gls, _) as result = - tclTHEN_i tac_t1 - (fun i -> - if !flag then - (fun g -> - let tac_i = (List.nth l i) in - if traceable tac_i then - local_interp tac_i new_holder g - else - try - let (gls,_) as result = Tacinterp.eval_tactic tac_i g in - let len = List.length (sig_it gls) in - new_holder := - (Report_node(true, len, []))::!new_holder; - result - with - e -> (new_holder := (Failed 1)::!new_holder; - tclIDTAC g)) - else - tclIDTAC) g in - let new_goal_list = sig_it gls in - (if !flag then - report_holder := - (Report_node(collect_status !new_holder, - (List.length new_goal_list), - List.rev !new_holder))::!report_holder - else - report_holder := - (match !card_holder with - Goals_mismatch(n) -> Mismatch(n, List.length l) - | Recursive_fail tr -> Tree_fail tr - | Fail -> Failed 1 - | _ -> errorlabstrm "check_thens" - (str "this case should not happen in check_thens")):: - !report_holder); - result) - -(* This tactical receives two tactics as argument, it executes the - first tactic and applies the second one to all the produced goals, - reporting information about the success of all tactics in the report - holder. It never fails. *) - -and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic = - (fun report_holder t1 t2 g -> - let flag = ref true in - let card_holder = ref Fail in - let tac_t1 = - if traceable t1 then - (count_subgoals2 card_holder flag (local_interp t1)) - else - (count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in - let new_tree_holder = ref ([] : report_tree list) in - let (gls, _) as result = - tclTHEN tac_t1 - (fun (g:goal sigma) -> - if !flag then - if traceable t2 then - local_interp t2 new_tree_holder g - else - try - let (gls, _) as result = Tacinterp.eval_tactic t2 g in - new_tree_holder := - (Report_node(true, List.length (sig_it gls),[])):: - !new_tree_holder; - result - with - e -> - (new_tree_holder := ((Failed 1)::!new_tree_holder); - tclIDTAC g) - else - tclIDTAC g) g in - (if !flag then - report_holder := - (Report_node(collect_status !new_tree_holder, - List.length (sig_it gls), - List.rev !new_tree_holder))::!report_holder - else - report_holder := - (match !card_holder with - Recursive_fail tr -> Tree_fail tr - | Fail -> Failed 1 - | _ -> error "this case should not happen in check_then")::!report_holder); - result);; - -(* This tactic applies the given tactic only to those subgoals designated - by the list of integers given as extra arguments. - *) - -let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level -let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level -let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level - - -let on_then = function [t1;t2;l] -> - let t1 = out_gen wit_main_tactic t1 in - let t2 = out_gen wit_main_tactic t2 in - let l = out_gen (wit_list0 wit_int) l in - tclTHEN_i (Tacinterp.eval_tactic t1) - (fun i -> - if List.mem (i + 1) l then - (Tacinterp.eval_tactic t2) - else - tclIDTAC) - | _ -> anomaly "bad arguments for on_then";; - -let mkOnThen t1 t2 selected_indices = - let a = in_gen rawwit_main_tactic t1 in - let b = in_gen rawwit_main_tactic t2 in - let l = in_gen (wit_list0 rawwit_int) selected_indices in - TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));; - -(* Analyzing error reports *) - -let rec select_success n = function - [] -> [] - | Report_node(true,_,_)::tl -> n::select_success (n+1) tl - | _::tl -> select_success (n+1) tl;; - -let rec reconstruct_success_tac (tac:glob_tactic_expr) = - match tac with - TacThens (a,l) -> - (function - Report_node(true, n, l) -> tac - | Report_node(false, n, rl) -> - TacThens (a,List.map2 reconstruct_success_tac l rl) - | Failed n -> TacId [] - | Tree_fail r -> reconstruct_success_tac a r - | Mismatch (n,p) -> a) - | TacThen (a,[||],b,[||]) -> - (function - Report_node(true, n, l) -> tac - | Report_node(false, n, rl) -> - let selected_indices = select_success 1 rl in - TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", - [in_gen globwit_main_tactic a; - in_gen globwit_main_tactic b; - in_gen (wit_list0 globwit_int) selected_indices])) - | Failed n -> TacId [] - | Tree_fail r -> reconstruct_success_tac a r - | _ -> error "this error case should not happen in a THEN tactic") - | _ -> - (function - Report_node(true, n, l) -> tac - | Failed n -> TacId [] - | _ -> - errorlabstrm - "this error case should not happen on an unknown tactic" - (str "error in reconstruction with " ++ fnl () ++ - (pr_glob_tactic tac)));; - - -let rec path_to_first_error = function -| Report_node(true, _, l) -> - let rec find_first_error n = function - | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl - | it::tl -> n, it - | [] -> error "no error detected" in - let p, t = find_first_error 1 l in - p::(path_to_first_error t) -| _ -> [];; - -let debug_tac = function - [(Tacexp ast)] -> - (fun g -> - let report = ref ([] : report_tree list) in - let result = local_interp ast report g in - let clean_ast = (* expand_tactic *) ast in - let report_tree = - try List.hd !report with - Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in - let success_tac = - reconstruct_success_tac clean_ast report_tree in - let compact_success_tac = (* flatten_then *) success_tac in - msgnl (fnl () ++ - str "========= Successful tactic =============" ++ - fnl () ++ - pr_glob_tactic compact_success_tac ++ fnl () ++ - str "========= End of successful tactic ============"); - result) - | _ -> error "wrong arguments for debug_tac";; - -(* TODO ... used ? -add_tactic "DebugTac" debug_tac;; -*) - -Tacinterp.add_tactic "OnThen" on_then;; - -let rec clean_path tac l = - match tac, l with - | TacThen (a,[||],b,[||]), fst::tl -> - fst::(clean_path (if fst = 1 then a else b) tl) - | TacThens (a,l), 1::tl -> - 1::(clean_path a tl) - | TacThens (a,tacs), 2::fst::tl -> - 2::fst::(clean_path (List.nth tacs (fst - 1)) tl) - | _, [] -> [] - | _, _ -> failwith "this case should not happen in clean_path";; - -let rec report_error - : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> - int list -> tactic = - fun tac the_goal the_ast returned_path path -> - match tac with - TacThens (a,l) -> - let the_card_holder = ref Fail in - let the_flag = ref false in - let the_exn = ref (Failure "") in - tclTHENS - (fun g -> - let result = - check_subgoals_count - the_card_holder - (List.length l) - the_flag - (fun g2 -> - try - (report_error a the_goal the_ast returned_path (1::path) g2) - with - e -> (the_exn := e; raise e)) - g in - if !the_flag then - result - else - (match !the_card_holder with - Fail -> - the_ast := TacThens (!the_ast, l); - raise !the_exn - | Goals_mismatch p -> - the_ast := tac; - returned_path := path; - error ("Wrong number of tactics: expected " ^ - (string_of_int (List.length l)) ^ " received " ^ - (string_of_int p)) - | _ -> error "this should not happen")) - (let rec fold_num n = function - [] -> [] - | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path)):: - (fold_num (n + 1) tl) in - fold_num 1 l) - | TacThen (a,[||],b,[||]) -> - let the_count = ref 1 in - tclTHEN - (fun g -> - try - report_error a the_goal the_ast returned_path (1::path) g - with - e -> - (the_ast := TacThen (!the_ast,[||], b,[||]); - raise e)) - (fun g -> - try - let result = - report_error b the_goal the_ast returned_path (2::path) g in - the_count := !the_count + 1; - result - with - e -> - if !the_count > 1 then - msgnl - (str "in branch no " ++ int !the_count ++ - str " after tactic " ++ pr_glob_tactic a); - raise e) - | tac -> - (fun g -> - try - Tacinterp.eval_tactic tac g - with - e -> - (the_ast := tac; - the_goal := Some g; - returned_path := path; - raise e));; - -let strip_some = function - Some n -> n - | None -> failwith "No optional value";; - -let descr_first_error tac = - (fun g -> - let the_goal = ref (None : goal sigma option) in - let the_ast = ref tac in - let the_path = ref ([] : int list) in - try - let result = report_error tac the_goal the_ast the_path [] g in - msgnl (str "no Error here"); - result - with - e -> - (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ - fnl () ++ Cerrors.explain_exn e ++ fnl () ++ - fnl () ++ str "on goal" ++ fnl () ++ - Printer.pr_goal (sig_it (strip_some !the_goal)) ++ - fnl () ++ str "faulty tactic is" ++ fnl () ++ fnl () ++ - pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ()); - tclIDTAC g)) - -(* TODO ... used ?? -add_tactic "DebugTac2" descr_first_error;; -*) - -(* -TACTIC EXTEND DebugTac2 - [ ??? ] -> [ descr_first_error tac ] -END -*) diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli deleted file mode 100644 index da4bbaa0..00000000 --- a/contrib/interface/debug_tac.mli +++ /dev/null @@ -1,6 +0,0 @@ - -val report_error : Tacexpr.glob_tactic_expr -> - Proof_type.goal Evd.sigma option ref -> - Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;; - -val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;; diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml deleted file mode 100644 index e0f43193..00000000 --- a/contrib/interface/depends.ml +++ /dev/null @@ -1,454 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant *) -(* <O___,, * *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1, *) -(* * or (at your option) any later version. *) -(************************************************************************) - -(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *) - -(* This is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) -(* Lesser General Public License for more details. *) - -(* You should have received a copy of the GNU Lesser General Public *) -(* License along with this library; if not, write to the Free Software *) -(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, *) -(* MA 02110-1301, USA *) - - -(* LEM TODO: a .mli file *) - -open Refiner -open Proof_type -open Rawterm -open Term -open Libnames -open Util -open Tacexpr -open Entries - -(* DBG utilities, to be removed *) -let print_bool b = print_string (string_of_bool b) -let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter() -let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O" -(* End utilities, to be removed *) - -let explore_tree pfs = - print_string "explore_tree called\n"; - print_string "pfs is a top: "; - (* We expect yes. *) - print_string (if (is_top_pftreestate pfs) then "yes" else "no"); - print_newline(); - let rec explain_tree (pt:proof_tree) = - match pt.ref with - | None -> "none" - | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" - | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" - | Some (Decl_proof _, _) -> "Decl_proof" - | Some (Daimon, _) -> "Daimon" - and explain_compound cr = - match cr with - | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")" - | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")" - and explain_prim = function - | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c)) - | Intro identifier -> "Intro" - | Cut (bool, _, identifier, types) -> "Cut" - | FixRule (identifier, int, l, _) -> "FixRule" - | Cofix (identifier, l, _) -> "Cofix" - | Convert_concl (types, cast_kind) -> "Convert_concl" - | Convert_hyp named_declaration -> "Convert_hyp" - | Thin identifier_list -> "Thin" - | ThinBody identifier_list -> "ThinBody" - | Move (bool, identifier, identifier') -> "Move" - | Rename (identifier, identifier') -> "Rename" - | Change_evars -> "Change_evars" - | Order _ -> "Order" - in - let pt = proof_of_pftreestate pfs in - (* We expect 0 *) - print_string "Number of open subgoals: "; - print_int pt.open_subgoals; - print_newline(); - print_string "First rule is a "; - print_string (explain_tree pt); - print_newline() - - -let o f g x = f (g x) -let fst_of_3 (x, _, _) = x -let snd_of_3 (_, x, _) = x -let trd_of_3 (_, _, x) = x - -(* TODO: These for now return a Libnames.global_reference, but a - prooftree will also depend on things like tactic declarations, etc - so we may need a new type for that. *) -let rec depends_of_hole_kind hk acc = match hk with - | Evd.ImplicitArg (gr,_) -> gr::acc - | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc - | Evd.BinderType _ - | Evd.QuestionMark _ - | Evd.CasesType - | Evd.InternalHole - | Evd.GoalEvar - | Evd.ImpossibleCase -> acc - -let depends_of_'a_cast_type depends_of_'a act acc = match act with - | CastConv (ck, a) -> depends_of_'a a acc - | CastCoerce -> acc - -let depends_of_'a_bindings depends_of_'a ab acc = match ab with - | ImplicitBindings al -> list_union_map depends_of_'a al acc - | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc - | NoBindings -> acc - -let depends_of_'a_with_bindings depends_of_'a (a, ab) acc = - depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc) - -(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *) -(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *) - -let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with - | ElimOnConstr a -> depends_of_'a a acc - | ElimOnIdent _ -> - (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.) - * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-( - - * Plan: Load all section variables before anything in that - * section and call the user's proof script "brittle" and refuse - * to handle if it breaks because of that - *) - acc - | ElimOnAnonHyp _ -> acc - -let depends_of_'a_or_var depends_of_'a aov acc = match aov with - | ArgArg a -> depends_of_'a a acc - | ArgVar _ -> acc - -let depends_of_'a_with_occurences depends_of_'a (_,a) acc = - depends_of_'a a acc - -let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with - (* TODO: dirty assumption that the 'b doesn't make any dependency *) - | Red _ - | Hnf - | Cbv _ - | Lazy _ - | Unfold _ - | ExtraRedExpr _ - | CbvVm -> acc - | Simpl awoo -> - Option.fold_right - (depends_of_'a_with_occurences depends_of_'a) - awoo - acc - | Fold al -> list_union_map depends_of_'a al acc - | Pattern awol -> - list_union_map - (depends_of_'a_with_occurences depends_of_'a) - awol - acc - -let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with - (* TODO: dirty assumption that the 'b doesn't make any dependency *) - | NonDepInversion _ -> acc - | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc - | InversionUsing (a, _) -> depends_of_'a a acc - -let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc - -let depends_of_named_vals nvs acc = - (* TODO: I'm stopping here because I have noooo idea what to do with values... *) - acc - -let depends_of_inductive ind acc = (IndRef ind)::acc - -let rec depends_of_constr c acc = match kind_of_term c with - | Rel _ -> acc - | Var id -> (VarRef id)::acc - | Meta _ -> acc - | Evar ev -> depends_of_'a_pexistential depends_of_constr ev acc - | Sort _ -> acc - | Cast (c, _, t) -> depends_of_constr c (depends_of_constr t acc) - | Prod (_, t, t') -> depends_of_constr t (depends_of_constr t' acc) - | Lambda (_, t, c) -> depends_of_constr t (depends_of_constr c acc) - | LetIn (_, c, t, c') -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc)) - | App (c, ca) -> depends_of_constr c (array_union_map depends_of_constr ca acc) - | Const cnst -> (ConstRef cnst)::acc - | Ind ind -> (IndRef ind)::acc - | Construct cons -> (ConstructRef cons)::acc - | Case (_, c, c', ca) -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc)) - | Fix (_, (_, ta, ca)) - | CoFix (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc) -and depends_of_evar_map evm acc = - Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc -and depends_of_evar_info evi acc = - (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *) - depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc)) -and depends_of_evar_body evb acc = match evb with - | Evd.Evar_empty -> acc - | Evd.Evar_defined c -> depends_of_constr c acc -and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc -and depends_of_named_context_val ncv acc = - depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc) -and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc) - - - -let depends_of_open_constr (evm,c) acc = - depends_of_constr c (depends_of_evar_map evm acc) - -let rec depends_of_rawconstr rc acc = match rc with - | RRef (_,r) -> r::acc - | RVar (_, id) -> (VarRef id)::acc - | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc - | RPatVar _ -> acc - | RApp (_, rc, rcl) -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc) - | RLambda (_, _, _, rct, rcb) - | RProd (_, _, _, rct, rcb) - | RLetIn (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc) - | RCases (_, _, rco, tmt, cc) -> - (* LEM TODO: handle the cc *) - (Option.fold_right depends_of_rawconstr rco - (list_union_map - (fun (rc, pp) acc -> - Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp) - (depends_of_rawconstr rc acc)) - tmt - acc)) - | RLetTuple (_,_,(_,rco),rc0,rc1) -> - depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc)) - | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in - dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc)))) - | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in - dorca rca0 (dorca rca1 (array_union_map - (list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc))) - rdla - acc)) - | RSort _ -> acc - | RHole (_, hk) -> depends_of_hole_kind hk acc - | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc) - | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*) -and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l - -let depends_of_rawconstr_and_expr (rc, _) acc = - (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *) - depends_of_rawconstr rc acc - -let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac = - (* TODO: - * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies - *) - let rec depends_of_tacexpr texp acc = match texp with - | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc - | TacThen (tac0, taca0, tac1, taca1) -> - depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc))) - | TacThens (tac, tacl) -> - depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc) - | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc - | TacComplete tac -> depends_of_tacexpr tac acc - | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc - | TacTry tac -> depends_of_tacexpr tac acc - | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc) - | TacDo (_, tac) -> depends_of_tacexpr tac acc - | TacRepeat tac -> depends_of_tacexpr tac acc - | TacProgress tac -> depends_of_tacexpr tac acc - | TacAbstract (tac, _) -> depends_of_tacexpr tac acc - | TacId _ - | TacFail _ -> acc - | TacInfo tac -> depends_of_tacexpr tac acc - | TacLetIn (_, igtal, tac) -> - depends_of_tacexpr - tac - (list_union_map - (fun x y -> depends_of_tac_arg (snd x) y) - igtal - acc) - | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet" - | TacMatchGoal (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet" - | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc - | TacArg tacarg -> depends_of_tac_arg tacarg acc - and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with - (* Basic tactics *) - | TacIntroPattern _ - | TacIntrosUntil _ - | TacIntroMove _ - | TacAssumption -> acc - | TacExact c - | TacExactNoCheck c - | TacVmCastNoCheck c -> depends_of_'constr c acc - | TacApply (_, _, [cb], None) -> depends_of_'constr_with_bindings cb acc - | TacApply (_, _, _, _) -> failwith "TODO" - | TacElim (_, cwb, cwbo) -> - depends_of_'constr_with_bindings cwb - (Option.fold_right depends_of_'constr_with_bindings cwbo acc) - | TacElimType c -> depends_of_'constr c acc - | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc - | TacCaseType c -> depends_of_'constr c acc - | TacFix _ - | TacMutualFix _ - | TacCofix _ - | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet" - | TacCut c -> depends_of_'constr c acc - | TacAssert (taco, _, c) -> - Option.fold_right depends_of_'tac taco (depends_of_'constr c acc) - | TacGeneralize cl -> - list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl) - acc - | TacGeneralizeDep c -> depends_of_'constr c acc - | TacLetTac (_,c,_,_) -> depends_of_'constr c acc - - (* Derived basic tactics *) - | TacSimpleInductionDestruct _ - | TacDoubleInduction _ -> acc - | TacInductionDestruct (_, _, [cwbial, cwbo, _, _]) -> - list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings) - cwbial - (Option.fold_right depends_of_'constr_with_bindings cwbo acc) - | TacInductionDestruct (_, _, _) -> failwith "TODO" - | TacDecomposeAnd c - | TacDecomposeOr c -> depends_of_'constr c acc - | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc) - | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc - | TacLApply c -> depends_of_'constr c acc - - (* Automation tactics *) - | TacTrivial (cl, bs) -> - (* TODO: Maybe make use of bs: list of hint bases to be used. *) - list_union_map depends_of_'constr cl acc - | TacAuto (_, cs, bs) -> - (* TODO: Maybe make use of bs: list of hint bases to be used. - None -> all ("with *") - Some list -> a list, "core" added implicitly *) - list_union_map depends_of_'constr cs acc - | TacAutoTDB _ -> acc - | TacDestructHyp _ -> acc - | TacDestructConcl -> acc - | TacSuperAuto _ -> (* TODO: this reference thing is scary*) - acc - | TacDAuto _ -> acc - - (* Context management *) - | TacClear _ - | TacClearBody _ - | TacMove _ - | TacRename _ - | TacRevert _ -> acc - - (* Constructors *) - | TacLeft (_,cb) - | TacRight (_,cb) - | TacSplit (_, _, cb) - | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc - | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc - - (* Conversion *) - | TacReduce (reg,_) -> - depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc - | TacChange (cwoo, c, _) -> - depends_of_'constr - c - (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc) - - (* Equivalence relations *) - | TacReflexivity - | TacSymmetry _ -> acc - | TacTransitivity c -> depends_of_'constr c acc - - (* Equality and inversion *) - | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc - | TacInversion (is, _) -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc - - (* For ML extensions *) - | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented" - - (* For syntax extensions *) - | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented" - and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet" - and depends_of_tac_arg ta acc = match ta with - | TacDynamic (_,d) -> failwith "Don't know what to do with a Dyn in tac_arg" - | TacVoid -> acc - | MetaIdArg _ -> failwith "Don't know what to do with a MetaIdArg in tac_arg" - | ConstrMayEval me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval" - | IntroPattern _ -> acc - | Reference ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) - | Integer _ -> acc - | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) - list_union_map depends_of_tac_arg l acc - | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc - | TacFreshId _ -> acc - | Tacexp tac -> - depends_of_'tac tac acc - in - depends_of_tacexpr - -let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc = - depends_of_gen_tactic_expr - depends_of_rawconstr_and_expr - (depends_of_'a_or_var depends_of_inductive) - depends_of_glob_tactic_expr - gte - acc - -let rec depends_of_tacexpr te acc = - depends_of_gen_tactic_expr - depends_of_open_constr - depends_of_inductive - depends_of_glob_tactic_expr - te - acc - -let depends_of_compound_rule cr acc = match cr with - | Tactic (texp, _) -> depends_of_tacexpr texp acc - | Proof_instr (b, instr) -> - (* TODO: What is the boolean b? Should check. *) - failwith "Dependency calculation of Proof_instr not implemented yet" -and depends_of_prim_rule pr acc = match pr with - | Refine c -> depends_of_constr c acc - | Intro id -> acc - | Cut (_, _, _, t) -> depends_of_constr t acc (* TODO: check what 3nd argument contains *) - | FixRule (_, _, l, _) -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *) - | Cofix (_, l, _) -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *) - | Convert_concl (t, _) -> depends_of_constr t acc - | Convert_hyp (_, None, t) -> depends_of_constr t acc - | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc) - | Thin _ -> acc - | ThinBody _ -> acc - | Move _ -> acc - | Rename _ -> acc - | Change_evars -> acc - | Order _ -> acc - -let rec depends_of_pftree pt acc = - match pt.ref with - | None -> acc - | Some (Prim pr , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l acc) - | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc)) - | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc - | Some (Daimon, l) -> list_union_map depends_of_pftree l acc - -let rec depends_of_pftree_head pt acc = - match pt.ref with - | None -> acc - | Some (Prim pr , l) -> depends_of_prim_rule pr acc - | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc) - | Some (Decl_proof _ , l) -> acc - | Some (Daimon, l) -> acc - -let depends_of_pftreestate depends_of_pftree pfs = -(* print_string "depends_of_pftreestate called\n"; *) -(* explore_tree pfs; *) - let pt = proof_of_pftreestate pfs in - assert (is_top_pftreestate pfs); - assert (pt.open_subgoals = 0); - depends_of_pftree pt [] - -let depends_of_definition_entry de ~acc = - Option.fold_right - depends_of_constr - de.const_entry_type - (depends_of_constr de.const_entry_body acc) diff --git a/contrib/interface/history.ml b/contrib/interface/history.ml deleted file mode 100644 index f73c2084..00000000 --- a/contrib/interface/history.ml +++ /dev/null @@ -1,373 +0,0 @@ -open Paths;; - -type tree = {mutable index : int; - parent : tree option; - path_to_root : int list; - mutable is_open : bool; - mutable sub_proofs : tree list};; - -type prf_info = { - mutable prf_length : int; - mutable ranks_and_goals : (int * int * tree) list; - mutable border : tree list; - prf_struct : tree};; - -let theorem_proofs = ((Hashtbl.create 17): - (string, prf_info) Hashtbl.t);; - - -let rec mk_trees_for_goals path tree rank k n = - if k = (n + 1) then - [] - else - { index = rank; - parent = tree; - path_to_root = k::path; - is_open = true; - sub_proofs = [] } ::(mk_trees_for_goals path tree rank (k+1) n);; - - -let push_command s rank ngoals = - let ({prf_length = this_length; - ranks_and_goals = these_ranks; - border = this_border} as proof_info) = - Hashtbl.find theorem_proofs s in - let rec push_command_aux n = function - [] -> failwith "the given rank was too large" - | a::l -> - if n = 1 then - let {path_to_root = p} = a in - let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in - new_trees,(new_trees@l),a - else - let new_trees, res, this_tree = push_command_aux (n-1) l in - new_trees,(a::res),this_tree in - let new_trees, new_border, this_tree = - push_command_aux rank this_border in - let new_length = this_length + 1 in - begin - proof_info.border <- new_border; - proof_info.prf_length <- new_length; - proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks; - this_tree.index <- new_length; - this_tree.is_open <- false; - this_tree.sub_proofs <- new_trees - end;; - -let get_tree_for_rank thm_name rank = - let {ranks_and_goals=l;prf_length=n} = - Hashtbl.find theorem_proofs thm_name in - let rec get_tree_aux = function - [] -> - failwith - "inconsistent values for thm_name and rank in get_tree_for_rank" - | (_,_,({index=i} as tree))::tl -> - if i = rank then - tree - else - get_tree_aux tl in - get_tree_aux l;; - -let get_path_for_rank thm_name rank = - let {path_to_root=l}=get_tree_for_rank thm_name rank in - l;; - -let rec list_descendants_aux l tree = - let {index = i; is_open = open_status; sub_proofs = tl} = tree in - let res = (List.fold_left list_descendants_aux l tl) in - if open_status then i::res else res;; - -let list_descendants thm_name rank = - list_descendants_aux [] (get_tree_for_rank thm_name rank);; - -let parent_from_rank thm_name rank = - let {parent=mommy} = get_tree_for_rank thm_name rank in - match mommy with - Some x -> Some x.index - | None -> None;; - -let first_child_command thm_name rank = - let {sub_proofs = l} = get_tree_for_rank thm_name rank in - let rec first_child_rec = function - [] -> None - | {index=i;is_open=b}::l -> - if b then - (first_child_rec l) - else - Some i in - first_child_rec l;; - -type index_or_rank = Is_index of int | Is_rank of int;; - -let first_child_command_or_goal thm_name rank = - let proof_info = Hashtbl.find theorem_proofs thm_name in - let {sub_proofs=l}=get_tree_for_rank thm_name rank in - match l with - [] -> None - | ({index=i;is_open=b} as t)::_ -> - if b then - let rec get_rank n = function - [] -> failwith "A goal is lost in first_child_command_or_goal" - | a::l -> - if a==t then - n - else - get_rank (n + 1) l in - Some(Is_rank(get_rank 1 proof_info.border)) - else - Some(Is_index i);; - -let next_sibling thm_name rank = - let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in - match mommy with - None -> None - | Some real_mommy -> - let {sub_proofs=l}=real_mommy in - let rec next_sibling_aux b = function - (opt_first, []) -> - if b then - opt_first - else - failwith "inconsistency detected in next_sibling" - | (opt_first, {is_open=true}::l) -> - next_sibling_aux b (opt_first, l) - | (Some(first),({index=i; is_open=false} as t')::l) -> - if b then - Some i - else - next_sibling_aux (t == t') (Some first,l) - | None,({index=i;is_open=false} as t')::l -> - next_sibling_aux (t == t') ((Some i), l) - in - Some (next_sibling_aux false (None, l));; - - -let prefix l1 l2 = - let l1rev = List.rev l1 in - let l2rev = List.rev l2 in - is_prefix l1rev l2rev;; - -let rec remove_all_prefixes p = function - [] -> [] - | a::l -> - if is_prefix p a then - (remove_all_prefixes p l) - else - a::(remove_all_prefixes p l);; - -let recompute_border tree = - let rec recompute_border_aux tree acc = - let {is_open=b;sub_proofs=l}=tree in - if b then - tree::acc - else - List.fold_right recompute_border_aux l acc in - recompute_border_aux tree [];; - - -let historical_undo thm_name rank = - let ({ranks_and_goals=l} as proof_info)= - Hashtbl.find theorem_proofs thm_name in - let rec undo_aux acc = function - [] -> failwith "bad rank provided for undoing in historical_undo" - | (r, n, ({index=i} as tree))::tl -> - let this_path_reversed = List.rev tree.path_to_root in - let res = remove_all_prefixes this_path_reversed acc in - if i = rank then - begin - proof_info.prf_length <- i-1; - proof_info.ranks_and_goals <- tl; - tree.is_open <- true; - tree.sub_proofs <- []; - proof_info.border <- recompute_border proof_info.prf_struct; - this_path_reversed::res - end - else - begin - tree.is_open <- true; - tree.sub_proofs <- []; - undo_aux (this_path_reversed::res) tl - end - in - List.map List.rev (undo_aux [] l);; - -(* The following function takes a list of trees and compute the - number of elements whose path is lexically smaller or a suffixe of - the path given as a first argument. This works under the precondition that - the list is lexicographically order. *) - -let rec logical_undo_on_border the_tree rev_path = function - [] -> (0,[the_tree]) - | ({path_to_root=p}as tree)::tl -> - let p_rev = List.rev p in - if is_prefix rev_path p_rev then - let (k,res) = (logical_undo_on_border the_tree rev_path tl) in - (k+1,res) - else if lex_smaller p_rev rev_path then - let (k,res) = (logical_undo_on_border the_tree rev_path tl) in - (k,tree::res) - else - (0, the_tree::tree::tl);; - - -let logical_undo thm_name rank = - let ({ranks_and_goals=l; border=last_border} as proof_info)= - Hashtbl.find theorem_proofs thm_name in - let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in - let rev_ref_path = List.rev ref_path in - let rec logical_aux lex_smaller_offset family_width = function - [] -> failwith "this case should never happen in logical_undo" - | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree)):: - tl -> - let this_path_rev = List.rev this_path in - let new_rank, new_offset, new_width, kept = - if is_prefix rev_ref_path this_path_rev then - (r + lex_smaller_offset), lex_smaller_offset, - (family_width + 1 - n), false - else if lex_smaller this_path_rev rev_ref_path then - r, (lex_smaller_offset - 1 + n), family_width, true - else - (r + 1 - family_width+ lex_smaller_offset), - lex_smaller_offset, family_width, true in - if i=rank then - [i,new_rank],[], tl, rank - else - let ranks_undone, ranks_kept, ranks_and_goals, current_rank = - (logical_aux new_offset new_width tl) in - begin - if kept then - begin - tree.index <- current_rank; - ranks_undone, ((i,new_rank)::ranks_kept), - ((new_rank, n, tree)::ranks_and_goals), - (current_rank + 1) - end - else - ((i,new_rank)::ranks_undone), ranks_kept, - ranks_and_goals, current_rank - end in - let number_suffix, new_border = - logical_undo_on_border ref_tree rev_ref_path last_border in - let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, - new_length_plus_one = logical_aux 0 number_suffix l in - let the_goal_index = - let rec compute_goal_index n = function - [] -> failwith "this case should never happen in logical undo (2)" - | {path_to_root=path}::tl -> - if List.rev path = (rev_ref_path) then - n - else - compute_goal_index (n+1) tl in - compute_goal_index 1 new_border in - begin - ref_tree.is_open <- true; - ref_tree.sub_proofs <- []; - proof_info.border <- new_border; - proof_info.ranks_and_goals <- new_ranks_and_goals; - proof_info.prf_length <- new_length_plus_one - 1; - changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, - the_goal_index - end;; - -let start_proof thm_name = - let the_tree = - {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in - Hashtbl.add theorem_proofs thm_name - {prf_length=0; - ranks_and_goals=[]; - border=[the_tree]; - prf_struct=the_tree};; - -let dump_sequence chan s = - match (Hashtbl.find theorem_proofs s) with - {ranks_and_goals=l}-> - let rec dump_rec = function - [] -> () - | (r,n,_)::tl -> - dump_rec tl; - output_string chan (string_of_int r); - output_string chan ","; - output_string chan (string_of_int n); - output_string chan "\n" in - begin - dump_rec l; - output_string chan "end\n" - end;; - - -let proof_info_as_string s = - let res = ref "" in - match (Hashtbl.find theorem_proofs s) with - {prf_struct=tree} -> - let open_goal_counter = ref 0 in - let rec dump_rec = function - {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> - begin - (match the_parent with - None -> - if op then - res := !res ^ "\"open goal\"\n" - | Some {index=j} -> - begin - res := !res ^ (string_of_int j); - res := !res ^ " -> "; - if op then - begin - res := !res ^ "\"open goal "; - open_goal_counter := !open_goal_counter + 1; - res := !res ^ (string_of_int !open_goal_counter); - res := !res ^ "\"\n"; - end - else - begin - res := !res ^ (string_of_int i); - res := !res ^ "\n" - end - end); - List.iter dump_rec trees - end in - dump_rec tree; - !res;; - - -let dump_proof_info chan s = - match (Hashtbl.find theorem_proofs s) with - {prf_struct=tree} -> - let open_goal_counter = ref 0 in - let rec dump_rec = function - {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> - begin - (match the_parent with - None -> - if op then - output_string chan "\"open goal\"\n" - | Some {index=j} -> - begin - output_string chan (string_of_int j); - output_string chan " -> "; - if op then - begin - output_string chan "\"open goal "; - open_goal_counter := !open_goal_counter + 1; - output_string chan (string_of_int !open_goal_counter); - output_string chan "\"\n"; - end - else - begin - output_string chan (string_of_int i); - output_string chan "\n" - end - end); - List.iter dump_rec trees - end in - dump_rec tree;; - -let get_nth_open_path s n = - match Hashtbl.find theorem_proofs s with - {border=l} -> - let {path_to_root=p}=List.nth l (n - 1) in - p;; - -let border_length s = - match Hashtbl.find theorem_proofs s with - {border=l} -> List.length l;; diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli deleted file mode 100644 index 053883f0..00000000 --- a/contrib/interface/history.mli +++ /dev/null @@ -1,12 +0,0 @@ -type prf_info;; - -val start_proof : string -> unit;; -val historical_undo : string -> int -> int list list -val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int -val dump_sequence : out_channel -> string -> unit -val proof_info_as_string : string -> string -val dump_proof_info : out_channel -> string -> unit -val push_command : string -> int -> int -> unit -val get_path_for_rank : string -> int -> int list -val get_nth_open_path : string -> int -> int list -val border_length : string -> int diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4 deleted file mode 100755 index 0b13a092..00000000 --- a/contrib/interface/line_parser.ml4 +++ /dev/null @@ -1,241 +0,0 @@ -(* line-oriented Syntactic analyser for a Coq parser *) -(* This parser expects a very small number of commands, each given on a complete -line. Some of these commands are then followed by a text fragment terminated -by a precise keyword, which is also expected to appear alone on a line. *) - -(* The main parsing loop procedure is "parser_loop", given at the end of this -file. It read lines one by one and checks whether they can be parsed using -a very simple parser. This very simple parser uses a lexer, which is also given -in this file. - -The lexical analyser: - There are only 5 sorts of tokens *) -type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | - Tlbracket | Trbracket;; - -(* When recognizing identifiers or strings, the lexical analyser accumulates - the characters in a buffer, using the command add_in_buff. To recuperate - the characters, one can use get_buff (this code was inspired by the - code in src/meta/lexer.ml of Coq revision 6.1) *) -let add_in_buff,get_buff = - let buff = ref (String.create 80) in - (fun i x -> - let len = String.length !buff in - if i >= len then (buff := !buff ^ (String.create len);()); - String.set !buff i x; - succ i), - (fun len -> String.sub !buff 0 len);; - -(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*. When arriving here the first - character has already been recognized. *) -let rec ident len = parser - [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] -> - ident (add_in_buff len c) s -| [< >] -> let str = get_buff len in Tid(str);; - -(* While recognizing integers, one constructs directly the integer value. - The ascii code of '0' is important for this. *) -let code0 = Char.code '0';; - -let get_digit c = Char.code c - code0;; - -(* Integers are [0-9]* - The variable intval is the integer value of the text that has already - been recognized. As for identifiers, the first character has already been - recognized. *) - -let rec parse_int intval = parser - [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i -| [< >] -> Tint intval;; - -(* The string lexer is borrowed from the string parser of Coq V6.1 - This may be a problem if convention have changed in Coq, - However this parser is only used to recognize file names which should - not contain too many special characters *) - -let rec spec_char = parser - [< ''n' >] -> '\n' -| [< ''t' >] -> '\t' -| [< ''b' >] -> '\008' -| [< ''r' >] -> '\013' -| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> - Char.chr v -| [< 'x >] -> x - -and spec1 v = parser - [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s -| [< >] -> v -;; - -(* This is the actual string lexical analyser. Strings are - QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used - to represents double quotation characters, that cannot be used - freely, even inside comments. *) - -let rec string len = parser - [< ''"' >] -> len -| [<''\\' ; - len = (parser [< ''\n' >] -> len - | [< c=spec_char >] -> add_in_buff len c); - s >] -> string len s -| [< 'x; s >] -> string (add_in_buff len x) s;; - -(* The lexical analyser repeats the recognized given by next_token: - spaces and tabulations are ignored, identifiers, integers, - strings, opening and closing square brackets. Lexical errors are - ignored ! *) -let rec next_token = parser _count - [< '' ' | '\t'; tok = next_token >] -> tok -| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i -| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i -| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len) -| [< ''[' >] -> Tlbracket -| [< '']' >] -> Trbracket -| [< '_ ; x = next_token >] -> x;; - -(* A very simple lexical analyser to recognize a integer value behind - blank characters *) - -let rec next_int = parser _count - [< '' ' | '\t'; v = next_int >] -> v -| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] -> - (match i with - Tint n -> n - | _ -> failwith "unexpected branch in next_int");; - -(* This is the actual lexical analyser, implemented as a function on a stream. - It will be used with the Stream.from primitive to construct a function - of type char Stream.t -> simple_token option Stream.t *) -let token_stream cs _ = - try let tok = next_token cs in - Some tok - with Stream.Failure -> None;; - -(* Two of the actions of the parser request that one reads the rest of - the input up to a specific string stop_string. This is done - with a function that transform the input_channel into a pair of - char Stream.t, reading from the input_channel all the lines to - the stop_string first. *) - - -let rec gather_strings stop_string input_channel = - let buff = input_line input_channel in - if buff = stop_string then - [] - else - (buff::(gather_strings stop_string input_channel));; - - -(* the result of this function is supposed to be used in a Stream.from - construction. *) - -let line_list_to_stream string_list = - let count = ref 0 in - let buff = ref "" in - let reserve = ref string_list in - let current_length = ref 0 in - (fun i -> if (i - !count) >= !current_length then - begin - count := !count + !current_length + 1; - match !reserve with - | [] -> None - | s1::rest -> - begin - buff := s1; - current_length := String.length !buff; - reserve := rest; - Some '\n' - end - end - else - Some(String.get !buff (i - !count)));; - - -(* In older revisions of this file you would find a function that - does line oriented breakdown of the input channel without resorting to - a list of lines. However, the need for the list of line appeared when - we wanted to have a channel and a list of strings describing the same - data, one for regular parsing and the other for error recovery. *) - -let channel_to_stream_and_string_list stop_string input_channel = - let string_list = gather_strings stop_string input_channel in - (line_list_to_stream string_list, string_list);; - -let flush_until_end_of_stream char_stream = - Stream.iter (function _ -> ()) char_stream;; - -(* There are only 5 kinds of lines recognized by our little parser. - Unrecognized lines are ignored. *) -type parser_request = - | PRINT_VERSION - | PARSE_STRING of string - (* parse_string <int> [<ident>] then text and && END--OF--DATA *) - | QUIET_PARSE_STRING - (* quiet_parse_string then text and && END--OF--DATA *) - | PARSE_FILE of string - (* parse_file <int> <string> *) - | ADD_PATH of string - (* add_path <int> <string> *) - | ADD_REC_PATH of string * string - (* add_rec_path <int> <string> <ident> *) - | LOAD_SYNTAX of string - (* load_syntax_file <int> <ident> *) - | GARBAGE -;; - -(* The procedure parser_loop should never terminate while the input_channel is - not closed. This procedure receives the functions called for each sentence - as arguments. Thus the code is completely independent from the Coq sources. *) -let parser_loop functions input_channel = - let print_version_action, - parse_string_action, - quiet_parse_string_action, - parse_file_action, - add_path_action, - add_rec_path_action, - load_syntax_action = functions in - let rec parser_loop_rec input_channel = - (let line = input_line input_channel in - let reqid, parser_request = - try - (match Stream.from (token_stream (Stream.of_string line)) with - parser - | [< 'Tid "print_version" >] -> - 0, PRINT_VERSION - | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; - 'Tid phylum ; 'Trbracket >] - -> reqid,PARSE_STRING phylum - | [< 'Tid "quiet_parse_string" >] -> - 0,QUIET_PARSE_STRING - | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] -> - reqid, PARSE_FILE fname - | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ; 'Tid alias >] - -> reqid, ADD_REC_PATH(directory, alias) - | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >] - -> reqid, ADD_PATH directory - | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] -> - reqid, LOAD_SYNTAX module_name - | [< 'Tid "quit_parser" >] -> raise End_of_file - | [< >] -> 0, GARBAGE) - with - Stream.Failure | Stream.Error _ -> 0,GARBAGE in - match parser_request with - PRINT_VERSION -> print_version_action () - | PARSE_STRING phylum -> - let regular_stream, string_list = - channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in - parse_string_action reqid phylum (Stream.from regular_stream) - string_list;() - | QUIET_PARSE_STRING -> - let regular_stream, string_list = - channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in - quiet_parse_string_action - (Stream.from regular_stream);() - | PARSE_FILE file_name -> - parse_file_action reqid file_name - | ADD_PATH path -> add_path_action reqid path - | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias - | LOAD_SYNTAX syn -> load_syntax_action reqid syn - | GARBAGE -> ()); - parser_loop_rec input_channel in - parser_loop_rec input_channel;; diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli deleted file mode 100644 index b0b043c7..00000000 --- a/contrib/interface/line_parser.mli +++ /dev/null @@ -1,5 +0,0 @@ -val parser_loop : - (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) * - (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) * - (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c -val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml deleted file mode 100644 index 0dc8f024..00000000 --- a/contrib/interface/name_to_ast.ml +++ /dev/null @@ -1,232 +0,0 @@ -open Sign;; -open Classops;; -open Names;; -open Nameops -open Term;; -open Impargs;; -open Reduction;; -open Libnames;; -open Libobject;; -open Environ;; -open Declarations;; -open Prettyp;; -open Inductive;; -open Util;; -open Pp;; -open Declare;; -open Nametab -open Vernacexpr;; -open Decl_kinds;; -open Constrextern;; -open Topconstr;; - -(* This function converts the parameter binders of an inductive definition, - in particular you have to be careful to handle each element in the - context containing all previously defined variables. This squeleton - of this procedure is taken from the function print_env in pretty.ml *) -let convert_env = - let convert_binder env (na, b, c) = - match b with - | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) - | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in - let rec cvrec env = function - [] -> [] - | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in - cvrec (Global.env());; - -(* let mib string = - let sp = Nametab.sp_of_id CCI (id_of_string string) in - let lobj = Lib.map_leaf (objsp_of sp) in - let (cmap, _) = outMutualInductive lobj in - Listmap.map cmap CCI;; *) - -(* This function is directly inspired by print_impl_args in pretty.ml *) - -let impl_args_to_string_by_pos = function - [] -> None - | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.") - | l -> Some (" positions " ^ - (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s) - l - " are implicit."));; - -(* This function is directly inspired by implicit_args_id in pretty.ml *) - -let impl_args_to_string l = - impl_args_to_string_by_pos (positions_of_implicits l) - -let implicit_args_id_to_ast_list id l ast_list = - (match impl_args_to_string l with - None -> ast_list - | Some(s) -> CommentString s:: - CommentString ("For " ^ (string_of_id id)):: - ast_list);; - -(* This function construct an ast to enumerate the implicit positions for an - inductive type and its constructors. It is obtained directly from - implicit_args_msg in pretty.ml. *) - -let implicit_args_to_ast_list sp mipv = - let implicit_args_descriptions = - let ast_list = ref [] in - (Array.iteri - (fun i mip -> - let imps = implicits_of_global (IndRef (sp, i)) in - (ast_list := - implicit_args_id_to_ast_list mip.mind_typename imps !ast_list; - Array.iteri - (fun j idc -> - let impls = implicits_of_global - (ConstructRef ((sp,i),j+1)) in - ast_list := - implicit_args_id_to_ast_list idc impls !ast_list) - mip.mind_consnames)) - mipv; - !ast_list) in - match implicit_args_descriptions with - [] -> [] - | _ -> [VernacComments (List.rev implicit_args_descriptions)];; - -(* This function converts constructors for an inductive definition to a - Coqast.t. It is obtained directly from print_constructors in pretty.ml *) - -let convert_constructors envpar names types = - let array_idC = - array_map2 - (fun n t -> - let coercion_flag = false (* arbitrary *) in - (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) - names types in - Array.to_list array_idC;; - -(* this function converts one inductive type in a possibly multiple inductive - definition *) - -let convert_one_inductive sp tyi = - let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in - let env = Global.env () in - let envpar = push_rel_context params env in - let sp = sp_of_global (IndRef (sp, tyi)) in - (((false,(dummy_loc,basename sp)), - convert_env(List.rev params), - Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw , - Constructors (convert_constructors envpar cstrnames cstrtypes)), None);; - -(* This function converts a Mutual inductive definition to a Coqast.t. - It is obtained directly from print_mutual in pretty.ml. However, all - references to kinds have been removed and it treats only CCI stuff. *) - -let mutual_to_ast_list sp mib = - let mipv = (Global.lookup_mind sp).mind_packets in - let _, l = - Array.fold_right - (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in - VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l) - :: (implicit_args_to_ast_list sp mipv);; - -let constr_to_ast v = - extern_constr true (Global.env()) v;; - -let implicits_to_ast_list implicits = - match (impl_args_to_string implicits) with - | None -> [] - | Some s -> [VernacComments [CommentString s]];; - -let make_variable_ast name typ implicits = - (VernacAssumption - ((Local,Definitional),false,(*inline flag*) - [false,([dummy_loc,name], constr_to_ast typ)])) - ::(implicits_to_ast_list implicits);; - - -let make_definition_ast name c typ implicits = - VernacDefinition ((Global,false,Definition), (dummy_loc,name), - DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)), - (fun _ _ -> ())) - ::(implicits_to_ast_list implicits);; - -(* This function is inspired by print_constant *) -let constant_to_ast_list kn = - let cb = Global.lookup_constant kn in - let c = cb.const_body in - let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in - let l = implicits_of_global (ConstRef kn) in - (match c with - None -> - make_variable_ast (id_of_label (con_label kn)) typ l - | Some c1 -> - make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) - -let variable_to_ast_list sp = - let (id, c, v) = Global.lookup_named sp in - let l = implicits_of_global (VarRef sp) in - (match c with - None -> - make_variable_ast id v l - | Some c1 -> - make_definition_ast id c1 v l);; - -(* this function is taken from print_inductive in file pretty.ml *) - -let inductive_to_ast_list sp = - let mib = Global.lookup_mind sp in - mutual_to_ast_list sp mib - -(* this function is inspired by print_leaf_entry from pretty.ml *) - -let leaf_entry_to_ast_list ((sp,kn),lobj) = - let tag = object_tag lobj in - match tag with - | "VARIABLE" -> variable_to_ast_list (basename sp) - | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) - | "INDUCTIVE" -> inductive_to_ast_list kn - | s -> - errorlabstrm - "print" (str ("printing of unrecognized object " ^ - s ^ " has been required"));; - - - - -(* this function is inspired by print_name *) -let name_to_ast ref = - let (loc,qid) = qualid_of_reference ref in - let l = - try - let sp = Nametab.locate_obj qid in - let (sp,lobj) = - let (sp,entry) = - List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None) - in - match entry with - | Lib.Leaf obj -> (sp,obj) - | _ -> raise Not_found - in - leaf_entry_to_ast_list (sp,lobj) - with Not_found -> - try - match Nametab.locate qid with - | ConstRef sp -> constant_to_ast_list sp - | IndRef (sp,_) -> inductive_to_ast_list sp - | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp - | VarRef sp -> variable_to_ast_list sp - with Not_found -> - try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,name = repr_qualid qid in - if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named name in - (match c with - None -> make_variable_ast name typ [] - | Some c1 -> make_definition_ast name c1 typ []) - with Not_found -> - try - let _sp = Nametab.locate_syntactic_definition qid in - errorlabstrm "print" - (str "printing of syntax definitions not implemented") - with Not_found -> - errorlabstrm "print" - (pr_qualid qid ++ - spc () ++ str "not a defined object") - in - VernacList (List.map (fun x -> (dummy_loc,x)) l) - diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli deleted file mode 100644 index f9e83b5e..00000000 --- a/contrib/interface/name_to_ast.mli +++ /dev/null @@ -1,5 +0,0 @@ -val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; -val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;; -val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;; -val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;; -val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml deleted file mode 100644 index 1bbab5fe..00000000 --- a/contrib/interface/parse.ml +++ /dev/null @@ -1,422 +0,0 @@ -open Util;; -open System;; -open Pp;; -open Libnames;; -open Library;; -open Ascent;; -open Vtp;; -open Xlate;; -open Line_parser;; -open Pcoq;; -open Vernacexpr;; -open Mltop;; - -type parsed_tree = - | P_cl of ct_COMMAND_LIST - | P_c of ct_COMMAND - | P_t of ct_TACTIC_COM - | P_f of ct_FORMULA - | P_id of ct_ID - | P_s of ct_STRING - | P_i of ct_INT;; - -let print_parse_results n msg = - Pp.msg - ( str "message\nparsed\n" ++ - int n ++ - str "\n" ++ - (match msg with - | P_cl x -> fCOMMAND_LIST x - | P_c x -> fCOMMAND x - | P_t x -> fTACTIC_COM x - | P_f x -> fFORMULA x - | P_id x -> fID x - | P_s x -> fSTRING x - | P_i x -> fINT x) ++ - str "e\nblabla\n"); - flush stdout;; - -let ctf_SyntaxErrorMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++ - int reqid ++ fnl () ++ - pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; -let ctf_SyntaxWarningMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++ - int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - -let ctf_FileErrorMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++ - int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ - fnl ();; - -let execute_when_necessary v = - (match v with - | VernacOpenCloseScope sc -> Vernacentries.interp v - | VernacRequire (_,_,l) -> - (try - Vernacentries.interp v - with _ -> - let l=prlist_with_sep spc pr_reference l in - msgnl (str "Reinterning of " ++ l ++ str " failed")) - | VernacRequireFrom (_,_,f) -> - (try - Vernacentries.interp v - with _ -> - msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) - | _ -> ()); v;; - -let parse_to_dot = - let rec dot st = match Stream.next st with - | ("", ".") -> () - | ("EOI", "") -> raise End_of_file - | _ -> dot st in - Gram.Entry.of_parser "Coqtoplevel.dot" dot;; - -let rec discard_to_dot stream = - try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with - | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;; - -let rec decompose_string_aux s n = - try let index = String.index_from s n '\n' in - (String.sub s n (index - n)):: - (decompose_string_aux s (index + 1)) - with Not_found -> [String.sub s n ((String.length s) - n)];; - -let decompose_string s n = - match decompose_string_aux s n with - ""::tl -> tl - | a -> a;; - -let make_string_list file_chan fst_pos snd_pos = - let len = (snd_pos - fst_pos) in - let s = String.create len in - begin - seek_in file_chan fst_pos; - really_input file_chan s 0 len; - decompose_string s 0; - end;; - -let rec get_sub_aux string_list snd_pos = - match string_list with - [] -> [] - | s::l -> - let len = String.length s in - if len >= snd_pos then - if snd_pos < 0 then - [] - else - [String.sub s 0 snd_pos] - else - s::(get_sub_aux l (snd_pos - len - 1));; - -let rec get_substring_list string_list fst_pos snd_pos = - match string_list with - [] -> [] - | s::l -> - let len = String.length s in - if fst_pos > len then - get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) - else - (* take into account the fact that carriage returns are not in the *) - (* strings. *) - let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in - if snd_pos > len then - String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2):: - (get_sub_aux l (snd_pos - len - 2)) - else - let gap = (snd_pos - fst_pos2) in - if gap < 0 then - [] - else - [String.sub s (fst_pos2 - 1) gap];; - -(* When parsing a list of commands, we try to recover error messages for - each individual command. *) - -type parse_result = - | ParseOK of Vernacexpr.vernac_expr located option - | ParseError of string * string list - -let embed_string s = - CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s)) - -let make_parse_error_item s l = - CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l)) - -let parse_command_list reqid stream string_list = - let rec parse_whole_stream () = - let this_pos = Stream.count stream in - let first_ast = - try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) - with - | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> - begin - msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); - try - discard_to_dot stream; - msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ - int (Stream.count stream)); - ParseError ("PARSING_ERROR", - get_substring_list string_list this_pos - (Stream.count stream)) - with End_of_file -> ParseOK None - end - | e-> - begin - discard_to_dot stream; - ParseError ("PARSING_ERROR2", - get_substring_list string_list this_pos (Stream.count stream)) - end in - match first_ast with - | ParseOK (Some (loc,ast)) -> - let _ast0 = (execute_when_necessary ast) in - (try xlate_vernac ast - with e -> - make_parse_error_item "PARSING_ERROR2" - (get_substring_list string_list this_pos - (Stream.count stream)))::parse_whole_stream() - | ParseOK None -> [] - | ParseError (s,l) -> - (make_parse_error_item s l)::parse_whole_stream() - in - match parse_whole_stream () with - | first_one::tail -> (P_cl (CT_command_list(first_one, tail))) - | [] -> raise (UserError ("parse_string", (str "empty text.")));; - -(*When parsing a string using a phylum, the string is first transformed - into a Coq Ast using the regular Coq parser, then it is transformed into - the right ascent term using xlate functions, then it is transformed into - a stream, using the right vtp function. There is a special case for commands, - since some of these must be executed!*) -let parse_string_action reqid phylum char_stream string_list = - try let msg = - match phylum with - | "COMMAND_LIST" -> - parse_command_list reqid char_stream string_list - | "COMMAND" -> - P_c - (xlate_vernac - (execute_when_necessary - (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) - | "TACTIC_COM" -> - P_t - (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi - (Gram.parsable char_stream))) - | "FORMULA" -> - P_f - (xlate_formula - (Gram.Entry.parse - (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) - | "ID" -> P_id (CT_ident - (Libnames.string_of_qualid - (snd - (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) - (Gram.parsable char_stream))))) - | "STRING" -> - P_s - (CT_string (Gram.Entry.parse Pcoq.Prim.string - (Gram.parsable char_stream))) - | "INT" -> - P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural - (Gram.parsable char_stream))) - | _ -> error "parse_string_action : bad phylum" in - print_parse_results reqid msg - with - | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> - flush_until_end_of_stream char_stream; - msgnl (ctf_SyntaxErrorMessage reqid - (Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error "match failure")))) - | e -> - flush_until_end_of_stream char_stream; - msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));; - - -let quiet_parse_string_action char_stream = - try let _ = - Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in - () - with - | _ -> flush_until_end_of_stream char_stream; ();; - - -let parse_file_action reqid file_name = - try let file_chan = open_in file_name in - (* file_chan_err, stream_err are the channel and stream used to - get the text when a syntax error occurs *) - let file_chan_err = open_in file_name in - let stream = Stream.of_channel file_chan in - let _stream_err = Stream.of_channel file_chan_err in - let rec discard_to_dot () = - try Gram.Entry.parse parse_to_dot (Gram.parsable stream) - with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in - match let rec parse_whole_file () = - let this_pos = Stream.count stream in - match - try - ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) - with - | Stdpp.Exc_located(l,Stream.Error txt) -> - msgnl (ctf_SyntaxWarningMessage reqid - (str "Error with file" ++ spc () ++ - str file_name ++ fnl () ++ - Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error txt)))); - (try - begin - discard_to_dot (); - ParseError ("PARSING_ERROR", - (make_string_list file_chan_err this_pos - (Stream.count stream))) - end - with End_of_file -> ParseOK None) - | e -> - begin - Gram.Entry.parse parse_to_dot (Gram.parsable stream); - ParseError ("PARSING_ERROR2", - (make_string_list file_chan this_pos - (Stream.count stream))) - end - - with - | ParseOK (Some (_,ast)) -> - let _ast0=(execute_when_necessary ast) in - let term = - (try xlate_vernac ast - with e -> - print_string ("translation error between " ^ - (string_of_int this_pos) ^ - " " ^ - (string_of_int (Stream.count stream)) ^ - "\n"); - make_parse_error_item "PARSING_ERROR2" - (make_string_list file_chan_err this_pos - (Stream.count stream))) in - term::parse_whole_file () - | ParseOK None -> [] - | ParseError (s,l) -> - (make_parse_error_item s l)::parse_whole_file () in - parse_whole_file () with - | first_one :: tail -> - print_parse_results reqid - (P_cl (CT_command_list (first_one, tail))) - | [] -> raise (UserError ("parse_file_action", str "empty file.")) - with - | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> - msgnl - (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ - fnl () ++ - Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error "match failure")))) - | e -> - msgnl - (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ - fnl () ++ Cerrors.explain_exn e));; - -let add_rec_path_action reqid string_arg ident_arg = - let directory_name = expand_path_macros string_arg in - begin - add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) - end;; - - -let add_path_action reqid string_arg = - let directory_name = expand_path_macros string_arg in - begin - add_path directory_name Names.empty_dirpath - end;; - -let print_version_action () = - msgnl (mt ()); - msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");; - -let load_syntax_action reqid module_name = - msg (str "loading " ++ str module_name ++ str "... "); - try - (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in - require_library [dummy_loc,qid] None; - msg (str "opening... "); - Declaremods.import_module false (Nametab.locate_module qid); - msgnl (str "done" ++ fnl ()); - ()) - with - | UserError (label, pp_stream) -> - (*This one may be necessary to make sure that the message won't be indented *) - msgnl (mt ()); - msgnl - (fnl () ++ str "error while loading syntax module " ++ str module_name ++ - str ": " ++ str label ++ fnl () ++ pp_stream) - | e -> - msgnl (mt ()); - msgnl - (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++ - int reqid ++ fnl ()); - ();; - -let coqparser_loop inchan = - (parser_loop : (unit -> unit) * - (int -> string -> char Stream.t -> string list -> unit) * - (char Stream.t -> unit) * (int -> string -> unit) * - (int -> string -> unit) * (int -> string -> string -> unit) * - (int -> string -> unit) -> in_channel -> unit) - (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action, - add_path_action, add_rec_path_action, load_syntax_action) inchan;; - -if !Sys.interactive then () - else -Libobject.relax true; -(let coqdir = - try Sys.getenv "COQDIR" - with Not_found -> - let coqdir = Envars.coqlib () in - if Sys.file_exists coqdir then - coqdir - else - (msgnl (str "could not find the value of COQDIR"); exit 1) in - begin - add_rec_path (Filename.concat coqdir "theories") - (Names.make_dirpath [Nameops.coq_root]); - add_rec_path (Filename.concat coqdir "contrib") - (Names.make_dirpath [Nameops.coq_root]) - end; -(let vernacrc = - try - Sys.getenv "VERNACRC" - with - Not_found -> - List.fold_left - (fun s1 s2 -> (Filename.concat s1 s2)) - coqdir [ "contrib"; "interface"; "vernacrc"] in - try - (Gramext.warning_verbose := false; - coqparser_loop (open_in vernacrc)) - with - | End_of_file -> () - | e -> - (msgnl (Cerrors.explain_exn e); - msgnl (str "could not load the VERNACRC file")); - try - msgnl (str vernacrc) - with - e -> ()); -(try let user_vernacrc = - try Some(Sys.getenv "USERVERNACRC") - with - | Not_found -> - msgnl (str "no .vernacrc file"); None in - (match user_vernacrc with - Some f -> coqparser_loop (open_in f) - | None -> ()) - with - | End_of_file -> () - | e -> - msgnl (Cerrors.explain_exn e); - msgnl (str "error in your .vernacrc file")); -msgnl (str "Starting Centaur Specialized Parser Loop"); -try - coqparser_loop stdin -with - | End_of_file -> () - | e -> msgnl(Cerrors.explain_exn e)) diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml deleted file mode 100644 index a157ca92..00000000 --- a/contrib/interface/paths.ml +++ /dev/null @@ -1,26 +0,0 @@ -let int_list_to_string s l = - List.fold_left - (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) - s - l;; - -(* Given two paths, this function returns the longest common prefix and the - two suffixes. *) -let rec decompose_path - : (int list * int list) -> (int list * int list * int list) = - function - (a::l,b::m) when a = b -> - let (c,p1,p2) = decompose_path (l,m) in - (a::c,p1,p2) - | p1,p2 -> [], p1, p2;; - -let rec is_prefix p1 p2 = match p1,p2 with - [], _ -> true -| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2 -| _ -> false;; - -let rec lex_smaller p1 p2 = match p1,p2 with - [], _ -> true -| a::tl1, b::tl2 when a < b -> true -| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 -| _ -> false;; diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli deleted file mode 100644 index 26620723..00000000 --- a/contrib/interface/paths.mli +++ /dev/null @@ -1,4 +0,0 @@ -val decompose_path : (int list * int list) -> (int list * int list * int list);; -val int_list_to_string : string -> int list -> string;; -val is_prefix : int list -> int list -> bool;; -val lex_smaller : int list -> int list -> bool;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml deleted file mode 100644 index 01747aa5..00000000 --- a/contrib/interface/pbp.ml +++ /dev/null @@ -1,758 +0,0 @@ -(* A proof by pointing algorithm. *) -open Util;; -open Names;; -open Term;; -open Tactics;; -open Tacticals;; -open Hipattern;; -open Pattern;; -open Matching;; -open Reduction;; -open Rawterm;; -open Environ;; - -open Proof_trees;; -open Proof_type;; -open Tacmach;; -open Tacexpr;; -open Typing;; -open Pp;; -open Libnames;; -open Genarg;; -open Topconstr;; -open Termops;; - -let zz = Util.dummy_loc;; - -let hyp_radix = id_of_string "H";; - -let next_global_ident = next_global_ident_away true - -(* get_hyp_by_name : goal sigma -> string -> constr, - looks up for an hypothesis (or a global constant), from its name *) -let get_hyp_by_name g name = - let evd = project g in - let env = pf_env g in - try (let judgment = - Pretyping.Default.understand_judgment - evd env (RVar(zz, name)) in - ("hyp",judgment.uj_type)) -(* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... - Loïc *) - with _ -> (let c = Nametab.global (Ident (zz,name)) in - ("cste",type_of (Global.env()) Evd.empty (constr_of_global c))) -;; - -type pbp_atom = - | PbpTryAssumption of identifier option - | PbpTryClear of identifier list - | PbpGeneralize of identifier * identifier list - | PbpLApply of identifier (* = CutAndApply *) - | PbpIntros of intro_pattern_expr located list - | PbpSplit - (* Existential *) - | PbpExists of identifier - (* Or *) - | PbpLeft - | PbpRight - (* Head *) - | PbpApply of identifier - | PbpElim of identifier * identifier list;; - -(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics - [a1]..[an-1] are atomic (or try of an atomic) tactic and produce - exactly one goal, and [an] produces exactly p subgoals - - In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and - produces exactly one subgoal, except the last one which may complete the - goal - - Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion - from atomic to composed tactic -*) - -type pbp_sequence = - | PbpThens of pbp_atom list * pbp_sequence list - | PbpThen of pbp_atom list - -(* This flattens sequences of tactics producing just one subgoal *) -let chain_tactics tl1 = function - | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3) - | PbpThen tl2 -> PbpThen (tl1@tl2) - -type pbp_rule = (identifier list * - identifier list * - bool * - identifier option * - (types, constr) kind_of_term * - int list * - (identifier list -> - identifier list -> - bool -> - identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) -> - pbp_sequence option;; - - -let make_named_intro id = PbpIntros [zz,IntroIdentifier id];; - -let make_clears str_list = PbpThen [PbpTryClear str_list] - -let add_clear_names_if_necessary tactic clear_names = - match clear_names with - [] -> tactic - | l -> chain_tactics [PbpTryClear l] tactic;; - -let make_final_cmd f optname clear_names constr path = - add_clear_names_if_necessary (f optname constr path) clear_names;; - -let (rem_cast:pbp_rule) = function - (a,c,cf,o, Cast(f,_,_), p, func) -> - Some(func a c cf o (kind_of_term f) p) - | _ -> None;; - -let (forall_intro: pbp_rule) = function - (avoid, - clear_names, - clear_flag, - None, - Prod(Name x, _, body), - (2::path), - f) -> - let x' = next_global_ident x avoid in - Some(chain_tactics [make_named_intro x'] - (f (x'::avoid) - clear_names clear_flag None (kind_of_term body) path)) -| _ -> None;; - -let (imply_intro2: pbp_rule) = function - avoid, clear_names, - clear_flag, None, Prod(Anonymous, _, body), 2::path, f -> - let h' = next_global_ident hyp_radix avoid in - Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) - | _ -> None;; - - -(* -let (imply_intro1: pbp_rule) = function - avoid, clear_names, - clear_flag, None, Prod(Anonymous, prem, body), 1::path, f -> - let h' = next_global_ident hyp_radix avoid in - let str_h' = h' in - Some(chain_tactics [make_named_intro str_h'] - (f (h'::avoid) clear_names clear_flag (Some str_h') - (kind_of_term prem) path)) - | _ -> None;; -*) - -let make_var id = CRef (Ident(zz, id)) - -let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l) - -let make_pbp_pattern x = - make_app (make_var (id_of_string "PBP_META")) - [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] - -let rec make_then = function - | [] -> TacId [] - | [t] -> t - | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l) - -let make_pbp_atomic_tactic = function - | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) - | PbpTryAssumption (Some a) -> - TacTry (TacAtom (zz, TacExact (make_var a))) - | PbpExists x -> - TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x])) - | PbpGeneralize (h,args) -> - let l = List.map make_pbp_pattern args in - TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous]) - | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings)) - | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) - | PbpIntros l -> TacAtom (zz, TacIntroPattern l) - | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings],None)) - | PbpElim (hyp_name, names) -> - let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in - TacAtom - (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None)) - | PbpTryClear l -> - TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) - | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));; - -let rec make_pbp_tactic = function - | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl) - | PbpThens (l,tl) -> - TacThens - (make_then (List.map make_pbp_atomic_tactic l), - List.map make_pbp_tactic tl) - -let (forall_elim: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Name x, _, body), 2::path, f -> - let h' = next_global_ident hyp_radix avoid in - let clear_names' = if clear_flag then h::clear_names else clear_names in - Some - (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h'] - (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path)) - | _ -> None;; - - -let (imply_elim1: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Anonymous, prem, body), 1::path, f -> - let clear_names' = if clear_flag then h::clear_names else clear_names in - let h' = next_global_ident hyp_radix avoid in - let _str_h' = (string_of_id h') in - Some(PbpThens - ([PbpLApply h], - [chain_tactics [make_named_intro h'] (make_clears (h::clear_names)); - f avoid clear_names' false None (kind_of_term prem) path])) - | _ -> None;; - - -let (imply_elim2: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Anonymous, prem, body), 2::path, f -> - let clear_names' = if clear_flag then h::clear_names else clear_names in - let h' = next_global_ident hyp_radix avoid in - Some(PbpThens - ([PbpLApply h], - [chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names' false (Some h') - (kind_of_term body) path); - make_clears clear_names])) - | _ -> None;; - -let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s - -let constant dir s = Coqlib.gen_constant "Pbp" ("Init"::dir) s - -let andconstr: unit -> constr = Coqlib.build_coq_and;; -let prodconstr () = constant ["Datatypes"] "prod";; -let exconstr = Coqlib.build_coq_ex;; -let sigconstr () = constant ["Specif"] "sig";; -let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;; -let orconstr = Coqlib.build_coq_or;; -let sumboolconstr = Coqlib.build_coq_sumbool;; -let sumconstr() = constant ["Datatypes"] "sum";; -let notconstr = Coqlib.build_coq_not;; -let notTconstr () = constant ["Logic_Type"] "notT";; - -let is_matching_local a b = is_matching (pattern_of_constr a) b;; - -let rec (or_and_tree_to_intro_pattern: identifier list -> - constr -> int list -> - intro_pattern_expr * identifier list * identifier *constr - * int list * int * int) = -fun avoid c path -> match kind_of_term c, path with - | (App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (andconstr()) oper) or - (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> - let id2 = next_global_ident hyp_radix avoid in - let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let patt_list = - if a = 1 then - [zz,cont_patt; zz,IntroIdentifier id2] - else - [zz,IntroIdentifier id2; zz,cont_patt] in - (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, - total_branches) - | (App(oper, [|c1; c2|]), 2::3::path) - when ((is_matching_local (exconstr()) oper) or - (is_matching_local (sigconstr()) oper)) -> - (match (kind_of_term c2) with - Lambda (Name x, _, body) -> - let id1 = next_global_ident x avoid in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id1::avoid) body path in - (IntroOrAndPattern[[zz,IntroIdentifier id1; zz,cont_patt]], - avoid_names, id, c, path, rank, total_branches) - | _ -> assert false) - | (App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (orconstr ()) oper) or - (is_matching_local (sumboolconstr ()) oper) or - (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) -> - let id2 = next_global_ident hyp_radix avoid in - let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let new_rank = if a = 1 then rank else rank+1 in - let patt_list = - if a = 1 then - [[zz,cont_patt];[zz,IntroIdentifier id2]] - else - [[zz,IntroIdentifier id2];[zz,cont_patt]] in - (IntroOrAndPattern patt_list, - avoid_names, id, c, path, new_rank, total_branches+1) - | (_, path) -> let id = next_global_ident hyp_radix avoid in - (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; - -let auxiliary_goals clear_names clear_flag this_name n_aux others = - let clear_cmd = - make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in - let rec clear_list = function - 0 -> others - | n -> clear_cmd::(clear_list (n - 1)) in - clear_list n_aux;; - - -let (imply_intro3: pbp_rule) = function - avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body), - 1::path, f -> - let intro_patt, avoid_names, id, c, p, rank, total_branches = - or_and_tree_to_intro_pattern avoid prem path in - if total_branches = 1 then - Some(chain_tactics [PbpIntros [zz,intro_patt]] - (f avoid_names clear_names clear_flag (Some id) - (kind_of_term c) path)) - else - Some - (PbpThens - ([PbpIntros [zz,intro_patt]], - auxiliary_goals clear_names clear_flag id - (rank - 1) - ((f avoid_names clear_names clear_flag (Some id) - (kind_of_term c) path):: - auxiliary_goals clear_names clear_flag id - (total_branches - rank) []))) - | _ -> None;; - - - -let (and_intro: pbp_rule) = function - avoid, clear_names, clear_flag, - None, App(and_oper, [|c1; c2|]), 2::a::path, f - -> - if ((is_matching_local (andconstr()) and_oper) or - (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then - let cont_term = if a = 1 then c1 else c2 in - let cont_cmd = f avoid clear_names false None - (kind_of_term cont_term) path in - let clear_cmd = make_clears clear_names in - let cmds = - (if a = 1 - then [cont_cmd;clear_cmd] - else [clear_cmd;cont_cmd]) in - Some (PbpThens ([PbpSplit],cmds)) - else None - | _ -> None;; - -let exists_from_lambda avoid clear_names clear_flag c2 path f = - match kind_of_term c2 with - Lambda(Name x, _, body) -> - Some (PbpThens ([PbpExists x], - [f avoid clear_names false None (kind_of_term body) path])) - | _ -> None;; - - -let (ex_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(oper, [| c1; c2|]), 2::3::path, f - when (is_matching_local (exconstr ()) oper) - or (is_matching_local (sigconstr ()) oper) -> - exists_from_lambda avoid clear_names clear_flag c2 path f - | _ -> None;; - -let (exT_intro : pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(oper, [| c1; c2|]), 2::2::2::path, f - when (is_matching_local (sigTconstr ()) oper) -> - exists_from_lambda avoid clear_names clear_flag c2 path f - | _ -> None;; - -let (or_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(or_oper, [|c1; c2 |]), 2::a::path, f -> - if ((is_matching_local (orconstr ()) or_oper) or - (is_matching_local (sumboolconstr ()) or_oper) or - (is_matching_local (sumconstr ()) or_oper)) - & (a = 1 or a = 2) then - let cont_term = if a = 1 then c1 else c2 in - let fst_cmd = if a = 1 then PbpLeft else PbpRight in - let cont_cmd = f avoid clear_names false None - (kind_of_term cont_term) path in - Some(chain_tactics [fst_cmd] cont_cmd) - else - None - | _ -> None;; - -let dummy_id = id_of_string "Dummy";; - -let (not_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(not_oper, [|c1|]), 2::1::path, f -> - if(is_matching_local (notconstr ()) not_oper) or - (is_matching_local (notTconstr ()) not_oper) then - let h' = next_global_ident hyp_radix avoid in - Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names false (Some h') - (kind_of_term c1) path)) - else - None - | _ -> None;; - - - - -let elim_with_bindings hyp_name names = - PbpElim (hyp_name, names);; - -(* This function is used to follow down a path, while staying on the spine of - successive products (universal quantifications or implications). - Arguments are the current observed constr object and the path that remains - to be followed, and an integer indicating how many products have already been - crossed. - Result is: - - a list of string indicating the names of universally quantified variables. - - a list of integers indicating the positions of the successive - universally quantified variables. - - an integer indicating the number of non-dependent products. - - the last constr object encountered during the walk down, and - - the remaining path. - - For instance the following session should happen: - let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign())) - (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in - down_prods (tt, [2;2;2], 0) - ---> ["P","x"],[0;1], 1, <<(P x)>>, [] -*) - - -let rec down_prods: (types, constr) kind_of_term * (int list) * int -> - identifier list * (int list) * int * (types, constr) kind_of_term * - (int list) = - function - Prod(Name x, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p - = down_prods (kind_of_term body, path, k+1) in - x::res_sl, (k::res_il), res_i, res_cstr, res_p - | Prod(Anonymous, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p - = down_prods (kind_of_term body, path, k+1) in - res_sl, res_il, res_i+1, res_cstr, res_p - | cstr, path, _ -> [], [], 0, cstr, path;; - -exception Pbp_internal of int list;; - -(* This function should be usable to check that a type can be used by the - Apply command. Basically, c is supposed to be the head of some - type, where l gives the ranks of all universally quantified variables. - It check that these universally quantified variables occur in the head. - - The knowledge I have on constr structures is incomplete. -*) -let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = - function c -> function l -> - let rec delete n = function - | [] -> [] - | p::tl -> if n = p then tl else p::(delete n tl) in - let rec check_rec l = function - | App(f, array) -> - Array.fold_left (fun l c -> check_rec l (kind_of_term c)) - (check_rec l (kind_of_term f)) array - | Const _ -> l - | Ind _ -> l - | Construct _ -> l - | Var _ -> l - | Rel p -> - let result = delete p l in - if result = [] then - raise (Pbp_internal []) - else - result - | _ -> raise (Pbp_internal l) in - try - (check_rec l c) = [] - with Pbp_internal l -> l = [];; - -let (mk_db_indices: int list -> int -> int list) = - function int_list -> function nprems -> - let total = (List.length int_list) + nprems in - let rec mk_db_aux = function - [] -> [] - | a::l -> (total - a)::(mk_db_aux l) in - mk_db_aux int_list;; - - -(* This proof-by-pointing rule is quite complicated, as it attempts to foresee - usages of head tactics. A first operation is to follow the path as far - as possible while staying on the spine of products (function down_prods) - and then to check whether the next step will be an elim step. If the - answer is true, then the built command takes advantage of the power of - head tactics. *) - -let (head_tactic_patt: pbp_rule) = function - avoid, clear_names, clear_flag, Some h, cstr, path, f -> - (match down_prods (cstr, path, 0) with - | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path) - when (((is_matching_local (exconstr ()) oper) (* or - (is_matching_local (sigconstr ()) oper) *)) && a = 3) -> - (match (kind_of_term c2) with - Lambda(Name x, _,body) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let x' = next_global_ident x avoid in - let cont_body = - Prod(Name x', c1, - mkProd(Anonymous, body, - mkVar(dummy_id))) in - let cont_tac - = f avoid (h::clear_names) false None - cont_body (2::1::path) in - cont_tac::(auxiliary_goals - clear_names clear_flag - h nprems []))) - | _ -> None) - | (str_list, _, nprems, - App(oper,[|c1|]), 2::1::path) - when - (is_matching_local (notconstr ()) oper) or - (is_matching_local (notTconstr ()) oper) -> - Some(chain_tactics [elim_with_bindings h str_list] - (f avoid clear_names false None (kind_of_term c1) path)) - | (str_list, _, nprems, - App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (andconstr()) oper) or - (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> - let h1 = next_global_ident hyp_radix avoid in - let h2 = next_global_ident hyp_radix (h1::avoid) in - Some(PbpThens - ([elim_with_bindings h str_list], - let cont_body = - if a = 1 then c1 else c2 in - let cont_tac = - f (h2::h1::avoid) (h::clear_names) - false (Some (if 1 = a then h1 else h2)) - (kind_of_term cont_body) path in - (chain_tactics - [make_named_intro h1; make_named_intro h2] - cont_tac):: - (auxiliary_goals clear_names clear_flag h nprems []))) - | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) - when ((is_matching_local (sigTconstr()) oper)) & a = 2 -> - (match (kind_of_term c2),path with - Lambda(Name x, _,body), (2::path) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let x' = next_global_ident x avoid in - let cont_body = - Prod(Name x', c1, - mkProd(Anonymous, body, - mkVar(dummy_id))) in - let cont_tac - = f avoid (h::clear_names) false None - cont_body (2::1::path) in - cont_tac::(auxiliary_goals - clear_names clear_flag - h nprems []))) - | _ -> None) - | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) - when ((is_matching_local (orconstr ()) oper) or - (is_matching_local (sumboolconstr ()) oper) or - (is_matching_local (sumconstr ()) oper)) & - (a = 1 or a = 2) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let cont_body = - if a = 1 then c1 else c2 in - (* h' is the name for the new intro *) - let h' = next_global_ident hyp_radix avoid in - let cont_tac = - chain_tactics - [make_named_intro h'] - (f - (* h' should not be used again *) - (h'::avoid) - (* the disjunct itself can be discarded *) - (h::clear_names) false (Some h') - (kind_of_term cont_body) path) in - let snd_tac = - chain_tactics - [make_named_intro h'] - (make_clears (h::clear_names)) in - let tacs1 = - if a = 1 then - [cont_tac; snd_tac] - else - [snd_tac; cont_tac] in - tacs1@(auxiliary_goals (h::clear_names) - false dummy_id nprems []))) - | (str_list, int_list, nprems, c, []) - when (check_apply c (mk_db_indices int_list nprems)) & - (match c with Prod(_,_,_) -> false - | _ -> true) & - (List.length int_list) + nprems > 0 -> - Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) - | _ -> None) - | _ -> None;; - - -let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; - forall_elim; imply_intro3; imply_elim1; imply_elim2; - and_intro; or_intro; not_intro; ex_intro; exT_intro];; - - -let try_trace = ref true;; - -let traced_try (f1:tactic) g = - try (try_trace := true; tclPROGRESS f1 g) - with e when Logic.catchable_exception e -> - (try_trace := false; tclIDTAC g);; - -let traced_try_entry = function - [Tacexp t] -> - traced_try (Tacinterp.interp t) - | _ -> failwith "traced_try_entry received wrong arguments";; - - -(* When the recursive descent along the path is over, one includes the - command requested by the point-and-shoot strategy. Default is - Try Assumption--Try Exact. *) - - -let default_ast optname constr path = PbpThen [PbpTryAssumption optname] - -(* This is the main proof by pointing function. *) -(* avoid: les noms a ne pas utiliser *) -(* final_cmd: la fonction appelee par defaut *) -(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *) - -let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = - let rec try_all_rules rl = - match rl with - f::tl -> - (match f (avoid, clear_names, clear_flag, - opt_name, constr, path, pbpt final_cmd) with - Some(ast) -> ast - | None -> try_all_rules tl) - | [] -> make_final_cmd final_cmd opt_name clear_names constr path - in try_all_rules (!pbp_rules);; - -(* these are the optimisation functions. *) -(* This function takes care of flattening successive then commands. *) - - -(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy - that t is some [PbpAtom t] *) - -(* This optimization function takes care of compacting successive Intro commands - together. *) - -let rec group_intros names = function - [] -> (match names with - [] -> [] - | l -> [PbpIntros l]) - | (PbpIntros ids)::others -> group_intros (names@ids) others - | t1::others -> - (match names with - [] -> t1::(group_intros [] others) - | l -> (PbpIntros l)::t1::(group_intros [] others)) - -let rec optim2 = function - | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2) - | PbpThen tl -> PbpThen (group_intros [] tl) - - -let rec cleanup_clears str_list = function - [] -> [] - | x::tail -> - if List.mem x str_list then cleanup_clears str_list tail - else x::(cleanup_clears str_list tail);; - -(* This function takes care of compacting instanciations of universal - quantifications. *) - -let rec optim3_aux str_list = function - (PbpGeneralize (h,l1)):: - (PbpIntros [zz,IntroIdentifier s])::(PbpGeneralize (h',l2))::others - when s=h' -> - optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others) - | (PbpTryClear names)::other -> - (match cleanup_clears str_list names with - [] -> other - | l -> (PbpTryClear l)::other) - | a::l -> a::(optim3_aux str_list l) - | [] -> [];; - -let rec optim3 str_list = function - PbpThens (tl1, tl2) -> - PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2) - | PbpThen tl -> PbpThen (optim3_aux str_list tl) - -let optim x = make_pbp_tactic (optim3 [] (optim2 x));; - -(* TODO -add_tactic "Traced_Try" traced_try_entry;; -*) - -let rec tactic_args_to_ints = function - [] -> [] - | (Integer n)::l -> n::(tactic_args_to_ints l) - | _ -> failwith "expecting only numbers";; - -(* -let pbp_tac display_function = function - (Identifier a)::l -> - (function g -> - let str = (string_of_id a) in - let (ou,tstr) = (get_hyp_by_name g str) in - let exp_ast = - pbpt default_ast - (match ou with - "hyp" ->(pf_ids_of_hyps g) - |_ -> (a::(pf_ids_of_hyps g))) - [] - false - (Some str) - (kind_of_term tstr) - (tactic_args_to_ints l) in - (display_function (optim exp_ast); - tclIDTAC g)) - | ((Integer n)::_) as l -> - (function g -> - let exp_ast = - (pbpt default_ast (pf_ids_of_hyps g) [] false - None (kind_of_term (pf_concl g)) - (tactic_args_to_ints l)) in - (display_function (optim exp_ast); - tclIDTAC g)) - | [] -> (function g -> - (display_function (default_ast None (pf_concl g) []); - tclIDTAC g)) - | _ -> failwith "expecting other arguments";; - - -*) -let pbp_tac display_function idopt nl = - match idopt with - | Some str -> - (function g -> - let (ou,tstr) = (get_hyp_by_name g str) in - let exp_ast = - pbpt default_ast - (match ou with - "hyp" ->(pf_ids_of_hyps g) - |_ -> (str::(pf_ids_of_hyps g))) - [] - false - (Some str) - (kind_of_term tstr) - nl in - (display_function (optim exp_ast); tclIDTAC g)) - | None -> - if nl <> [] then - (function g -> - let exp_ast = - (pbpt default_ast (pf_ids_of_hyps g) [] false - None (kind_of_term (pf_concl g)) nl) in - (display_function (optim exp_ast); tclIDTAC g)) - else - (function g -> - (display_function - (make_pbp_tactic (default_ast None (pf_concl g) [])); - tclIDTAC g));; - - diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli deleted file mode 100644 index 9daba184..00000000 --- a/contrib/interface/pbp.mli +++ /dev/null @@ -1,2 +0,0 @@ -val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - Names.identifier option -> int list -> Proof_type.tactic diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml deleted file mode 100644 index 2ab62763..00000000 --- a/contrib/interface/showproof.ml +++ /dev/null @@ -1,1813 +0,0 @@ -(* -#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; -open Coqast;; -*) -open Environ -open Evd -open Names -open Nameops -open Libnames -open Term -open Termops -open Util -open Proof_type -open Pfedit -open Translate -open Term -open Reductionops -open Clenv -open Typing -open Inductive -open Inductiveops -open Vernacinterp -open Declarations -open Showproof_ct -open Proof_trees -open Sign -open Pp -open Printer -open Rawterm -open Tacexpr -open Genarg -(*****************************************************************************) -(* - Arbre de preuve maison: - -*) - -(* hypotheses *) - -type nhyp = {hyp_name : identifier; - hyp_type : Term.constr; - hyp_full_type: Term.constr} -;; - -type ntactic = tactic_expr -;; - -type nproof = - Notproved - | Proof of ntactic * (ntree list) - -and ngoal= - {newhyp : nhyp list; - t_concl : Term.constr; - t_full_concl: Term.constr; - t_full_env: Environ.named_context_val} -and ntree= - {t_info:string; - t_goal:ngoal; - t_proof : nproof} -;; - - -let hyps {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = lh -;; - -let concl {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = g -;; - -let proof {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = p -;; -let g_env {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = ge -;; -let sub_ntrees t = - match (proof t) with - Notproved -> [] - | Proof (_,l) -> l -;; - -let tactic t = - match (proof t) with - Notproved -> failwith "no tactic applied" - | Proof (t,_) -> t -;; - - -(* -un arbre est clos s'il ne contient pas de sous-but non prouves, -ou bien s'il a un cousin gauche qui n'est pas clos -ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. -*) -let update_closed nt = - let found_not_closed=ref false in - let rec update {t_info=b; t_goal=g; t_proof =p} = - if !found_not_closed - then {t_info="to_prove"; t_goal=g; t_proof =p} - else - match p with - Notproved -> found_not_closed:=true; - {t_info="not_proved"; t_goal=g; t_proof =p} - | Proof(tac,lt) -> - let lt1=List.map update lt in - let b=ref "proved" in - (List.iter - (fun x -> - if x.t_info ="not_proved" then b:="not_proved") lt1; - {t_info=(!b); - t_goal=g; - t_proof=Proof(tac,lt1)}) - in update nt - ;; - - -(* - type complet avec les hypotheses. -*) - -let long_type_hyp lh t= - let t=ref t in - List.iter (fun (n,th) -> - let ni = match n with Name ni -> ni | _ -> assert false in - t:= mkProd(n,th,subst_term (mkVar ni) !t)) - (List.rev lh); - !t -;; - -(* let long_type_hyp x y = y;; *) - -(* Expansion des tactikelles *) - -let seq_to_lnhyp sign sign' cl = - let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in - let nh=List.map (fun (id,c,ty) -> - {hyp_name=id; - hyp_type=ty; - hyp_full_type= - let res= long_type_hyp !lh ty in - lh:=(!lh)@[(Name id,ty)]; - res}) - sign' - in - {newhyp=nh; - t_concl=cl; - t_full_concl=long_type_hyp !lh cl; - t_full_env = Environ.val_of_named_context (sign@sign')} -;; - - -let rule_is_complex r = - match r with - Nested (Tactic - ((TacArg (Tacexp _) - |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true - |_ -> false -;; - -let rule_to_ntactic r = - let rt = - (match r with - Nested(Tactic (t,_),_) -> t - | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h)) - | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in - if rule_is_complex r - then (match rt with - TacArg (Tacexp _) as t -> t - | _ -> assert false) - - else rt -;; - -(* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt *) - - -let fill_unproved nt l = - let lnt = ref l in - let rec fill nt = - let {t_goal=g;t_proof=p}=nt in - match p with - Notproved -> let p=List.hd (!lnt) in - lnt:=List.tl (!lnt); - {t_info="to_prove";t_goal=g;t_proof=p} - |Proof(tac,lt) -> - {t_info="to_prove";t_goal=g; - t_proof=Proof(tac,List.map fill lt)} - in fill nt -;; -(* Differences entre signatures *) - -let new_sign osign sign = - let res=ref [] in - List.iter (fun (id,c,ty) -> - try (let (_,_,_ty1)= (lookup_named id osign) in - ()) - with Not_found -> res:=(id,c,ty)::(!res)) - sign; - !res -;; - -let old_sign osign sign = - let res=ref [] in - List.iter (fun (id,c,ty) -> - try (let (_,_,ty1) = (lookup_named id osign) in - if ty1 = ty then res:=(id,c,ty)::(!res)) - with Not_found -> ()) - sign; - !res -;; - -(* convertit l'arbre de preuve courant en ntree *) -let to_nproof sigma osign pf = - let rec to_nproof_rec sigma osign pf = - let {evar_hyps=sign;evar_concl=cl} = pf.goal in - let sign = Environ.named_context_of_val sign in - let nsign = new_sign osign sign in - let oldsign = old_sign osign sign in - match pf.ref with - - None -> {t_info="to_prove"; - t_goal=(seq_to_lnhyp oldsign nsign cl); - t_proof=Notproved} - | Some(r,spfl) -> - if rule_is_complex r - then ( - let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in - let ntree= fill_unproved p1 - (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) - spfl) in - (match r with - Nested(Tactic (TacAtom (_, TacAuto _),_),_) -> - if spfl=[] - then - {t_info="to_prove"; - t_goal= {newhyp=[]; - t_concl=concl ntree; - t_full_concl=ntree.t_goal.t_full_concl; - t_full_env=ntree.t_goal.t_full_env}; - t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} - else ntree - | _ -> ntree)) - else - {t_info="to_prove"; - t_goal=(seq_to_lnhyp oldsign nsign cl); - t_proof=(Proof (rule_to_ntactic r, - List.map (fun x -> to_nproof_rec sigma sign x) spfl))} - in update_closed (to_nproof_rec sigma osign pf) - ;; - -(* - recupere l'arbre de preuve courant. -*) - -let get_nproof () = - to_nproof (Global.env()) [] - (Tacmach.proof_of_pftreestate (get_pftreestate())) -;; - - -(*****************************************************************************) -(* - Pprinter -*) - -let pr_void () = sphs "";; - -let list_rem l = match l with [] -> [] |x::l1->l1;; - -(* liste de chaines *) -let prls l = - let res = ref (sps (List.hd l)) in - List.iter (fun s -> - res:= sphv [ !res; spb; sps s]) (list_rem l); - !res -;; - -let prphrases f l = - spv (List.map (fun s -> sphv [f s; sps ","]) l) -;; - -(* indentation *) -let spi = spnb 3;; - -(* en colonne *) -let prl f l = - if l=[] then spe else spv (List.map f l);; -(*en colonne, avec indentation *) -let prli f l = - if l=[] then spe else sph [spi; spv (List.map f l)];; - -(* - Langues. -*) - -let rand l = - List.nth l (Random.int (List.length l)) -;; - -type natural_languages = French | English;; -let natural_language = ref French;; - -(*****************************************************************************) -(* - Les liens html pour proof-by-pointing -*) - -(* le path du but en cours. *) - -let path=ref[1];; - -let ftag_apply =ref (fun (n:string) t -> spt t);; - -let ftag_case =ref (fun n -> sps n);; - -let ftag_elim =ref (fun n -> sps n);; - -let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);; - -let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);; - -let ftag_uselemma =ref (fun h t -> - let intro = match !natural_language with - French -> "par" - | English -> "by" - in - spuselemma intro h t);; - -let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);; - -let tag_apply = !ftag_apply;; - -let tag_case = !ftag_case;; - -let tag_elim = !ftag_elim;; - -let tag_uselemma = !ftag_uselemma;; - -let tag_hyp = !ftag_hyp;; - -let tag_hypt = !ftag_hypt;; - -let tag_toprove = !ftag_toprove;; - -(*****************************************************************************) - -(* pluriel *) -let txtn n s = - if n=1 then s - else match s with - |"un" -> "des" - |"a" -> "" - |"an" -> "" - |"une" -> "des" - |"Soit" -> "Soient" - |"Let" -> "Let" - | s -> s^"s" -;; - -let _et () = match !natural_language with - French -> sps "et" -| English -> sps "and" -;; - -let name_count = ref 0;; -let new_name () = - name_count:=(!name_count)+1; - string_of_int !name_count -;; - -let enumerate f ln = - match ln with - [] -> [] - | [x] -> [f x] - |ln -> - let rec enum_rec f ln = - (match ln with - [x;y] -> [f x; spb; sph [_et ();spb;f y]] - |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) - | _ -> assert false) - in enum_rec f ln -;; - - -let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; - -let sp_tac tac = failwith "TODO" - -let soit_A_une_proposition nh ln t= match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "une";txtn nh "proposition"]]) -| English -> - sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]]) -;; - -let on_a ()= match !natural_language with - French -> rand ["on a "] -| English ->rand ["we have "] -;; - -let bon_a ()= match !natural_language with - French -> rand ["On a "] -| English ->rand ["We have "] -;; - -let soit_X_un_element_de_T nh ln t = match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "un";txtn nh "élément";"de"]] - @[spb; spt t]) -| English -> - sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]] - @[spb; spt t]) -;; - -let soit_F_une_fonction_de_type_T nh ln t = match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]] - @[spb; spt t]) -| English -> - sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]] - @[spb; spt t]) -;; - - -let telle_que nh = match !natural_language with - French -> [prls [" ";txtn nh "telle";"que";" "]] -| English -> [prls [" "; "such";"that";" "]] -;; - -let tel_que nh = match !natural_language with - French -> [prls [" ";txtn nh "tel";"que";" "]] -| English -> [prls [" ";"such";"that";" "]] -;; - -let supposons () = match !natural_language with - French -> "Supposons " -| English -> "Suppose " -;; - -let cas () = match !natural_language with - French -> "Cas" -| English -> "Case" -;; - -let donnons_une_proposition () = match !natural_language with - French -> sph[ (prls ["Donnons";"une";"proposition"])] -| English -> sph[ (prls ["Let us give";"a";"proposition"])] -;; - -let montrons g = match !natural_language with - French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]); - spb; spt g; sps ". "] -| English -> sph[ sps (rand ["Let us";"Now"]);spb; - sps (rand ["prove";"show"]); - spb; spt g; sps ". "] -;; - -let calculons_un_element_de g = match !natural_language with - French -> sph[ (prls ["Calculons";"un";"élément";"de"]); - spb; spt g; sps ". "] -| English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]); - spb; spt g; sps ". "] -;; - -let calculons_une_fonction_de_type g = match !natural_language with - French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]); - spb; spt g; sps ". "] -| English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]); - spb; spt g; sps ". "];; - -let en_simplifiant_on_obtient g = match !natural_language with - French -> - sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"]; - rand ["on doit";"il reste à"]; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English -> - sphv [ (prls [rand ["After simplification,"; "Simplifying,"]; - rand ["we must";"it remains to"]; - rand ["prove";"show"]]); - spb; spt g; sps ". "] ;; - -let on_obtient g = match !natural_language with - French -> sph[ (prls [rand ["on doit";"il reste à"]; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English ->sph[ (prls [rand ["we must";"it remains to"]; - rand ["prove";"show"]]); - spb; spt g; sps ". "] -;; - -let reste_a_montrer g = match !natural_language with - French -> sph[ (prls ["Reste";"à"; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English -> sph[ (prls ["It remains";"to"; - rand ["prove";"show"]]); - spb; spt g; sps ". "] -;; - -let discutons_avec_A type_arg = match !natural_language with - French -> sphv [sps "Discutons"; spb; sps "avec"; spb; - spt type_arg; sps ":"] -| English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; - spt type_arg; sps ":"] -;; - -let utilisons_A arg1 = match !natural_language with - French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); - spb; spt arg1; sps ":"] -| English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); - spb; spt arg1; sps ":"] -;; - -let selon_les_valeurs_de_A arg1 = match !natural_language with - French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); - spb; spt arg1; sps ":"] -| English -> sphv [ (prls ["According";"values";"of"]); - spb; spt arg1; sps ":"] -;; - -let de_A_on_a arg1 = match !natural_language with - French -> sphv [ sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb; - sps (rand ["on a:";"on déduit:";"on obtient:"])] -| English -> sphv [ sps (rand ["From";"With";"Thanks to"]); spb; - spt arg1; spb; - sps (rand ["we have:";"we deduce:";"we obtain:"])] -;; - - -let procedons_par_recurrence_sur_A arg1 = match !natural_language with - French -> sphv [ (prls ["Procédons";"par";"récurrence";"sur"]); - spb; spt arg1; sps ":"] -| English -> sphv [ (prls ["By";"induction";"on"]); - spb; spt arg1; sps ":"] -;; - - -let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A - nfun tfun narg = match !natural_language with - French -> sphv [ - sphv [ prls ["Calculons";"la";"fonction"]; - spb; sps (string_of_id nfun);spb; - prls ["de";"type"]; - spb; spt tfun;spb; - prls ["par";"récurrence";"sur";"son";"argument"]; - spb; sps (string_of_int narg); sps ":"] - ] -| English -> sphv [ - sphv [ prls ["Let us compute";"the";"function"]; - spb; sps (string_of_id nfun);spb; - prls ["of";"type"]; - spb; spt tfun;spb; - prls ["by";"induction";"on";"its";"argument"]; - spb; sps (string_of_int narg); sps ":"] - ] - -;; -let pour_montrer_G_la_valeur_recherchee_est_A g arg1 = - match !natural_language with - French -> sph [sps "Pour";spb;sps "montrer"; spt g; spb; - sps ","; spb; sps "choisissons";spb; - spt arg1;sps ". " ] -| English -> sph [sps "In order to";spb;sps "show"; spt g; spb; - sps ","; spb; sps "let us choose";spb; - spt arg1;sps ". " ] -;; - -let on_se_sert_de_A arg1 = match !natural_language with - French -> sph [sps "On se sert de";spb ;spt arg1;sps ":" ] -| English -> sph [sps "We use";spb ;spt arg1;sps ":" ] -;; - - -let d_ou_A g = match !natural_language with - French -> sph [spi; sps "d'où";spb ;spt g;sps ". " ] -| English -> sph [spi; sps "then";spb ;spt g;sps ". " ] -;; - - -let coq_le_demontre_seul () = match !natural_language with - French -> rand [prls ["Coq";"le";"démontre"; "seul."]; - sps "Fastoche."; - sps "Trop cool"] -| English -> rand [prls ["Coq";"shows";"it"; "alone."]; - sps "Fingers in the nose."] -;; - -let de_A_on_deduit_donc_B arg g = match !natural_language with - French -> sph - [ sps "De"; spb; spt arg; spb; sps "on";spb; - sps "déduit";spb; sps "donc";spb; spt g ] -| English -> sph - [ sps "From"; spb; spt arg; spb; sps "we";spb; - sps "deduce";spb; sps "then";spb; spt g ] -;; - -let _A_est_immediat_par_B g arg = match !natural_language with - French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); - spb; spt arg ] -| English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); - spb; spt arg ] -;; - -let le_resultat_est arg = match !natural_language with - French -> sph [ (prls ["le";"résultat";"est"]); - spb; spt arg ] -| English -> sph [ (prls ["the";"result";"is"]); - spb; spt arg ];; - -let on_applique_la_tactique tactic tac = match !natural_language with - French -> sphv - [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] -| English -> sphv - [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] -;; - -let de_A_il_vient_B arg g = match !natural_language with - French -> sph - [ sps "De"; spb; spt arg; spb; - sps "il";spb; sps "vient";spb; spt g; sps ". " ] -| English -> sph - [ sps "From"; spb; spt arg; spb; - sps "it";spb; sps "comes";spb; spt g; sps ". " ] -;; - -let ce_qui_est_trivial () = match !natural_language with - French -> sps "Trivial." -| English -> sps "Trivial." -;; - -let en_utilisant_l_egalite_A arg = match !natural_language with - French -> sphv [ sps "En"; spb;sps "utilisant"; spb; - sps "l'egalite"; spb; spt arg; sps "," - ] -| English -> sphv [ sps "Using"; spb; - sps "the equality"; spb; spt arg; sps "," - ] -;; - -let simplifions_H_T hyp thyp = match !natural_language with - French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:"; - spb;spt thyp;sps "."] -| English -> sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:"; - spb;spt thyp;sps "."] -;; - -let grace_a_A_il_suffit_de_montrer_LA arg lg= - match !natural_language with - French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb; - spt arg;sps ",";spb; - sps "il suffit";spb; sps "de"; spb; - sps (rand["prouver";"montrer";"démontrer"]); spb] - @[spv (enumerate (fun x->x) lg)]) -| English -> sphv ([sps (rand ["Thanks to";"With"]);spb; - spt arg;sps ",";spb; - sps "it suffices";spb; sps "to"; spb; - sps (rand["prove";"show"]); spb] - @[spv (enumerate (fun x->x) lg)]) -;; -let reste_a_montrer_LA lg= - match !natural_language with - French -> sphv ([ sps "Il reste";spb; sps "à"; spb; - sps (rand["prouver";"montrer";"démontrer"]); spb] - @[spv (enumerate (fun x->x) lg)]) -| English -> sphv ([ sps "It remains";spb; sps "to"; spb; - sps (rand["prove";"show"]); spb] - @[spv (enumerate (fun x->x) lg)]) -;; -(*****************************************************************************) -(* - Traduction des hypothèses. -*) - -type n_sort= - Nprop - | Nformula - | Ntype - | Nfunction -;; - - -let sort_of_type t ts = - let t=(strip_outer_cast t) in - if is_Prop t - then Nprop - else - match ts with - Prop(Null) -> Nformula - |_ -> (match (kind_of_term t) with - Prod(_,_,_) -> Nfunction - |_ -> Ntype) -;; - -let adrel (x,t) e = - match x with - Name(xid) -> Environ.push_rel (x,None,t) e - | Anonymous -> Environ.push_rel (x,None,t) e - -let rec nsortrec vl x = - match (kind_of_term x) with - Prod(n,t,c)-> - let vl = (adrel (n,t) vl) in nsortrec vl c - | Lambda(n,t,c) -> - let vl = (adrel (n,t) vl) in nsortrec vl c - | App(f,args) -> nsortrec vl f - | Sort(Prop(Null)) -> Prop(Null) - | Sort(c) -> c - | Ind(ind) -> - let (mib,mip) = lookup_mind_specif vl ind in - new_sort_in_family (inductive_sort_family mip) - | Construct(c) -> - nsortrec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) - -> nsortrec vl x - | Cast(x,_, t)-> nsortrec vl t - | Const c -> nsortrec vl (Typeops.type_of_constant vl c) - | _ -> nsortrec vl (type_of vl Evd.empty x) -;; -let nsort x = - nsortrec (Global.env()) (strip_outer_cast x) -;; - -let sort_of_hyp h = - (sort_of_type h.hyp_type (nsort h.hyp_full_type)) -;; - -(* grouper les hypotheses successives de meme type, ou logiques. - donne une liste de liste *) -let rec group_lhyp lh = - match lh with - [] -> [] - |[h] -> [[h]] - |h::lh -> - match group_lhyp lh with - (h1::lh1)::lh2 -> - if h.hyp_type=h1.hyp_type - || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) - then (h::(h1::lh1))::lh2 - else [h]::((h1::lh1)::lh2) - |_-> assert false -;; - -(* ln noms des hypotheses, lt leurs types *) -let natural_ghyp (sort,ln,lt) intro = - let t=List.hd lt in - let nh=List.length ln in - let _ns=List.hd ln in - match sort with - Nprop -> soit_A_une_proposition nh ln t - | Ntype -> soit_X_un_element_de_T nh ln t - | Nfunction -> soit_F_une_fonction_de_type_T nh ln t - | Nformula -> - sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) - (List.combine ln lt))) -;; - -(* Cas d'une hypothese *) -let natural_hyp h = - let ns= string_of_id h.hyp_name in - let t=h.hyp_type in - let ts= (nsort h.hyp_full_type) in - natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ()) -;; - -let rec pr_ghyp lh intro= - match lh with - [] -> [] - | [(sort,ln,t)]-> - (match sort with - Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] - | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) - | (sort,ln,t)::lh -> - let hp= - ([natural_ghyp(sort,ln,t) intro] - @(match lh with - [] -> [sps ". "] - |(sort1,ln1,t1)::lh1 -> - match sort1 with - Nformula -> - (let nh=List.length ln in - match sort with - Nprop -> telle_que nh - |Nfunction -> telle_que nh - |Ntype -> tel_que nh - |Nformula -> [sps ". "]) - | _ -> [sps ". "])) in - (sphv hp)::(pr_ghyp lh "") -;; - -(* traduction d'une liste d'hypotheses groupees. *) -let prnatural_ghyp llh intro= - if llh=[] - then spe - else - sphv (pr_ghyp (List.map - (fun lh -> - let h=(List.hd lh) in - let sh = sort_of_hyp h in - let lhname = (List.map (fun h -> - string_of_id h.hyp_name) lh) in - let lhtype = (List.map (fun h -> h.hyp_type) lh) in - (sh,lhname,lhtype)) - llh) intro) -;; - - -(*****************************************************************************) -(* - Liste des hypotheses. -*) -type type_info_subgoals_hyp= - All_subgoals_hyp - | Reduce_hyp - | No_subgoals_hyp - | Case_subgoals_hyp of string (* word for introduction *) - * Term.constr (* variable *) - * string (* constructor *) - * int (* arity *) - * int (* number of constructors *) - | Case_prop_subgoals_hyp of string (* word for introduction *) - * Term.constr (* variable *) - * int (* index of constructor *) - * int (* arity *) - * int (* number of constructors *) - | Elim_subgoals_hyp of Term.constr (* variable *) - * string (* constructor *) - * int (* arity *) - * (string list) (* rec hyp *) - * int (* number of constructors *) - | Elim_prop_subgoals_hyp of Term.constr (* variable *) - * int (* index of constructor *) - * int (* arity *) - * (string list) (* rec hyp *) - * int (* number of constructors *) -;; -let rec nrem l n = - if n<=0 then l else nrem (list_rem l) (n-1) -;; - -let rec nhd l n = - if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1)) -;; - -let par_hypothese_de_recurrence () = match !natural_language with - French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])] -| English -> sphv [(prls ["by";"induction";"hypothesis";","])] -;; - -let natural_lhyp lh hi = - match hi with - All_subgoals_hyp -> - ( match lh with - [] -> spe - |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) - | Reduce_hyp -> - (match lh with - [h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type - | _-> spe) - | No_subgoals_hyp -> spe - |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *) - let s=ref c in - for i=1 to a do - let nh=(List.nth lh (i-1)) in - s:=(!s)^" "^(string_of_id nh.hyp_name); - done; - if a>0 then s:="("^(!s)^")"; - sphv [ (if ncase>1 - then sph[ sps ("-"^(cas ()));spb] - else spe); - (* spt var;sps "="; *) sps !s; sps ":"; - (prphrases (natural_hyp) (nrem lh a))] - |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) -> - prnatural_ghyp (group_lhyp lh) sintro - |Elim_subgoals_hyp (var,c,a,lhci,ncase) -> - let nlh = List.length lh in - let nlhci = List.length lhci in - let lh0 = ref [] in - for i=1 to (nlh-nlhci) do - lh0:=(!lh0)@[List.nth lh (i-1)]; - done; - let lh=nrem lh (nlh-nlhci) in - let s=ref c in - let lh1=ref [] in - for i=1 to nlhci do - let targ=(List.nth lhci (i-1))in - let nh=(List.nth lh (i-1)) in - if targ="arg" || targ="argrec" - then - (s:=(!s)^" "^(string_of_id nh.hyp_name); - lh0:=(!lh0)@[nh]) - else lh1:=(!lh1)@[nh]; - done; - let introhyprec= - (if (!lh1)=[] then spe - else par_hypothese_de_recurrence () ) - in - if a>0 then s:="("^(!s)^")"; - spv [sphv [(if ncase>1 - then sph[ sps ("-"^(cas ()));spb] - else spe); - sps !s; sps ":"]; - prnatural_ghyp (group_lhyp !lh0) (supposons ()); - introhyprec; - prl (natural_hyp) !lh1] - |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) -> - sphv [ (if ncase>1 - then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c); - sps ":";spb] - else spe); - (prphrases (natural_hyp) lh )] - -;; - -(*****************************************************************************) -(* - Analyse des tactiques. -*) - -let name_tactic = function - | TacIntroPattern _ -> "Intro" - | TacAssumption -> "Assumption" - | _ -> failwith "TODO" -;; - -(* -let arg1_tactic tac = - match tac with - (Node(_,"Interp", - (Node(_,_, - (Node(_,_,x::_))::_))::_))::_ ->x - | (Node(_,_,x::_))::_ -> x - | x::_ -> x - | _ -> assert false -;; -*) - -let arg1_tactic tac = failwith "TODO";; - -type type_info_subgoals = - {ihsg: type_info_subgoals_hyp; - isgintro : string} -;; - -let rec show_goal lh ig g gs = - match ig with - "intros" -> - if lh = [] - then spe - else show_goal lh "standard" g gs - |"standard" -> - (match (sort_of_type g gs) with - Nprop -> donnons_une_proposition () - | Nformula -> montrons g - | Ntype -> calculons_un_element_de g - | Nfunction ->calculons_une_fonction_de_type g) - | "apply" -> show_goal lh "" g gs - | "simpl" ->en_simplifiant_on_obtient g - | "rewrite" -> on_obtient g - | "equality" -> reste_a_montrer g - | "trivial_equality" -> reste_a_montrer g - | "" -> spe - |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ] -;; - -let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s = - if ig="" && lh = [] - then spe - else sphv [ show_goal lh ig g gs; sps s] -;; - -let imaginez_une_preuve_de () = match !natural_language with - French -> "Imaginez une preuve de" -| English -> "Imagine a proof of" -;; - -let donnez_un_element_de () = match !natural_language with - French -> "Donnez un element de" -| English -> "Give an element of";; - -let intro_not_proved_goal gs = - match gs with - Prop(Null) -> imaginez_une_preuve_de () - |_ -> donnez_un_element_de () -;; - -let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= - match lh with - {hyp_name=n}::_ -> n - | _ -> assert false -;; - -let rec find_type x t= - match (kind_of_term (strip_outer_cast t)) with - Prod(y,ty,t) -> - (match y with - Name y -> - if x=(string_of_id y) then ty - else find_type x t - | _ -> find_type x t) - |_-> assert false -;; - -(*********************************************************************** -Traitement des égalités -*) -(* -let is_equality e = - match (kind_of_term e) with - AppL args -> - (match (kind_of_term args.(0)) with - Const (c,_) -> - (match (string_of_sp c) with - "Equal" -> true - | "eq" -> true - | "eqT" -> true - | "identityT" -> true - | _ -> false) - | _ -> false) - | _ -> false -;; -*) - -let is_equality e = - let e= (strip_outer_cast e) in - match (kind_of_term e) with - App (f,args) -> (Array.length args) >= 3 - | _ -> false -;; - -let terms_of_equality e = - let e= (strip_outer_cast e) in - match (kind_of_term e) with - App (f,args) -> (args.(1) , args.(2)) - | _ -> assert false -;; - -let eq_term = eq_constr;; - -let is_equality_tac = function - | TacAtom (_, - (TacExtend - (_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" - |"ERewriteParallel"|"ERewriteNormal" - |"RewriteLR"|"RewriteRL"|"Replace"),_) - | TacReduce _ - | TacSymmetry _ | TacReflexivity - | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true - | _ -> false - -let equalities_ntree ig ntree = - let rec equalities_ntree ig ntree = - if not (is_equality (concl ntree)) - then [] - else - match (proof ntree) with - Notproved -> [(ig,ntree)] - | Proof (tac,ltree) -> - if is_equality_tac tac - then (match ltree with - [] -> [(ig,ntree)] - | t::_ -> let res=(equalities_ntree ig t) in - if eq_term (concl ntree) (concl t) - then res - else (ig,ntree)::res) - else [(ig,ntree)] - in - equalities_ntree ig ntree -;; - -let remove_seq_of_terms l = - let rec remove_seq_of_terms l = match l with - a::b::l -> if (eq_term (fst a) (fst b)) - then remove_seq_of_terms (b::l) - else a::(remove_seq_of_terms (b::l)) - | _ -> l - in remove_seq_of_terms l -;; - -let list_to_eq l o= - let switch = fun h h' -> (if o then h else h') in - match l with - [a] -> spt (fst a) - | (a,h)::(b,h')::l -> - let rec list_to_eq h l = - match l with - [] -> [] - | (b,h')::l -> - (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) - :: (list_to_eq (switch h' h) l) - in sph [spt a; spb; - spv ((sph [sps "="; spb; spt b; spb; - tag_uselemma (switch h h') spe]) - ::(list_to_eq (switch h' h) l))] - | _ -> assert false -;; - -let stde = Global.env;; - -let dbize env = Constrintern.interp_constr Evd.empty env;; - -(**********************************************************************) -let rec natural_ntree ig ntree = - let {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = ntree in - let leq = List.rev (equalities_ntree ig ntree) in - if List.length leq > 1 - then (* Several equalities to treate ... *) - ( - print_string("Several equalities to treate ...\n"); - let l1 = ref [] in - let l2 = ref [] in - List.iter - (fun (_,ntree) -> - let lemma = match (proof ntree) with - Proof (tac,ltree) -> - (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *) - (match ltree with - [] ->spe - | [_] -> spe - | _::l -> sphv[sps ": "; - prli (natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="standard"}) - l])]) - with _ -> sps "simplification" ) - | Notproved -> spe - in - let (t1,t2)= terms_of_equality (concl ntree) in - l2:=(t2,lemma)::(!l2); - l1:=(t1,lemma)::(!l1)) - leq; - l1:=remove_seq_of_terms !l1; - l2:=remove_seq_of_terms !l2; - l2:=List.rev !l2; - let ltext=ref [] in - if List.length !l1 > 1 - then (ltext:=(!ltext)@[list_to_eq !l1 true]; - if List.length !l2 > 1 then - (ltext:=(!ltext)@[_et()]; - ltext:=(!ltext)@[list_to_eq !l2 false])) - else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false]; - if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext]; - let (ig,ntree)=(List.hd leq) in - spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g (nsort gf) ""); - sph !ltext; - - natural_ntree {ihsg=All_subgoals_hyp; - isgintro= - let (t1,t2)= terms_of_equality (concl ntree) in - if eq_term t1 t2 - then "trivial_equality" - else "equality"} - ntree] - ) - else - let ntext = - let gs=nsort gf in - match p with - Notproved -> spv [ (natural_lhyp lh ig.ihsg); - sph [spi; sps (intro_not_proved_goal gs); spb; - tag_toprove g ] - ] - - | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) - | Proof (TacAtom (_,tac),ltree) -> - (let ntext = - match tac with -(* Pas besoin de l'argument éventuel de la tactique *) - TacIntroPattern _ -> natural_intros ig lh g gs ltree - | TacIntroMove _ -> natural_intros ig lh g gs ltree - | TacFix (_,n) -> natural_fix ig lh g gs n ltree - | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree - | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree - | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree - | TacRight _ -> natural_right ig lh g gs ltree - | TacLeft _ -> natural_left ig lh g gs ltree - | (* "Simpl" *)TacReduce (r,cl) -> - natural_reduce ig lh g gs ge r cl ltree - | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree - | TacAuto _ -> natural_auto ig lh g gs ltree - | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree - | TacTrivial _ -> natural_trivial ig lh g gs ltree - | TacAssumption -> natural_trivial ig lh g gs ltree - | TacClear _ -> natural_clear ig lh g gs ltree -(* Besoin de l'argument de la tactique *) - | TacSimpleInductionDestruct (true,NamedHyp id) -> - natural_induction ig lh g gs ge id ltree false - | TacExtend (_,"InductionIntro",[a]) -> - let id=(out_gen wit_ident a) in - natural_induction ig lh g gs ge id ltree true - | TacApply (_,false,[c,_],None) -> - natural_apply ig lh g gs (snd c) ltree - | TacExact c -> natural_exact ig lh g gs (snd c) ltree - | TacCut c -> natural_cut ig lh g gs (snd c) ltree - | TacExtend (_,"CutIntro",[a]) -> - let _c = out_gen wit_constr a in - natural_cutintro ig lh g gs a ltree - | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false - | TacExtend (_,"CaseIntro",[a]) -> - let c = out_gen wit_constr a in - natural_case ig lh g gs ge c ltree true - | TacElim (_,(c,_),_) -> - natural_elim ig lh g gs ge (snd c) ltree false - | TacExtend (_,"ElimIntro",[a]) -> - let c = out_gen wit_constr a in - natural_elim ig lh g gs ge c ltree true - | TacExtend (_,"Rewrite",[_;a]) -> - let (c,_) = out_gen wit_constr_with_bindings a in - natural_rewrite ig lh g gs c ltree - | TacExtend (_,"ERewriteRL",[a]) -> - let c = out_gen wit_constr a in (* TODO *) - natural_rewrite ig lh g gs c ltree - | TacExtend (_,"ERewriteLR",[a]) -> - let c = out_gen wit_constr a in (* TODO *) - natural_rewrite ig lh g gs c ltree - |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree - in - ntext (* spwithtac ntext tactic*) - ) - | Proof _ -> failwith "Don't know what to do with that" - in - if info<>"not_proved" - then spshrink info ntext - else ntext -and natural_generic ig lh g gs tactic tac ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - on_applique_la_tactique tactic tac ; - (prli(natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="standard"}) - ltree) - ] -and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree) -(* - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree ig) ltree) - ] -*) -and natural_intros ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="intros"}) - ltree) - ] -and natural_apply ig lh g gs arg ltree = - let lg = List.map concl ltree in - match lg with - [] -> - spv - [ (natural_lhyp lh ig.ihsg); - de_A_il_vient_B arg g - ] - | [sg]-> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh - {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" - then "standard" - else ""} - g gs ""); - grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; - sph [spi ; natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} (List.hd ltree)] - ] - | _ -> - let ln = List.map (fun _ -> new_name()) lg in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh - {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" - then "standard" - else ""} - g gs ""); - grace_a_A_il_suffit_de_montrer_LA arg - (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) - lg ln); - sph [spi; spv (List.map2 - (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} x]) - ltree ln)] - ] -and natural_rem_goals ltree = - let lg = List.map concl ltree in - match lg with - [] -> spe - | [sg]-> - spv - [ reste_a_montrer_LA [spt sg]; - sph [spi ; natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} (List.hd ltree)] - ] - | _ -> - let ln = List.map (fun _ -> new_name()) lg in - spv - [ reste_a_montrer_LA - (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) - lg ln); - sph [spi; spv (List.map2 - (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} x]) - ltree ln)] - ] -and natural_exact ig lh g gs arg ltree = -spv - [ - (natural_lhyp lh ig.ihsg); - (let {ihsg=pi;isgintro=ig}= ig in - (show_goal2 lh {ihsg=pi;isgintro=""} - g gs "")); - (match gs with - Prop(Null) -> _A_est_immediat_par_B g arg - |_ -> le_resultat_est arg) - - ] -and natural_cut ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - (List.rev ltree)); - de_A_on_deduit_donc_B arg g - ] -and natural_cutintro ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - sph [spi; - (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""} - (List.nth ltree 1))]; - sph [spi; - (natural_ntree - {ihsg=No_subgoals_hyp;isgintro=""} - (List.nth ltree 0))] - ] -and whd_betadeltaiota x = whd_betaiota Evd.empty x -and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) -and prod_head t = - match (kind_of_term (strip_outer_cast t)) with - Prod(_,_,c) -> prod_head c -(* |App(f,a) -> f *) - | _ -> t -and string_of_sp sp = string_of_id (basename sp) -and constr_of_mind mip i = - (string_of_id mip.mind_consnames.(i-1)) -and arity_of_constr_of_mind env indf i = - (get_constructors env indf).(i-1).cs_nargs -and gLOB ge = Global.env_of_context ge (* (Global.env()) *) - -and natural_case ig lh g gs ge arg1 ltree with_intros = - let env= (gLOB ge) in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let ti =(string_of_id mip.mind_typename) in - let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in - if ncti<>1 -(* Zéro ou Plusieurs constructeurs *) - then ( - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (match (nsort targ1) with - Prop(Null) -> - (match ti with - "or" -> discutons_avec_A type_arg - | _ -> utilisons_A arg1) - |_ -> selon_les_valeurs_de_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=if with_intros - then (arity_of_constr_of_mind env indf !ci) - else 0 in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Case_prop_subgoals_hyp (supposons (),arg1,ici,aci, - (List.length ltree)) - |_-> Case_subgoals_hyp ("",arg1,nci,aci, - (List.length ltree))); - isgintro= if with_intros then "" else "standard"} - treearg) - ]) - (nrem ltree ((List.length ltree)- ncti)))); - (sph [spi; (natural_rem_goals - (nhd ltree ((List.length ltree)- ncti)))]) - ] ) -(* Cas d'un seul constructeur *) - else ( - - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - de_A_on_a arg1; - (let treearg=List.hd ltree in - let nci=(constr_of_mind mip 1) in - let aci= - if with_intros - then (arity_of_constr_of_mind env indf 1) - else 0 in - let _ici= 1 in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Case_prop_subgoals_hyp ("",arg1,1,aci, - (List.length ltree)) - |_-> Case_subgoals_hyp ("",arg1,nci,aci, - (List.length ltree))); - isgintro=""} - treearg) - ]); - (sph [spi; (natural_rem_goals - (nhd ltree ((List.length ltree)- 1)))]) - ] - ) -(* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) - -(*****************************************************************************) -(* - Elim -*) -and prod_list_var t = - match (kind_of_term (strip_outer_cast t)) with - Prod(_,t,c) -> t::(prod_list_var c) - |_ -> [] -and hd_is_mind t ti = - try (let env = Global.env() in - let IndType (indf,targ) = find_rectype env Evd.empty t in - let _ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - (string_of_id mip.mind_typename) = ti) - with _ -> false -and mind_ind_info_hyp_constr indf c = - let env = Global.env() in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _p = mib.mind_nparams in - let a = arity_of_constr_of_mind env indf c in - let lp=ref (get_constructors env indf).(c).cs_args in - let lr=ref [] in - let ti = (string_of_id mip.mind_typename) in - for i=1 to a do - match !lp with - ((_,_,t)::lp1)-> - if hd_is_mind t ti - then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1) - else (lr:=(!lr)@["arg"];lp:=lp1) - | _ -> raise (Failure "mind_ind_info_hyp_constr") - done; - !lr -(* - mind_ind_info_hyp_constr "le" 2;; -donne ["arg"; "argrec"] -mind_ind_info_hyp_constr "le" 1;; -donne [] - mind_ind_info_hyp_constr "nat" 2;; -donne ["argrec"] -*) - -and natural_elim ig lh g gs ge arg1 ltree with_intros= - let env= (gLOB ge) in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _ti =(string_of_id mip.mind_typename) in - let _type_arg=targ1 (* List.nth targ (mis_index dmi) *) in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (match (nsort targ1) with - Prop(Null) -> utilisons_A arg1 - |_ ->procedons_par_recurrence_sur_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= - if with_intros - then mind_ind_info_hyp_constr indf !ci - else [] in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Elim_prop_subgoals_hyp (arg1,ici,aci,hci, - (List.length ltree)) - |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, - (List.length ltree))); - isgintro= ""} - treearg) - ]) - (nhd ltree ncti))); - (sph [spi; (natural_rem_goals (nrem ltree ncti))]) - ] -(* ) - with _ ->natural_generic ig lh g gs (sps "Elim") (spt arg1) ltree *) - -(*****************************************************************************) -(* - InductionIntro n -*) -and natural_induction ig lh g gs ge arg2 ltree with_intros= - let env = (gLOB (g_env (List.hd ltree))) in - let arg1= mkVar arg2 in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let _ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _ti =(string_of_id mip.mind_typename) in - let _type_arg= targ1(*List.nth targ (mis_index dmi)*) in - - let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *) - (* on les enleve des hypotheses des sous-buts *) - let ltree = List.map - (fun {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} -> - {t_info=info; - t_goal={newhyp=(nrem lh (List.length lh1)); - t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p}) ltree in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (natural_lhyp lh1 All_subgoals_hyp); - (match (print_string "targ1------------\n";(nsort targ1)) with - Prop(Null) -> utilisons_A arg1 - |_ -> procedons_par_recurrence_sur_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= - if with_intros - then mind_ind_info_hyp_constr indf !ci - else [] in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Elim_prop_subgoals_hyp (arg1,ici,aci,hci, - (List.length ltree)) - |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, - (List.length ltree))); - isgintro= "standard"} - treearg) - ]) - ltree)) - ] -(************************************************************************) -(* Points fixes *) - -and natural_fix ig lh g gs narg ltree = - let {t_info=info; - t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1; - t_full_env=ge1};t_proof=p1}=(List.hd ltree) in - match lh1 with - {hyp_name=nfun;hyp_type=tfun}::lh2 -> - let ltree=[{t_info=info; - t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1; - t_full_env=ge1}; - t_proof=p1}] in - spv - [ (natural_lhyp lh ig.ihsg); - calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_reduce ig lh g gs ge mode la ltree = - match la with - {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro="simpl"}) - ltree) - ] - | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr -> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=Reduce_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_split ig lh g gs ge la ltree = - match la with - [arg] -> - let _env= (gLOB ge) in - let arg1= (*dbize _env*) arg in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - pour_montrer_G_la_valeur_recherchee_est_A g arg1; - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree) - ] - | [] -> - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree) - ] - | _ -> assert false -and natural_generalize ig lh g gs ge la ltree = - match la with - [(_,(_,arg)),_] -> - let _env= (gLOB ge) in - let arg1= (*dbize env*) arg in - let _type_arg=type_of (Global.env()) Evd.empty arg in -(* let type_arg=type_of_ast ge arg in*) - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - on_se_sert_de_A arg1; - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_right ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g - ] -and natural_left ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g - ] -and natural_auto ig lh g gs ltree = - match ig.isgintro with - "trivial_equality" -> spe - | _ -> - if ltree=[] - then sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - coq_le_demontre_seul ()] - else spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} - ) - ltree)] -and natural_infoauto ig lh g gs ltree = - match ig.isgintro with - "trivial_equality" -> - spshrink "trivial_equality" - (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"} - (List.hd ltree)) - | _ -> sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - coq_le_demontre_seul (); - spshrink "auto" - (sph [spi; - (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""} - (List.hd ltree))])] -and natural_trivial ig lh g gs ltree = - if ltree=[] - then sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - ce_qui_est_trivial () ] - else spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ". "); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree)] -and natural_rewrite ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - en_utilisant_l_egalite_A arg; - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="rewrite"}) - ltree) - ] -;; - -let natural_ntree_path ig g = - Random.init(0); - natural_ntree ig g -;; - -let show_proof lang gpath = - (match lang with - "fr" -> natural_language:=French - |"en" -> natural_language:=English - | _ -> natural_language:=English); - path:=List.rev gpath; - name_count:=0; - let ntree=(get_nproof ()) in - let {t_info=i;t_goal=g;t_proof=p} =ntree in - root_of_text_proof - (sph [(natural_ntree_path {ihsg=All_subgoals_hyp; - isgintro="standard"} - {t_info="not_proved";t_goal=g;t_proof=p}); - spr]) - ;; - -let show_nproof path = - pp (sp_print (sph [spi; show_proof "fr" path]));; - -vinterp_add "ShowNaturalProof" - (fun _ -> - (fun () ->show_nproof[];()));; - -(*********************************************************************** -debug sous cygwin: - -PATH=/usr/local/bin:/usr/bin:$PATH -COQTOP=d:/Tools/coq-7avril -CAMLLIB=/usr/local/lib/ocaml -CAMLP4LIB=/usr/local/lib/camlp4 -export CAMLLIB -export COQTOP -export CAMLP4LIB -cd d:/Tools/pcoq/src/text -d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history - - - -Lemma l1: (A, B : Prop) A \/ B -> B -> A. -Intros. -Elim H. -Auto. -Qed. - - -Drop. - -#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; -#load "xlate.cmo";; -#load "translate.cmo";; -#load "showproof_ct.cmo";; -#load "showproof.cmo";; -#load "pbp.cmo";; -#load "debug_tac.cmo";; -#load "name_to_ast.cmo";; -#load "paths.cmo";; -#load "dad.cmo";; -#load "vtp.cmo";; -#load "history.cmo";; -#load "centaur.cmo";; -Xlate.set_xlate_mut_stuff Centaur.globcv;; -Xlate.declare_in_coq();; - -#use "showproof.ml";; - -let pproof x = pP (sp_print x);; -Pp_control.set_depth_boxes 100;; -#install_printer pproof;; - -ep();; -let bidon = ref (constr_of_string "O");; - -#trace to_nproof;; -***********************************************************************) -let ep()=show_proof "fr" [];; diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli deleted file mode 100755 index 9b6787b7..00000000 --- a/contrib/interface/showproof.mli +++ /dev/null @@ -1,21 +0,0 @@ -open Environ -open Evd -open Names -open Term -open Util -open Proof_type -open Pfedit -open Term -open Reduction -open Clenv -open Typing -open Inductive -open Vernacinterp -open Declarations -open Showproof_ct -open Proof_trees -open Sign -open Pp -open Printer - -val show_proof : string -> int list -> Ascent.ct_TEXT;; diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml deleted file mode 100644 index dd7f455d..00000000 --- a/contrib/interface/showproof_ct.ml +++ /dev/null @@ -1,184 +0,0 @@ -(*****************************************************************************) -(* - Vers Ctcoq -*) - -open Metasyntax -open Printer -open Pp -open Translate -open Ascent -open Vtp -open Xlate - -let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);; - -let sps s = - ct_text s - ;; - - -let sphs s = - ct_text s - ;; - -let spe = sphs "";; -let spb = sps " ";; -let spr = sps "Retour chariot pour Show proof";; - -let spnb n = - let s = ref "" in - for i=1 to n do s:=(!s)^" "; done; sps !s -;; - - -let rec spclean l = - match l with - [] -> [] - |x::l -> if x=spe then (spclean l) else x::(spclean l) -;; - - -let spnb n = - let s = ref "" in - for i=1 to n do s:=(!s)^" "; done; sps !s -;; - -let ct_FORMULA_constr = Hashtbl.create 50;; - -let stde() = (Global.env()) - -;; - -let spt t = - let f = (translate_constr true (stde()) t) in - Hashtbl.add ct_FORMULA_constr f t; - CT_text_formula f -;; - - - -let root_of_text_proof t= - CT_text_op [ct_text "root_of_text_proof"; - t] - ;; - -let spshrink info t = - CT_text_op [ct_text "shrink"; - CT_text_op [ct_text info; - t]] -;; - -let spuselemma intro x y = - CT_text_op [ct_text "uselemma"; - ct_text intro; - x;y] -;; - -let sptoprove p t = - CT_text_op [ct_text "to_prove"; - CT_text_path p; - ct_text "goal"; - (spt t)] -;; -let sphyp p h t = - CT_text_op [ct_text "hyp"; - CT_text_path p; - ct_text h; - (spt t)] -;; -let sphypt p h t = - CT_text_op [ct_text "hyp_with_type"; - CT_text_path p; - ct_text h; - (spt t)] -;; - -let spwithtac x t = - CT_text_op [ct_text "with_tactic"; - ct_text t; - x] -;; - - -let spv l = - let l= spclean l in - CT_text_v l -;; - -let sph l = - let l= spclean l in - CT_text_h l -;; - - -let sphv l = - let l= spclean l in - CT_text_hv l -;; - -let rec prlist_with_sep f g l = - match l with - [] -> hov 0 (mt ()) - |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) -;; - -let rec sp_print x = - match x with - | CT_coerce_ID_to_TEXT (CT_ident s) - -> (match s with - | "\n" -> fnl () - | "Retour chariot pour Show proof" -> fnl () - |_ -> str s) - | CT_text_formula f -> pr_lconstr (Hashtbl.find ct_FORMULA_constr f) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident "goal"); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (str "<b>" ++ sp_print g ++ str "</b>") - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma"); - CT_coerce_ID_to_TEXT (CT_ident intro); - l;g] -> - h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident hyp); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (str hyp) - - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident hyp); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") - - | CT_text_h l -> - h 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_v l -> - v 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_hv l -> - h 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink"); - CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]] -> - h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); - t]-> - sp_print t - | _ -> str "..." -;; - diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml deleted file mode 100644 index 559860b2..00000000 --- a/contrib/interface/translate.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Names;; -open Sign;; -open Util;; -open Term;; -open Pp;; -open Libobject;; -open Library;; -open Vernacinterp;; -open Tacmach;; -open Pfedit;; -open Parsing;; -open Evd;; -open Evarutil;; - -open Xlate;; -open Vtp;; -open Ascent;; -open Environ;; -open Proof_type;; - -(*translates a formula into a centaur-tree --> FORMULA *) -let translate_constr at_top env c = - xlate_formula (Constrextern.extern_constr at_top env c);; - -(*translates a named_context into a centaur-tree --> PREMISES_LIST *) -(* this code is inspired from printer.ml (function pr_named_context_of) *) -let translate_sign env = - let l = - Environ.fold_named_context - (fun env (id,v,c) l -> - (match v with - None -> - CT_premise(CT_ident(string_of_id id), translate_constr false env c) - | Some v1 -> - CT_eval_result - (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), - translate_constr false env v1, - translate_constr false env c))::l) - env ~init:[] - in - CT_premises_list l;; - -(* the function rev_and_compact performs two operations: - 1- it reverses the list of integers given as argument - 2- it replaces sequences of "1" by a negative number that is - the length of the sequence. *) -let rec rev_and_compact l = function - [] -> l - | 1::tl -> - (match l with - n::tl' -> - if n < 0 then - rev_and_compact ((n - 1)::tl') tl - else - rev_and_compact ((-1)::l) tl - | [] -> rev_and_compact [-1] tl) - | a::tl -> - if a < 0 then - (match l with - n::tl' -> - if n < 0 then - rev_and_compact ((n + a)::tl') tl - else - rev_and_compact (a::l) tl - | [] -> rev_and_compact (a::l) tl) - else - rev_and_compact (a::l) tl;; - -(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *) -let translate_path l = - CT_signed_int_list - (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) - (rev_and_compact [] l));; - -(*translates a path and a goal into a centaur-tree --> RULE *) -let translate_goal (g:goal) = - CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);; - -let translate_goals (gl: goal list) = - CT_rule_list (List.map translate_goal gl);; diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli deleted file mode 100644 index 34841fc4..00000000 --- a/contrib/interface/translate.mli +++ /dev/null @@ -1,12 +0,0 @@ -open Ascent;; -open Evd;; -open Proof_type;; -open Environ;; -open Term;; - -val translate_goal : goal -> ct_RULE;; -val translate_goals : goal list -> ct_RULE_LIST;; -(* The boolean argument indicates whether names from the environment should *) -(* be avoided (same interpretation as for prterm_env and ast_of_constr) *) -val translate_constr : bool -> env -> constr -> ct_FORMULA;; -val translate_path : int list -> ct_SIGNED_INT_LIST;; diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc deleted file mode 100644 index 4d3dc558..00000000 --- a/contrib/interface/vernacrc +++ /dev/null @@ -1,12 +0,0 @@ -# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $ - -# This file is loaded initially by ./vernacparser. - -load_syntax_file 1 Notations -load_syntax_file 2 Logic -load_syntax_file 34 Omega -load_syntax_file 27 Ring -quiet_parse_string -Goal a. -&& END--OF--DATA -print_version diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml deleted file mode 100644 index 94609009..00000000 --- a/contrib/interface/vtp.ml +++ /dev/null @@ -1,1945 +0,0 @@ -open Ascent;; -open Pp;; - -(* LEM: This is actually generated automatically *) - -let fNODE s n = - (str "n\n") ++ - (str ("vernac$" ^ s)) ++ - (str "\n") ++ - (int n) ++ - (str "\n");; - -let fATOM s1 = - (str "a\n") ++ - (str ("vernac$" ^ s1)) ++ - (str "\n");; - -let f_atom_string = str;; -let f_atom_int = int;; -let rec fAST = function -| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x -| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x -| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x -| CT_astnode(x1, x2) -> - fID x1 ++ - fAST_LIST x2 ++ - fNODE "astnode" 2 -| CT_astpath(x1) -> - fID_LIST x1 ++ - fNODE "astpath" 1 -| CT_astslam(x1, x2) -> - fID_OPT x1 ++ - fAST x2 ++ - fNODE "astslam" 2 -and fAST_LIST = function -| CT_ast_list l -> - (List.fold_left (++) (mt()) (List.map fAST l)) ++ - fNODE "ast_list" (List.length l) -and fBINARY = function -| CT_binary x -> fATOM "binary" ++ - (f_atom_int x) ++ - str "\n" -and fBINDER = function -| CT_coerce_DEF_to_BINDER x -> fDEF x -| CT_binder(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "binder" 2 -| CT_binder_coercion(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "binder_coercion" 2 -and fBINDER_LIST = function -| CT_binder_list l -> - (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ - fNODE "binder_list" (List.length l) -and fBINDER_NE_LIST = function -| CT_binder_ne_list(x,l) -> - fBINDER x ++ - (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ - fNODE "binder_ne_list" (1 + (List.length l)) -and fBINDING = function -| CT_binding(x1, x2) -> - fID_OR_INT x1 ++ - fFORMULA x2 ++ - fNODE "binding" 2 -and fBINDING_LIST = function -| CT_binding_list l -> - (List.fold_left (++) (mt()) (List.map fBINDING l)) ++ - fNODE "binding_list" (List.length l) -and fBOOL = function -| CT_false -> fNODE "false" 0 -| CT_true -> fNODE "true" 0 -and fCASE = function -| CT_case x -> fATOM "case" ++ - (f_atom_string x) ++ - str "\n" -and fCLAUSE = function -| CT_clause(x1, x2) -> - fHYP_LOCATION_LIST_OR_STAR x1 ++ - fSTAR_OPT x2 ++ - fNODE "clause" 2 -and fCOERCION_OPT = function -| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x -| CT_coercion_atm -> fNODE "coercion_atm" 0 -and fCOFIXTAC = function -| CT_cofixtac(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "cofixtac" 2 -and fCOFIX_REC = function -| CT_cofix_rec(x1, x2, x3, x4) -> - fID x1 ++ - fBINDER_LIST x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "cofix_rec" 4 -and fCOFIX_REC_LIST = function -| CT_cofix_rec_list(x,l) -> - fCOFIX_REC x ++ - (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++ - fNODE "cofix_rec_list" (1 + (List.length l)) -and fCOFIX_TAC_LIST = function -| CT_cofix_tac_list l -> - (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++ - fNODE "cofix_tac_list" (List.length l) -and fCOMMAND = function -| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x -| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x -| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x -| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x -| CT_abort(x1) -> - fID_OPT_OR_ALL x1 ++ - fNODE "abort" 1 -| CT_abstraction(x1, x2, x3) -> - fID x1 ++ - fFORMULA x2 ++ - fINT_LIST x3 ++ - fNODE "abstraction" 3 -| CT_add_field(x1, x2, x3, x4) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fFORMULA x3 ++ - fFORMULA_OPT x4 ++ - fNODE "add_field" 4 -| CT_add_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "add_natural_feature" 2 -| CT_addpath(x1, x2) -> - fSTRING x1 ++ - fID_OPT x2 ++ - fNODE "addpath" 2 -| CT_arguments_scope(x1, x2) -> - fID x1 ++ - fID_OPT_LIST x2 ++ - fNODE "arguments_scope" 2 -| CT_bind_scope(x1, x2) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fNODE "bind_scope" 2 -| CT_cd(x1) -> - fSTRING_OPT x1 ++ - fNODE "cd" 1 -| CT_check(x1) -> - fFORMULA x1 ++ - fNODE "check" 1 -| CT_class(x1) -> - fID x1 ++ - fNODE "class" 1 -| CT_close_scope(x1) -> - fID x1 ++ - fNODE "close_scope" 1 -| CT_coercion(x1, x2, x3, x4, x5) -> - fLOCAL_OPT x1 ++ - fIDENTITY_OPT x2 ++ - fID x3 ++ - fID x4 ++ - fID x5 ++ - fNODE "coercion" 5 -| CT_cofix_decl(x1) -> - fCOFIX_REC_LIST x1 ++ - fNODE "cofix_decl" 1 -| CT_compile_module(x1, x2, x3) -> - fVERBOSE_OPT x1 ++ - fID x2 ++ - fSTRING_OPT x3 ++ - fNODE "compile_module" 3 -| CT_declare_module(x1, x2, x3, x4) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_CHECK x3 ++ - fMODULE_EXPR x4 ++ - fNODE "declare_module" 4 -| CT_define_notation(x1, x2, x3, x4) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "define_notation" 4 -| CT_definition(x1, x2, x3, x4, x5) -> - fDEFN x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fDEF_BODY x4 ++ - fFORMULA_OPT x5 ++ - fNODE "definition" 5 -| CT_delim_scope(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "delim_scope" 2 -| CT_delpath(x1) -> - fSTRING x1 ++ - fNODE "delpath" 1 -| CT_derive_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "derive_depinversion" 4 -| CT_derive_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fINT_OPT x2 ++ - fID x3 ++ - fID x4 ++ - fNODE "derive_inversion" 4 -| CT_derive_inversion_with(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "derive_inversion_with" 4 -| CT_explain_proof(x1) -> - fINT_LIST x1 ++ - fNODE "explain_proof" 1 -| CT_explain_prooftree(x1) -> - fINT_LIST x1 ++ - fNODE "explain_prooftree" 1 -| CT_export_id(x1) -> - fID_NE_LIST x1 ++ - fNODE "export_id" 1 -| CT_extract_to_file(x1, x2) -> - fSTRING x1 ++ - fID_NE_LIST x2 ++ - fNODE "extract_to_file" 2 -| CT_extraction(x1) -> - fID_OPT x1 ++ - fNODE "extraction" 1 -| CT_fix_decl(x1) -> - fFIX_REC_LIST x1 ++ - fNODE "fix_decl" 1 -| CT_focus(x1) -> - fINT_OPT x1 ++ - fNODE "focus" 1 -| CT_go(x1) -> - fINT_OR_LOCN x1 ++ - fNODE "go" 1 -| CT_guarded -> fNODE "guarded" 0 -| CT_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1 ++ - fINT x2 ++ - fDESTRUCT_LOCATION x3 ++ - fFORMULA x4 ++ - fTACTIC_COM x5 ++ - fID_LIST x6 ++ - fNODE "hint_destruct" 6 -| CT_hint_extern(x1, x2, x3, x4) -> - fINT x1 ++ - fFORMULA_OPT x2 ++ - fTACTIC_COM x3 ++ - fID_LIST x4 ++ - fNODE "hint_extern" 4 -| CT_hintrewrite(x1, x2, x3, x4) -> - fORIENTATION x1 ++ - fFORMULA_NE_LIST x2 ++ - fID x3 ++ - fTACTIC_COM x4 ++ - fNODE "hintrewrite" 4 -| CT_hints(x1, x2, x3) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fID_LIST x3 ++ - fNODE "hints" 3 -| CT_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "hints_immediate" 2 -| CT_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "hints_resolve" 2 -| CT_hyp_search_pattern(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "hyp_search_pattern" 2 -| CT_implicits(x1, x2) -> - fID x1 ++ - fID_LIST_OPT x2 ++ - fNODE "implicits" 2 -| CT_import_id(x1) -> - fID_NE_LIST x1 ++ - fNODE "import_id" 1 -| CT_ind_scheme(x1) -> - fSCHEME_SPEC_LIST x1 ++ - fNODE "ind_scheme" 1 -| CT_infix(x1, x2, x3, x4) -> - fSTRING x1 ++ - fID x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "infix" 4 -| CT_inline(x1) -> - fID_NE_LIST x1 ++ - fNODE "inline" 1 -| CT_inspect(x1) -> - fINT x1 ++ - fNODE "inspect" 1 -| CT_kill_node(x1) -> - fINT x1 ++ - fNODE "kill_node" 1 -| CT_load(x1, x2) -> - fVERBOSE_OPT x1 ++ - fID_OR_STRING x2 ++ - fNODE "load" 2 -| CT_local_close_scope(x1) -> - fID x1 ++ - fNODE "local_close_scope" 1 -| CT_local_define_notation(x1, x2, x3, x4) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "local_define_notation" 4 -| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1 ++ - fINT x2 ++ - fDESTRUCT_LOCATION x3 ++ - fFORMULA x4 ++ - fTACTIC_COM x5 ++ - fID_LIST x6 ++ - fNODE "local_hint_destruct" 6 -| CT_local_hint_extern(x1, x2, x3, x4) -> - fINT x1 ++ - fFORMULA x2 ++ - fTACTIC_COM x3 ++ - fID_LIST x4 ++ - fNODE "local_hint_extern" 4 -| CT_local_hints(x1, x2, x3) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fID_LIST x3 ++ - fNODE "local_hints" 3 -| CT_local_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "local_hints_immediate" 2 -| CT_local_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "local_hints_resolve" 2 -| CT_local_infix(x1, x2, x3, x4) -> - fSTRING x1 ++ - fID x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "local_infix" 4 -| CT_local_open_scope(x1) -> - fID x1 ++ - fNODE "local_open_scope" 1 -| CT_local_reserve_notation(x1, x2) -> - fSTRING x1 ++ - fMODIFIER_LIST x2 ++ - fNODE "local_reserve_notation" 2 -| CT_locate(x1) -> - fID x1 ++ - fNODE "locate" 1 -| CT_locate_file(x1) -> - fSTRING x1 ++ - fNODE "locate_file" 1 -| CT_locate_lib(x1) -> - fID x1 ++ - fNODE "locate_lib" 1 -| CT_locate_notation(x1) -> - fSTRING x1 ++ - fNODE "locate_notation" 1 -| CT_mind_decl(x1, x2) -> - fCO_IND x1 ++ - fIND_SPEC_LIST x2 ++ - fNODE "mind_decl" 2 -| CT_ml_add_path(x1) -> - fSTRING x1 ++ - fNODE "ml_add_path" 1 -| CT_ml_declare_modules(x1) -> - fSTRING_NE_LIST x1 ++ - fNODE "ml_declare_modules" 1 -| CT_ml_print_modules -> fNODE "ml_print_modules" 0 -| CT_ml_print_path -> fNODE "ml_print_path" 0 -| CT_module(x1, x2, x3, x4) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_CHECK x3 ++ - fMODULE_EXPR x4 ++ - fNODE "module" 4 -| CT_module_type_decl(x1, x2, x3) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_OPT x3 ++ - fNODE "module_type_decl" 3 -| CT_no_inline(x1) -> - fID_NE_LIST x1 ++ - fNODE "no_inline" 1 -| CT_omega_flag(x1, x2) -> - fOMEGA_MODE x1 ++ - fOMEGA_FEATURE x2 ++ - fNODE "omega_flag" 2 -| CT_open_scope(x1) -> - fID x1 ++ - fNODE "open_scope" 1 -| CT_print -> fNODE "print" 0 -| CT_print_about(x1) -> - fID x1 ++ - fNODE "print_about" 1 -| CT_print_all -> fNODE "print_all" 0 -| CT_print_classes -> fNODE "print_classes" 0 -| CT_print_ltac id -> - fID id ++ - fNODE "print_ltac" 1 -| CT_print_coercions -> fNODE "print_coercions" 0 -| CT_print_grammar(x1) -> - fGRAMMAR x1 ++ - fNODE "print_grammar" 1 -| CT_print_graph -> fNODE "print_graph" 0 -| CT_print_hint(x1) -> - fID_OPT x1 ++ - fNODE "print_hint" 1 -| CT_print_hintdb(x1) -> - fID_OR_STAR x1 ++ - fNODE "print_hintdb" 1 -| CT_print_rewrite_hintdb(x1) -> - fID x1 ++ - fNODE "print_rewrite_hintdb" 1 -| CT_print_id(x1) -> - fID x1 ++ - fNODE "print_id" 1 -| CT_print_implicit(x1) -> - fID x1 ++ - fNODE "print_implicit" 1 -| CT_print_loadpath -> fNODE "print_loadpath" 0 -| CT_print_module(x1) -> - fID x1 ++ - fNODE "print_module" 1 -| CT_print_module_type(x1) -> - fID x1 ++ - fNODE "print_module_type" 1 -| CT_print_modules -> fNODE "print_modules" 0 -| CT_print_natural(x1) -> - fID x1 ++ - fNODE "print_natural" 1 -| CT_print_natural_feature(x1) -> - fNATURAL_FEATURE x1 ++ - fNODE "print_natural_feature" 1 -| CT_print_opaqueid(x1) -> - fID x1 ++ - fNODE "print_opaqueid" 1 -| CT_print_path(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "print_path" 2 -| CT_print_proof(x1) -> - fID x1 ++ - fNODE "print_proof" 1 -| CT_print_scope(x1) -> - fID x1 ++ - fNODE "print_scope" 1 -| CT_print_setoids -> fNODE "print_setoids" 0 -| CT_print_scopes -> fNODE "print_scopes" 0 -| CT_print_section(x1) -> - fID x1 ++ - fNODE "print_section" 1 -| CT_print_states -> fNODE "print_states" 0 -| CT_print_tables -> fNODE "print_tables" 0 -| CT_print_universes(x1) -> - fSTRING_OPT x1 ++ - fNODE "print_universes" 1 -| CT_print_visibility(x1) -> - fID_OPT x1 ++ - fNODE "print_visibility" 1 -| CT_proof(x1) -> - fFORMULA x1 ++ - fNODE "proof" 1 -| CT_proof_no_op -> fNODE "proof_no_op" 0 -| CT_proof_with(x1) -> - fTACTIC_COM x1 ++ - fNODE "proof_with" 1 -| CT_pwd -> fNODE "pwd" 0 -| CT_quit -> fNODE "quit" 0 -| CT_read_module(x1) -> - fID x1 ++ - fNODE "read_module" 1 -| CT_rec_ml_add_path(x1) -> - fSTRING x1 ++ - fNODE "rec_ml_add_path" 1 -| CT_recaddpath(x1, x2) -> - fSTRING x1 ++ - fID_OPT x2 ++ - fNODE "recaddpath" 2 -| CT_record(x1, x2, x3, x4, x5, x6) -> - fCOERCION_OPT x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fFORMULA x4 ++ - fID_OPT x5 ++ - fRECCONSTR_LIST x6 ++ - fNODE "record" 6 -| CT_remove_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "remove_natural_feature" 2 -| CT_require(x1, x2, x3) -> - fIMPEXP x1 ++ - fSPEC_OPT x2 ++ - fID_NE_LIST_OR_STRING x3 ++ - fNODE "require" 3 -| CT_reserve(x1, x2) -> - fID_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "reserve" 2 -| CT_reserve_notation(x1, x2) -> - fSTRING x1 ++ - fMODIFIER_LIST x2 ++ - fNODE "reserve_notation" 2 -| CT_reset(x1) -> - fID x1 ++ - fNODE "reset" 1 -| CT_reset_section(x1) -> - fID x1 ++ - fNODE "reset_section" 1 -| CT_restart -> fNODE "restart" 0 -| CT_restore_state(x1) -> - fID x1 ++ - fNODE "restore_state" 1 -| CT_resume(x1) -> - fID_OPT x1 ++ - fNODE "resume" 1 -| CT_save(x1, x2) -> - fTHM_OPT x1 ++ - fID_OPT x2 ++ - fNODE "save" 2 -| CT_scomments(x1) -> - fSCOMMENT_CONTENT_LIST x1 ++ - fNODE "scomments" 1 -| CT_search(x1, x2) -> - fID x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search" 2 -| CT_search_about(x1, x2) -> - fID_OR_STRING_NE_LIST x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_about" 2 -| CT_search_pattern(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_pattern" 2 -| CT_search_rewrite(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_rewrite" 2 -| CT_section_end(x1) -> - fID x1 ++ - fNODE "section_end" 1 -| CT_section_struct(x1, x2, x3) -> - fSECTION_BEGIN x1 ++ - fSECTION_BODY x2 ++ - fCOMMAND x3 ++ - fNODE "section_struct" 3 -| CT_set_natural(x1) -> - fID x1 ++ - fNODE "set_natural" 1 -| CT_set_natural_default -> fNODE "set_natural_default" 0 -| CT_set_option(x1) -> - fTABLE x1 ++ - fNODE "set_option" 1 -| CT_set_option_value(x1, x2) -> - fTABLE x1 ++ - fSINGLE_OPTION_VALUE x2 ++ - fNODE "set_option_value" 2 -| CT_set_option_value2(x1, x2) -> - fTABLE x1 ++ - fID_OR_STRING_NE_LIST x2 ++ - fNODE "set_option_value2" 2 -| CT_sethyp(x1) -> - fINT x1 ++ - fNODE "sethyp" 1 -| CT_setundo(x1) -> - fINT x1 ++ - fNODE "setundo" 1 -| CT_show_existentials -> fNODE "show_existentials" 0 -| CT_show_goal(x1) -> - fINT_OPT x1 ++ - fNODE "show_goal" 1 -| CT_show_implicit(x1) -> - fINT x1 ++ - fNODE "show_implicit" 1 -| CT_show_intro -> fNODE "show_intro" 0 -| CT_show_intros -> fNODE "show_intros" 0 -| CT_show_node -> fNODE "show_node" 0 -| CT_show_proof -> fNODE "show_proof" 0 -| CT_show_proofs -> fNODE "show_proofs" 0 -| CT_show_script -> fNODE "show_script" 0 -| CT_show_tree -> fNODE "show_tree" 0 -| CT_solve(x1, x2, x3) -> - fINT x1 ++ - fTACTIC_COM x2 ++ - fDOTDOT_OPT x3 ++ - fNODE "solve" 3 -| CT_strategy(CT_level_list x1) -> - List.fold_left (++) (mt()) - (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++ - fNODE "strategy" (List.length x1) -| CT_suspend -> fNODE "suspend" 0 -| CT_syntax_macro(x1, x2, x3) -> - fID x1 ++ - fFORMULA x2 ++ - fINT_OPT x3 ++ - fNODE "syntax_macro" 3 -| CT_tactic_definition(x1) -> - fTAC_DEF_NE_LIST x1 ++ - fNODE "tactic_definition" 1 -| CT_test_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "test_natural_feature" 2 -| CT_theorem_struct(x1, x2) -> - fTHEOREM_GOAL x1 ++ - fPROOF_SCRIPT x2 ++ - fNODE "theorem_struct" 2 -| CT_time(x1) -> - fCOMMAND x1 ++ - fNODE "time" 1 -| CT_undo(x1) -> - fINT_OPT x1 ++ - fNODE "undo" 1 -| CT_unfocus -> fNODE "unfocus" 0 -| CT_unset_option(x1) -> - fTABLE x1 ++ - fNODE "unset_option" 1 -| CT_unsethyp -> fNODE "unsethyp" 0 -| CT_unsetundo -> fNODE "unsetundo" 0 -| CT_user_vernac(x1, x2) -> - fID x1 ++ - fVARG_LIST x2 ++ - fNODE "user_vernac" 2 -| CT_variable(x1, x2) -> - fVAR x1 ++ - fBINDER_NE_LIST x2 ++ - fNODE "variable" 2 -| CT_write_module(x1, x2) -> - fID x1 ++ - fSTRING_OPT x2 ++ - fNODE "write_module" 2 -and fLEVEL = function -| CT_Opaque -> fNODE "opaque" 0 -| CT_Level n -> fINT n ++ fNODE "level" 1 -| CT_Expand -> fNODE "expand" 0 -and fCOMMAND_LIST = function -| CT_command_list(x,l) -> - fCOMMAND x ++ - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "command_list" (1 + (List.length l)) -and fCOMMENT = function -| CT_comment x -> fATOM "comment" ++ - (f_atom_string x) ++ - str "\n" -and fCOMMENT_S = function -| CT_comment_s l -> - (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++ - fNODE "comment_s" (List.length l) -and fCONSTR = function -| CT_constr(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "constr" 2 -| CT_constr_coercion(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "constr_coercion" 2 -and fCONSTR_LIST = function -| CT_constr_list l -> - (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++ - fNODE "constr_list" (List.length l) -and fCONTEXT_HYP_LIST = function -| CT_context_hyp_list l -> - (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++ - fNODE "context_hyp_list" (List.length l) -and fCONTEXT_PATTERN = function -| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x -| CT_context(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "context" 2 -and fCONTEXT_RULE = function -| CT_context_rule(x1, x2, x3) -> - fCONTEXT_HYP_LIST x1 ++ - fCONTEXT_PATTERN x2 ++ - fTACTIC_COM x3 ++ - fNODE "context_rule" 3 -| CT_def_context_rule(x1) -> - fTACTIC_COM x1 ++ - fNODE "def_context_rule" 1 -and fCONVERSION_FLAG = function -| CT_beta -> fNODE "beta" 0 -| CT_delta -> fNODE "delta" 0 -| CT_evar -> fNODE "evar" 0 -| CT_iota -> fNODE "iota" 0 -| CT_zeta -> fNODE "zeta" 0 -and fCONVERSION_FLAG_LIST = function -| CT_conversion_flag_list l -> - (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++ - fNODE "conversion_flag_list" (List.length l) -and fCONV_SET = function -| CT_unf l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "unf" (List.length l) -| CT_unfbut l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "unfbut" (List.length l) -and fCO_IND = function -| CT_co_ind x -> fATOM "co_ind" ++ - (f_atom_string x) ++ - str "\n" -and fDECL_NOTATION_OPT = function -| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x -| CT_decl_notation(x1, x2, x3) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fID_OPT x3 ++ - fNODE "decl_notation" 3 -and fDEF = function -| CT_def(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "def" 2 -and fDEFN = function -| CT_defn x -> fATOM "defn" ++ - (f_atom_string x) ++ - str "\n" -and fDEFN_OR_THM = function -| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x -| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x -and fDEF_BODY = function -| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x -| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x -| CT_type_of(x1) -> - fFORMULA x1 ++ - fNODE "type_of" 1 -and fDEF_BODY_OPT = function -| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x -| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x -and fDEP = function -| CT_dep x -> fATOM "dep" ++ - (f_atom_string x) ++ - str "\n" -and fDESTRUCTING = function -| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x -| CT_destructing -> fNODE "destructing" 0 -and fDESTRUCT_LOCATION = function -| CT_conclusion_location -> fNODE "conclusion_location" 0 -| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0 -| CT_hypothesis_location -> fNODE "hypothesis_location" 0 -and fDOTDOT_OPT = function -| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x -| CT_dotdot -> fNODE "dotdot" 0 -and fEQN = function -| CT_eqn(x1, x2) -> - fMATCH_PATTERN_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "eqn" 2 -and fEQN_LIST = function -| CT_eqn_list l -> - (List.fold_left (++) (mt()) (List.map fEQN l)) ++ - fNODE "eqn_list" (List.length l) -and fEVAL_CMD = function -| CT_eval(x1, x2, x3) -> - fINT_OPT x1 ++ - fRED_COM x2 ++ - fFORMULA x3 ++ - fNODE "eval" 3 -and fFIXTAC = function -| CT_fixtac(x1, x2, x3) -> - fID x1 ++ - fINT x2 ++ - fFORMULA x3 ++ - fNODE "fixtac" 3 -and fFIX_BINDER = function -| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x -| CT_fix_binder(x1, x2, x3, x4) -> - fID x1 ++ - fINT x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "fix_binder" 4 -and fFIX_BINDER_LIST = function -| CT_fix_binder_list(x,l) -> - fFIX_BINDER x ++ - (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++ - fNODE "fix_binder_list" (1 + (List.length l)) -and fFIX_REC = function -| CT_fix_rec(x1, x2, x3, x4, x5) -> - fID x1 ++ - fBINDER_NE_LIST x2 ++ - fID_OPT x3 ++ - fFORMULA x4 ++ - fFORMULA x5 ++ - fNODE "fix_rec" 5 -and fFIX_REC_LIST = function -| CT_fix_rec_list(x,l) -> - fFIX_REC x ++ - (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++ - fNODE "fix_rec_list" (1 + (List.length l)) -and fFIX_TAC_LIST = function -| CT_fix_tac_list l -> - (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++ - fNODE "fix_tac_list" (List.length l) -and fFORMULA = function -| CT_coerce_BINARY_to_FORMULA x -> fBINARY x -| CT_coerce_ID_to_FORMULA x -> fID x -| CT_coerce_NUM_to_FORMULA x -> fNUM x -| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x -| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x -| CT_appc(x1, x2) -> - fFORMULA x1 ++ - fFORMULA_NE_LIST x2 ++ - fNODE "appc" 2 -| CT_arrowc(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "arrowc" 2 -| CT_bang(x1) -> - fFORMULA x1 ++ - fNODE "bang" 1 -| CT_cases(x1, x2, x3) -> - fMATCHED_FORMULA_NE_LIST x1 ++ - fFORMULA_OPT x2 ++ - fEQN_LIST x3 ++ - fNODE "cases" 3 -| CT_cofixc(x1, x2) -> - fID x1 ++ - fCOFIX_REC_LIST x2 ++ - fNODE "cofixc" 2 -| CT_elimc(x1, x2, x3, x4) -> - fCASE x1 ++ - fFORMULA_OPT x2 ++ - fFORMULA x3 ++ - fFORMULA_LIST x4 ++ - fNODE "elimc" 4 -| CT_existvarc -> fNODE "existvarc" 0 -| CT_fixc(x1, x2) -> - fID x1 ++ - fFIX_BINDER_LIST x2 ++ - fNODE "fixc" 2 -| CT_if(x1, x2, x3, x4) -> - fFORMULA x1 ++ - fRETURN_INFO x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "if" 4 -| CT_inductive_let(x1, x2, x3, x4) -> - fFORMULA_OPT x1 ++ - fID_OPT_NE_LIST x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "inductive_let" 4 -| CT_labelled_arg(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "labelled_arg" 2 -| CT_lambdac(x1, x2) -> - fBINDER_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "lambdac" 2 -| CT_let_tuple(x1, x2, x3, x4) -> - fID_OPT_NE_LIST x1 ++ - fRETURN_INFO x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "let_tuple" 4 -| CT_letin(x1, x2) -> - fDEF x1 ++ - fFORMULA x2 ++ - fNODE "letin" 2 -| CT_notation(x1, x2) -> - fSTRING x1 ++ - fFORMULA_LIST x2 ++ - fNODE "notation" 2 -| CT_num_encapsulator(x1, x2) -> - fNUM_TYPE x1 ++ - fFORMULA x2 ++ - fNODE "num_encapsulator" 2 -| CT_prodc(x1, x2) -> - fBINDER_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "prodc" 2 -| CT_proj(x1, x2) -> - fFORMULA x1 ++ - fFORMULA_NE_LIST x2 ++ - fNODE "proj" 2 -and fFORMULA_LIST = function -| CT_formula_list l -> - (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ - fNODE "formula_list" (List.length l) -and fFORMULA_NE_LIST = function -| CT_formula_ne_list(x,l) -> - fFORMULA x ++ - (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ - fNODE "formula_ne_list" (1 + (List.length l)) -and fFORMULA_OPT = function -| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x -| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x -and fFORMULA_OR_INT = function -| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x -| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x -and fGRAMMAR = function -| CT_grammar_none -> fNODE "grammar_none" 0 -and fHYP_LOCATION = function -| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x -| CT_intype(x1, x2) -> - fID x1 ++ - fINT_LIST x2 ++ - fNODE "intype" 2 -| CT_invalue(x1, x2) -> - fID x1 ++ - fINT_LIST x2 ++ - fNODE "invalue" 2 -and fHYP_LOCATION_LIST_OR_STAR = function -| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x -| CT_hyp_location_list l -> - (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++ - fNODE "hyp_location_list" (List.length l) -and fID = function -| CT_ident x -> fATOM "ident" ++ - (f_atom_string x) ++ - str "\n" -| CT_metac(x1) -> - fINT x1 ++ - fNODE "metac" 1 -| CT_metaid x -> fATOM "metaid" ++ - (f_atom_string x) ++ - str "\n" -and fIDENTITY_OPT = function -| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x -| CT_identity -> fNODE "identity" 0 -and fID_LIST = function -| CT_id_list l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "id_list" (List.length l) -and fID_LIST_LIST = function -| CT_id_list_list l -> - (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++ - fNODE "id_list_list" (List.length l) -and fID_LIST_OPT = function -| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x -| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x -and fID_NE_LIST = function -| CT_id_ne_list(x,l) -> - fID x ++ - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "id_ne_list" (1 + (List.length l)) -and fID_NE_LIST_OR_STAR = function -| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x -| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x -and fID_NE_LIST_OR_STRING = function -| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x -| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x -and fID_OPT = function -| CT_coerce_ID_to_ID_OPT x -> fID x -| CT_coerce_NONE_to_ID_OPT x -> fNONE x -and fID_OPT_LIST = function -| CT_id_opt_list l -> - (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ - fNODE "id_opt_list" (List.length l) -and fID_OPT_NE_LIST = function -| CT_id_opt_ne_list(x,l) -> - fID_OPT x ++ - (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ - fNODE "id_opt_ne_list" (1 + (List.length l)) -and fID_OPT_OR_ALL = function -| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x -| CT_all -> fNODE "all" 0 -and fID_OR_INT = function -| CT_coerce_ID_to_ID_OR_INT x -> fID x -| CT_coerce_INT_to_ID_OR_INT x -> fINT x -and fID_OR_INT_OPT = function -| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x -| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x -| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x -and fID_OR_STAR = function -| CT_coerce_ID_to_ID_OR_STAR x -> fID x -| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x -and fID_OR_STRING = function -| CT_coerce_ID_to_ID_OR_STRING x -> fID x -| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x -and fID_OR_STRING_NE_LIST = function -| CT_id_or_string_ne_list(x,l) -> - fID_OR_STRING x ++ - (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++ - fNODE "id_or_string_ne_list" (1 + (List.length l)) -and fIMPEXP = function -| CT_coerce_NONE_to_IMPEXP x -> fNONE x -| CT_export -> fNODE "export" 0 -| CT_import -> fNODE "import" 0 -and fIND_SPEC = function -| CT_ind_spec(x1, x2, x3, x4, x5) -> - fID x1 ++ - fBINDER_LIST x2 ++ - fFORMULA x3 ++ - fCONSTR_LIST x4 ++ - fDECL_NOTATION_OPT x5 ++ - fNODE "ind_spec" 5 -and fIND_SPEC_LIST = function -| CT_ind_spec_list l -> - (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++ - fNODE "ind_spec_list" (List.length l) -and fINT = function -| CT_int x -> fATOM "int" ++ - (f_atom_int x) ++ - str "\n" -and fINTRO_PATT = function -| CT_coerce_ID_to_INTRO_PATT x -> fID x -| CT_disj_pattern(x,l) -> - fINTRO_PATT_LIST x ++ - (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++ - fNODE "disj_pattern" (1 + (List.length l)) -and fINTRO_PATT_LIST = function -| CT_intro_patt_list l -> - (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++ - fNODE "intro_patt_list" (List.length l) -and fINTRO_PATT_OPT = function -| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x -| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x -and fINT_LIST = function -| CT_int_list l -> - (List.fold_left (++) (mt()) (List.map fINT l)) ++ - fNODE "int_list" (List.length l) -and fINT_NE_LIST = function -| CT_int_ne_list(x,l) -> - fINT x ++ - (List.fold_left (++) (mt()) (List.map fINT l)) ++ - fNODE "int_ne_list" (1 + (List.length l)) -and fINT_OPT = function -| CT_coerce_INT_to_INT_OPT x -> fINT x -| CT_coerce_NONE_to_INT_OPT x -> fNONE x -and fINT_OR_LOCN = function -| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x -| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x -and fINT_OR_NEXT = function -| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x -| CT_next_level -> fNODE "next_level" 0 -and fINV_TYPE = function -| CT_inv_clear -> fNODE "inv_clear" 0 -| CT_inv_regular -> fNODE "inv_regular" 0 -| CT_inv_simple -> fNODE "inv_simple" 0 -and fIN_OR_OUT_MODULES = function -| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x -| CT_in_modules(x1) -> - fID_NE_LIST x1 ++ - fNODE "in_modules" 1 -| CT_out_modules(x1) -> - fID_NE_LIST x1 ++ - fNODE "out_modules" 1 -and fLET_CLAUSE = function -| CT_let_clause(x1, x2, x3) -> - fID x1 ++ - fTACTIC_OPT x2 ++ - fLET_VALUE x3 ++ - fNODE "let_clause" 3 -and fLET_CLAUSES = function -| CT_let_clauses(x,l) -> - fLET_CLAUSE x ++ - (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++ - fNODE "let_clauses" (1 + (List.length l)) -and fLET_VALUE = function -| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x -| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x -and fLOCAL_OPT = function -| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x -| CT_local -> fNODE "local" 0 -and fLOCN = function -| CT_locn x -> fATOM "locn" ++ - (f_atom_string x) ++ - str "\n" -and fMATCHED_FORMULA = function -| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x -| CT_formula_as(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "formula_as" 2 -| CT_formula_as_in(x1, x2, x3) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fFORMULA x3 ++ - fNODE "formula_as_in" 3 -| CT_formula_in(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "formula_in" 2 -and fMATCHED_FORMULA_NE_LIST = function -| CT_matched_formula_ne_list(x,l) -> - fMATCHED_FORMULA x ++ - (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++ - fNODE "matched_formula_ne_list" (1 + (List.length l)) -and fMATCH_PATTERN = function -| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x -| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x -| CT_pattern_app(x1, x2) -> - fMATCH_PATTERN x1 ++ - fMATCH_PATTERN_NE_LIST x2 ++ - fNODE "pattern_app" 2 -| CT_pattern_as(x1, x2) -> - fMATCH_PATTERN x1 ++ - fID_OPT x2 ++ - fNODE "pattern_as" 2 -| CT_pattern_delimitors(x1, x2) -> - fNUM_TYPE x1 ++ - fMATCH_PATTERN x2 ++ - fNODE "pattern_delimitors" 2 -| CT_pattern_notation(x1, x2) -> - fSTRING x1 ++ - fMATCH_PATTERN_LIST x2 ++ - fNODE "pattern_notation" 2 -and fMATCH_PATTERN_LIST = function -| CT_match_pattern_list l -> - (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ - fNODE "match_pattern_list" (List.length l) -and fMATCH_PATTERN_NE_LIST = function -| CT_match_pattern_ne_list(x,l) -> - fMATCH_PATTERN x ++ - (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ - fNODE "match_pattern_ne_list" (1 + (List.length l)) -and fMATCH_TAC_RULE = function -| CT_match_tac_rule(x1, x2) -> - fCONTEXT_PATTERN x1 ++ - fLET_VALUE x2 ++ - fNODE "match_tac_rule" 2 -and fMATCH_TAC_RULES = function -| CT_match_tac_rules(x,l) -> - fMATCH_TAC_RULE x ++ - (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++ - fNODE "match_tac_rules" (1 + (List.length l)) -and fMODIFIER = function -| CT_entry_type(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "entry_type" 2 -| CT_format(x1) -> - fSTRING x1 ++ - fNODE "format" 1 -| CT_lefta -> fNODE "lefta" 0 -| CT_nona -> fNODE "nona" 0 -| CT_only_parsing -> fNODE "only_parsing" 0 -| CT_righta -> fNODE "righta" 0 -| CT_set_item_level(x1, x2) -> - fID_NE_LIST x1 ++ - fINT_OR_NEXT x2 ++ - fNODE "set_item_level" 2 -| CT_set_level(x1) -> - fINT x1 ++ - fNODE "set_level" 1 -and fMODIFIER_LIST = function -| CT_modifier_list l -> - (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++ - fNODE "modifier_list" (List.length l) -and fMODULE_BINDER = function -| CT_module_binder(x1, x2) -> - fID_NE_LIST x1 ++ - fMODULE_TYPE x2 ++ - fNODE "module_binder" 2 -and fMODULE_BINDER_LIST = function -| CT_module_binder_list l -> - (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++ - fNODE "module_binder_list" (List.length l) -and fMODULE_EXPR = function -| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x -| CT_module_app(x1, x2) -> - fMODULE_EXPR x1 ++ - fMODULE_EXPR x2 ++ - fNODE "module_app" 2 -and fMODULE_TYPE = function -| CT_coerce_ID_to_MODULE_TYPE x -> fID x -| CT_module_type_with_def(x1, x2, x3) -> - fMODULE_TYPE x1 ++ - fID_LIST x2 ++ - fFORMULA x3 ++ - fNODE "module_type_with_def" 3 -| CT_module_type_with_mod(x1, x2, x3) -> - fMODULE_TYPE x1 ++ - fID_LIST x2 ++ - fID x3 ++ - fNODE "module_type_with_mod" 3 -and fMODULE_TYPE_CHECK = function -| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x -| CT_only_check(x1) -> - fMODULE_TYPE x1 ++ - fNODE "only_check" 1 -and fMODULE_TYPE_OPT = function -| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x -| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x -and fNATURAL_FEATURE = function -| CT_contractible -> fNODE "contractible" 0 -| CT_implicit -> fNODE "implicit" 0 -| CT_nat_transparent -> fNODE "nat_transparent" 0 -and fNONE = function -| CT_none -> fNODE "none" 0 -and fNUM = function -| CT_int_encapsulator x -> fATOM "int_encapsulator" ++ - (f_atom_string x) ++ - str "\n" -and fNUM_TYPE = function -| CT_num_type x -> fATOM "num_type" ++ - (f_atom_string x) ++ - str "\n" -and fOMEGA_FEATURE = function -| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x -| CT_flag_action -> fNODE "flag_action" 0 -| CT_flag_system -> fNODE "flag_system" 0 -| CT_flag_time -> fNODE "flag_time" 0 -and fOMEGA_MODE = function -| CT_set -> fNODE "set" 0 -| CT_switch -> fNODE "switch" 0 -| CT_unset -> fNODE "unset" 0 -and fORIENTATION = function -| CT_lr -> fNODE "lr" 0 -| CT_rl -> fNODE "rl" 0 -and fPATTERN = function -| CT_pattern_occ(x1, x2) -> - fINT_LIST x1 ++ - fFORMULA x2 ++ - fNODE "pattern_occ" 2 -and fPATTERN_NE_LIST = function -| CT_pattern_ne_list(x,l) -> - fPATTERN x ++ - (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++ - fNODE "pattern_ne_list" (1 + (List.length l)) -and fPATTERN_OPT = function -| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x -| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x -and fPREMISE = function -| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x -| CT_eval_result(x1, x2, x3) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fFORMULA x3 ++ - fNODE "eval_result" 3 -| CT_premise(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "premise" 2 -and fPREMISES_LIST = function -| CT_premises_list l -> - (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++ - fNODE "premises_list" (List.length l) -and fPREMISE_PATTERN = function -| CT_premise_pattern(x1, x2) -> - fID_OPT x1 ++ - fCONTEXT_PATTERN x2 ++ - fNODE "premise_pattern" 2 -and fPROOF_SCRIPT = function -| CT_proof_script l -> - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "proof_script" (List.length l) -and fRECCONSTR = function -| CT_defrecconstr(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fFORMULA_OPT x3 ++ - fNODE "defrecconstr" 3 -| CT_defrecconstr_coercion(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fFORMULA_OPT x3 ++ - fNODE "defrecconstr_coercion" 3 -| CT_recconstr(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "recconstr" 2 -| CT_recconstr_coercion(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "recconstr_coercion" 2 -and fRECCONSTR_LIST = function -| CT_recconstr_list l -> - (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++ - fNODE "recconstr_list" (List.length l) -and fREC_TACTIC_FUN = function -| CT_rec_tactic_fun(x1, x2, x3) -> - fID x1 ++ - fID_OPT_NE_LIST x2 ++ - fTACTIC_COM x3 ++ - fNODE "rec_tactic_fun" 3 -and fREC_TACTIC_FUN_LIST = function -| CT_rec_tactic_fun_list(x,l) -> - fREC_TACTIC_FUN x ++ - (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++ - fNODE "rec_tactic_fun_list" (1 + (List.length l)) -and fRED_COM = function -| CT_cbv(x1, x2) -> - fCONVERSION_FLAG_LIST x1 ++ - fCONV_SET x2 ++ - fNODE "cbv" 2 -| CT_fold(x1) -> - fFORMULA_LIST x1 ++ - fNODE "fold" 1 -| CT_hnf -> fNODE "hnf" 0 -| CT_lazy(x1, x2) -> - fCONVERSION_FLAG_LIST x1 ++ - fCONV_SET x2 ++ - fNODE "lazy" 2 -| CT_pattern(x1) -> - fPATTERN_NE_LIST x1 ++ - fNODE "pattern" 1 -| CT_red -> fNODE "red" 0 -| CT_cbvvm -> fNODE "vm_compute" 0 -| CT_simpl(x1) -> - fPATTERN_OPT x1 ++ - fNODE "simpl" 1 -| CT_unfold(x1) -> - fUNFOLD_NE_LIST x1 ++ - fNODE "unfold" 1 -and fRETURN_INFO = function -| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x -| CT_as_and_return(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "as_and_return" 2 -| CT_return(x1) -> - fFORMULA x1 ++ - fNODE "return" 1 -and fRULE = function -| CT_rule(x1, x2) -> - fPREMISES_LIST x1 ++ - fFORMULA x2 ++ - fNODE "rule" 2 -and fRULE_LIST = function -| CT_rule_list l -> - (List.fold_left (++) (mt()) (List.map fRULE l)) ++ - fNODE "rule_list" (List.length l) -and fSCHEME_SPEC = function -| CT_scheme_spec(x1, x2, x3, x4) -> - fID x1 ++ - fDEP x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "scheme_spec" 4 -and fSCHEME_SPEC_LIST = function -| CT_scheme_spec_list(x,l) -> - fSCHEME_SPEC x ++ - (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++ - fNODE "scheme_spec_list" (1 + (List.length l)) -and fSCOMMENT_CONTENT = function -| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x -| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x -and fSCOMMENT_CONTENT_LIST = function -| CT_scomment_content_list l -> - (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++ - fNODE "scomment_content_list" (List.length l) -and fSECTION_BEGIN = function -| CT_section(x1) -> - fID x1 ++ - fNODE "section" 1 -and fSECTION_BODY = function -| CT_section_body l -> - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "section_body" (List.length l) -and fSIGNED_INT = function -| CT_coerce_INT_to_SIGNED_INT x -> fINT x -| CT_minus(x1) -> - fINT x1 ++ - fNODE "minus" 1 -and fSIGNED_INT_LIST = function -| CT_signed_int_list l -> - (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++ - fNODE "signed_int_list" (List.length l) -and fSINGLE_OPTION_VALUE = function -| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x -| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x -and fSORT_TYPE = function -| CT_sortc x -> fATOM "sortc" ++ - (f_atom_string x) ++ - str "\n" -and fSPEC_LIST = function -| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x -| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x -and fSPEC_OPT = function -| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x -| CT_spec -> fNODE "spec" 0 -and fSTAR = function -| CT_star -> fNODE "star" 0 -and fSTAR_OPT = function -| CT_coerce_NONE_to_STAR_OPT x -> fNONE x -| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x -and fSTRING = function -| CT_string x -> fATOM "string" ++ - (f_atom_string x) ++ - str "\n" -and fSTRING_NE_LIST = function -| CT_string_ne_list(x,l) -> - fSTRING x ++ - (List.fold_left (++) (mt()) (List.map fSTRING l)) ++ - fNODE "string_ne_list" (1 + (List.length l)) -and fSTRING_OPT = function -| CT_coerce_NONE_to_STRING_OPT x -> fNONE x -| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x -and fTABLE = function -| CT_coerce_ID_to_TABLE x -> fID x -| CT_table(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "table" 2 -and fTACTIC_ARG = function -| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x -| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x -| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x -| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x -| CT_void -> fNODE "void" 0 -and fTACTIC_ARG_LIST = function -| CT_tactic_arg_list(x,l) -> - fTACTIC_ARG x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++ - fNODE "tactic_arg_list" (1 + (List.length l)) -and fTACTIC_COM = function -| CT_abstract(x1, x2) -> - fID_OPT x1 ++ - fTACTIC_COM x2 ++ - fNODE "abstract" 2 -| CT_absurd(x1) -> - fFORMULA x1 ++ - fNODE "absurd" 1 -| CT_any_constructor(x1) -> - fTACTIC_OPT x1 ++ - fNODE "any_constructor" 1 -| CT_apply(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "apply" 2 -| CT_assert(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "assert" 2 -| CT_assumption -> fNODE "assumption" 0 -| CT_auto(x1) -> - fINT_OPT x1 ++ - fNODE "auto" 1 -| CT_auto_with(x1, x2) -> - fINT_OPT x1 ++ - fID_NE_LIST_OR_STAR x2 ++ - fNODE "auto_with" 2 -| CT_autorewrite(x1, x2) -> - fID_NE_LIST x1 ++ - fTACTIC_OPT x2 ++ - fNODE "autorewrite" 2 -| CT_autotdb(x1) -> - fINT_OPT x1 ++ - fNODE "autotdb" 1 -| CT_case_type(x1) -> - fFORMULA x1 ++ - fNODE "case_type" 1 -| CT_casetac(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "casetac" 2 -| CT_cdhyp(x1) -> - fID x1 ++ - fNODE "cdhyp" 1 -| CT_change(x1, x2) -> - fFORMULA x1 ++ - fCLAUSE x2 ++ - fNODE "change" 2 -| CT_change_local(x1, x2, x3) -> - fPATTERN x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "change_local" 3 -| CT_clear(x1) -> - fID_NE_LIST x1 ++ - fNODE "clear" 1 -| CT_clear_body(x1) -> - fID_NE_LIST x1 ++ - fNODE "clear_body" 1 -| CT_cofixtactic(x1, x2) -> - fID_OPT x1 ++ - fCOFIX_TAC_LIST x2 ++ - fNODE "cofixtactic" 2 -| CT_condrewrite_lr(x1, x2, x3, x4) -> - fTACTIC_COM x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fID_OPT x4 ++ - fNODE "condrewrite_lr" 4 -| CT_condrewrite_rl(x1, x2, x3, x4) -> - fTACTIC_COM x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fID_OPT x4 ++ - fNODE "condrewrite_rl" 4 -| CT_constructor(x1, x2) -> - fINT x1 ++ - fSPEC_LIST x2 ++ - fNODE "constructor" 2 -| CT_contradiction -> fNODE "contradiction" 0 -| CT_contradiction_thm(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "contradiction_thm" 2 -| CT_cut(x1) -> - fFORMULA x1 ++ - fNODE "cut" 1 -| CT_cutrewrite_lr(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "cutrewrite_lr" 2 -| CT_cutrewrite_rl(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "cutrewrite_rl" 2 -| CT_dauto(x1, x2) -> - fINT_OPT x1 ++ - fINT_OPT x2 ++ - fNODE "dauto" 2 -| CT_dconcl -> fNODE "dconcl" 0 -| CT_decompose_list(x1, x2) -> - fID_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "decompose_list" 2 -| CT_decompose_record(x1) -> - fFORMULA x1 ++ - fNODE "decompose_record" 1 -| CT_decompose_sum(x1) -> - fFORMULA x1 ++ - fNODE "decompose_sum" 1 -| CT_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID_OR_INT x2 ++ - fINTRO_PATT_OPT x3 ++ - fFORMULA_OPT x4 ++ - fNODE "depinversion" 4 -| CT_deprewrite_lr(x1) -> - fID x1 ++ - fNODE "deprewrite_lr" 1 -| CT_deprewrite_rl(x1) -> - fID x1 ++ - fNODE "deprewrite_rl" 1 -| CT_destruct(x1) -> - fID_OR_INT x1 ++ - fNODE "destruct" 1 -| CT_dhyp(x1) -> - fID x1 ++ - fNODE "dhyp" 1 -| CT_discriminate_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "discriminate_eq" 1 -| CT_do(x1, x2) -> - fID_OR_INT x1 ++ - fTACTIC_COM x2 ++ - fNODE "do" 2 -| CT_eapply(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "eapply" 2 -| CT_eauto(x1, x2) -> - fID_OR_INT_OPT x1 ++ - fID_OR_INT_OPT x2 ++ - fNODE "eauto" 2 -| CT_eauto_with(x1, x2, x3) -> - fID_OR_INT_OPT x1 ++ - fID_OR_INT_OPT x2 ++ - fID_NE_LIST_OR_STAR x3 ++ - fNODE "eauto_with" 3 -| CT_elim(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fUSING x3 ++ - fNODE "elim" 3 -| CT_elim_type(x1) -> - fFORMULA x1 ++ - fNODE "elim_type" 1 -| CT_exact(x1) -> - fFORMULA x1 ++ - fNODE "exact" 1 -| CT_exact_no_check(x1) -> - fFORMULA x1 ++ - fNODE "exact_no_check" 1 -| CT_vm_cast_no_check(x1) -> - fFORMULA x1 ++ - fNODE "vm_cast_no_check" 1 -| CT_exists(x1) -> - fSPEC_LIST x1 ++ - fNODE "exists" 1 -| CT_fail(x1, x2) -> - fID_OR_INT x1 ++ - fSTRING_OPT x2 ++ - fNODE "fail" 2 -| CT_first(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "first" (1 + (List.length l)) -| CT_firstorder(x1) -> - fTACTIC_OPT x1 ++ - fNODE "firstorder" 1 -| CT_firstorder_using(x1, x2) -> - fTACTIC_OPT x1 ++ - fID_NE_LIST x2 ++ - fNODE "firstorder_using" 2 -| CT_firstorder_with(x1, x2) -> - fTACTIC_OPT x1 ++ - fID_NE_LIST x2 ++ - fNODE "firstorder_with" 2 -| CT_fixtactic(x1, x2, x3) -> - fID_OPT x1 ++ - fINT x2 ++ - fFIX_TAC_LIST x3 ++ - fNODE "fixtactic" 3 -| CT_formula_marker(x1) -> - fFORMULA x1 ++ - fNODE "formula_marker" 1 -| CT_fresh(x1) -> - fSTRING_OPT x1 ++ - fNODE "fresh" 1 -| CT_generalize(x1) -> - fFORMULA_NE_LIST x1 ++ - fNODE "generalize" 1 -| CT_generalize_dependent(x1) -> - fFORMULA x1 ++ - fNODE "generalize_dependent" 1 -| CT_idtac(x1) -> - fSTRING_OPT x1 ++ - fNODE "idtac" 1 -| CT_induction(x1) -> - fID_OR_INT x1 ++ - fNODE "induction" 1 -| CT_info(x1) -> - fTACTIC_COM x1 ++ - fNODE "info" 1 -| CT_injection_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "injection_eq" 1 -| CT_instantiate(x1, x2, x3) -> - fINT x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "instantiate" 3 -| CT_intro(x1) -> - fID_OPT x1 ++ - fNODE "intro" 1 -| CT_intro_after(x1, x2) -> - fID_OPT x1 ++ - fID x2 ++ - fNODE "intro_after" 2 -| CT_intros(x1) -> - fINTRO_PATT_LIST x1 ++ - fNODE "intros" 1 -| CT_intros_until(x1) -> - fID_OR_INT x1 ++ - fNODE "intros_until" 1 -| CT_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID_OR_INT x2 ++ - fINTRO_PATT_OPT x3 ++ - fID_LIST x4 ++ - fNODE "inversion" 4 -| CT_left(x1) -> - fSPEC_LIST x1 ++ - fNODE "left" 1 -| CT_let_ltac(x1, x2) -> - fLET_CLAUSES x1 ++ - fLET_VALUE x2 ++ - fNODE "let_ltac" 2 -| CT_lettac(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "lettac" 3 -| CT_match_context(x,l) -> - fCONTEXT_RULE x ++ - (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ - fNODE "match_context" (1 + (List.length l)) -| CT_match_context_reverse(x,l) -> - fCONTEXT_RULE x ++ - (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ - fNODE "match_context_reverse" (1 + (List.length l)) -| CT_match_tac(x1, x2) -> - fTACTIC_COM x1 ++ - fMATCH_TAC_RULES x2 ++ - fNODE "match_tac" 2 -| CT_move_after(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "move_after" 2 -| CT_new_destruct(x1, x2, x3) -> - (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *) - fUSING x2 ++ - fINTRO_PATT_OPT x3 ++ - fNODE "new_destruct" 3 -| CT_new_induction(x1, x2, x3) -> - (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *) - fUSING x2 ++ - fINTRO_PATT_OPT x3 ++ - fNODE "new_induction" 3 -| CT_omega -> fNODE "omega" 0 -| CT_orelse(x1, x2) -> - fTACTIC_COM x1 ++ - fTACTIC_COM x2 ++ - fNODE "orelse" 2 -| CT_parallel(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "parallel" (1 + (List.length l)) -| CT_pose(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "pose" 2 -| CT_progress(x1) -> - fTACTIC_COM x1 ++ - fNODE "progress" 1 -| CT_prolog(x1, x2) -> - fFORMULA_LIST x1 ++ - fINT x2 ++ - fNODE "prolog" 2 -| CT_rec_tactic_in(x1, x2) -> - fREC_TACTIC_FUN_LIST x1 ++ - fTACTIC_COM x2 ++ - fNODE "rec_tactic_in" 2 -| CT_reduce(x1, x2) -> - fRED_COM x1 ++ - fCLAUSE x2 ++ - fNODE "reduce" 2 -| CT_refine(x1) -> - fFORMULA x1 ++ - fNODE "refine" 1 -| CT_reflexivity -> fNODE "reflexivity" 0 -| CT_rename(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "rename" 2 -| CT_repeat(x1) -> - fTACTIC_COM x1 ++ - fNODE "repeat" 1 -| CT_replace_with(x1, x2,x3,x4) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fTACTIC_OPT x4 ++ - fNODE "replace_with" 4 -| CT_rewrite_lr(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fCLAUSE x3 ++ - fNODE "rewrite_lr" 3 -| CT_rewrite_rl(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fCLAUSE x3 ++ - fNODE "rewrite_rl" 3 -| CT_right(x1) -> - fSPEC_LIST x1 ++ - fNODE "right" 1 -| CT_ring(x1) -> - fFORMULA_LIST x1 ++ - fNODE "ring" 1 -| CT_simple_user_tac(x1, x2) -> - fID x1 ++ - fTACTIC_ARG_LIST x2 ++ - fNODE "simple_user_tac" 2 -| CT_simplify_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "simplify_eq" 1 -| CT_specialize(x1, x2, x3) -> - fINT_OPT x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fNODE "specialize" 3 -| CT_split(x1) -> - fSPEC_LIST x1 ++ - fNODE "split" 1 -| CT_subst(x1) -> - fID_LIST x1 ++ - fNODE "subst" 1 -| CT_superauto(x1, x2, x3, x4) -> - fINT_OPT x1 ++ - fID_LIST x2 ++ - fDESTRUCTING x3 ++ - fUSINGTDB x4 ++ - fNODE "superauto" 4 -| CT_symmetry(x1) -> - fCLAUSE x1 ++ - fNODE "symmetry" 1 -| CT_tac_double(x1, x2) -> - fID_OR_INT x1 ++ - fID_OR_INT x2 ++ - fNODE "tac_double" 2 -| CT_tacsolve(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "tacsolve" (1 + (List.length l)) -| CT_tactic_fun(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fTACTIC_COM x2 ++ - fNODE "tactic_fun" 2 -| CT_then(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "then" (1 + (List.length l)) -| CT_transitivity(x1) -> - fFORMULA x1 ++ - fNODE "transitivity" 1 -| CT_trivial -> fNODE "trivial" 0 -| CT_trivial_with(x1) -> - fID_NE_LIST_OR_STAR x1 ++ - fNODE "trivial_with" 1 -| CT_truecut(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "truecut" 2 -| CT_try(x1) -> - fTACTIC_COM x1 ++ - fNODE "try" 1 -| CT_use(x1) -> - fFORMULA x1 ++ - fNODE "use" 1 -| CT_use_inversion(x1, x2, x3) -> - fID_OR_INT x1 ++ - fFORMULA x2 ++ - fID_LIST x3 ++ - fNODE "use_inversion" 3 -| CT_user_tac(x1, x2) -> - fID x1 ++ - fTARG_LIST x2 ++ - fNODE "user_tac" 2 -and fTACTIC_OPT = function -| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x -| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x -and fTAC_DEF = function -| CT_tac_def(x1, x2) -> - fID x1 ++ - fTACTIC_COM x2 ++ - fNODE "tac_def" 2 -and fTAC_DEF_NE_LIST = function -| CT_tac_def_ne_list(x,l) -> - fTAC_DEF x ++ - (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++ - fNODE "tac_def_ne_list" (1 + (List.length l)) -and fTARG = function -| CT_coerce_BINDING_to_TARG x -> fBINDING x -| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x -| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x -| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x -| CT_coerce_PATTERN_to_TARG x -> fPATTERN x -| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x -| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x -| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x -| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x -| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x -| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x -| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x -| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x -and fTARG_LIST = function -| CT_targ_list l -> - (List.fold_left (++) (mt()) (List.map fTARG l)) ++ - fNODE "targ_list" (List.length l) -and fTERM_CHANGE = function -| CT_check_term(x1) -> - fFORMULA x1 ++ - fNODE "check_term" 1 -| CT_inst_term(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "inst_term" 2 -and fTEXT = function -| CT_coerce_ID_to_TEXT x -> fID x -| CT_text_formula(x1) -> - fFORMULA x1 ++ - fNODE "text_formula" 1 -| CT_text_h l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_h" (List.length l) -| CT_text_hv l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_hv" (List.length l) -| CT_text_op l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_op" (List.length l) -| CT_text_path(x1) -> - fSIGNED_INT_LIST x1 ++ - fNODE "text_path" 1 -| CT_text_v l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_v" (List.length l) -and fTHEOREM_GOAL = function -| CT_goal(x1) -> - fFORMULA x1 ++ - fNODE "goal" 1 -| CT_theorem_goal(x1, x2, x3, x4) -> - fDEFN_OR_THM x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fFORMULA x4 ++ - fNODE "theorem_goal" 4 -and fTHM = function -| CT_thm x -> fATOM "thm" ++ - (f_atom_string x) ++ - str "\n" -and fTHM_OPT = function -| CT_coerce_NONE_to_THM_OPT x -> fNONE x -| CT_coerce_THM_to_THM_OPT x -> fTHM x -and fTYPED_FORMULA = function -| CT_typed_formula(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "typed_formula" 2 -and fUNFOLD = function -| CT_coerce_ID_to_UNFOLD x -> fID x -| CT_unfold_occ(x1, x2) -> - fID x1 ++ - fINT_NE_LIST x2 ++ - fNODE "unfold_occ" 2 -and fUNFOLD_NE_LIST = function -| CT_unfold_ne_list(x,l) -> - fUNFOLD x ++ - (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++ - fNODE "unfold_ne_list" (1 + (List.length l)) -and fUSING = function -| CT_coerce_NONE_to_USING x -> fNONE x -| CT_using(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "using" 2 -and fUSINGTDB = function -| CT_coerce_NONE_to_USINGTDB x -> fNONE x -| CT_usingtdb -> fNODE "usingtdb" 0 -and fVAR = function -| CT_var x -> fATOM "var" ++ - (f_atom_string x) ++ - str "\n" -and fVARG = function -| CT_coerce_AST_to_VARG x -> fAST x -| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x -| CT_coerce_BINDER_to_VARG x -> fBINDER x -| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x -| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x -| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x -| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x -| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x -| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x -| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x -| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x -| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x -| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x -| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x -| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x -and fVARG_LIST = function -| CT_varg_list l -> - (List.fold_left (++) (mt()) (List.map fVARG l)) ++ - fNODE "varg_list" (List.length l) -and fVERBOSE_OPT = function -| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x -| CT_verbose -> fNODE "verbose" 0 -;; diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli deleted file mode 100644 index d7bd8db5..00000000 --- a/contrib/interface/vtp.mli +++ /dev/null @@ -1,16 +0,0 @@ -open Ascent;; -open Pp;; - -val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;; -val fCOMMAND : ct_COMMAND -> std_ppcmds;; -val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;; -val fFORMULA : ct_FORMULA -> std_ppcmds;; -val fID : ct_ID -> std_ppcmds;; -val fSTRING : ct_STRING -> std_ppcmds;; -val fINT : ct_INT -> std_ppcmds;; -val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;; -val fRULE : ct_RULE -> std_ppcmds;; -val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;; -val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;; -val fID_LIST : ct_ID_LIST -> std_ppcmds;; -val fTEXT : ct_TEXT -> std_ppcmds;; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml deleted file mode 100644 index e3cd56a0..00000000 --- a/contrib/interface/xlate.ml +++ /dev/null @@ -1,2267 +0,0 @@ -(** Translation from coq abstract syntax trees to centaur vernac - *) -open String;; -open Char;; -open Util;; -open Names;; -open Ascent;; -open Genarg;; -open Rawterm;; -open Termops;; -open Tacexpr;; -open Vernacexpr;; -open Decl_kinds;; -open Topconstr;; -open Libnames;; -open Goptions;; - - -(* // Verify whether this is dead code, as of coq version 7 *) -(* The following three sentences have been added to cope with a change -of strategy from the Coq team in the way rules construct ast's. The -problem is that now grammar rules will refer to identifiers by giving -their absolute name, using the mutconstruct when needed. Unfortunately, -when you have a mutconstruct structure, you don't have a way to guess -the corresponding identifier without an environment, and the parser -does not have an environment. We add one, only for the constructs -that are always loaded. *) -let type_table = ((Hashtbl.create 17) : - (string, ((string array) array)) Hashtbl.t);; - -Hashtbl.add type_table "Coq.Init.Logic.and" - [|[|"dummy";"conj"|]|];; - -Hashtbl.add type_table "Coq.Init.Datatypes.prod" - [|[|"dummy";"pair"|]|];; - -Hashtbl.add type_table "Coq.Init.Datatypes.nat" - [|[|"";"O"; "S"|]|];; - -Hashtbl.add type_table "Coq.ZArith.fast_integer.Z" -[|[|"";"ZERO";"POS";"NEG"|]|];; - - -Hashtbl.add type_table "Coq.ZArith.fast_integer.positive" -[|[|"";"xI";"xO";"xH"|]|];; - -(*The following two codes are added to cope with the distinction - between ocaml and caml-light syntax while using ctcaml to - manipulate the program *) -let code_plus = code (get "+" 0);; - -let code_minus = code (get "-" 0);; - -let coercion_description_holder = ref (function _ -> None : t -> int option);; - -let coercion_description t = !coercion_description_holder t;; - -let set_coercion_description f = - coercion_description_holder:=f; ();; - -let xlate_error s = print_endline ("xlate_error : "^s);failwith ("Translation error: " ^ s);; - -let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;; - -let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;; - -let ctf_STRING_OPT = function - | None -> ctf_STRING_OPT_NONE - | Some s -> ctf_STRING_OPT_SOME (CT_string s) - -let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;; - -let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;; - -let ctv_ID_OPT_OR_ALL_NONE = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);; - -let ctv_FORMULA_OPT_NONE = - CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);; - -let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; - -let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT - ctv_FORMULA_OPT_NONE;; - -let ctf_ID_OPT_OR_ALL_SOME s = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);; - -let ctv_ID_OPT_OR_ALL_ALL = CT_all;; - -let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;; - -let ct_coerce_FORMULA_to_DEF_BODY x = - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY - (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);; - -let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;; - -let varc x = CT_coerce_ID_to_FORMULA x;; - -let xlate_ident id = CT_ident (string_of_id id) - -let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);; - -let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);; - -let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;; - -let nums_to_int_list l = CT_int_list(nums_to_int_list_aux l);; - -let num_or_var_to_int = function - | ArgArg x -> CT_int x - | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";; - -let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;; - -let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);; - -let nums_or_var_to_int_ne_list n l = - CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);; - -type iTARG = Targ_command of ct_FORMULA - | Targ_intropatt of ct_INTRO_PATT_LIST - | Targ_id_list of ct_ID_LIST - | Targ_spec_list of ct_SPEC_LIST - | Targ_binding_com of ct_FORMULA - | Targ_ident of ct_ID - | Targ_int of ct_INT - | Targ_binding of ct_BINDING - | Targ_pattern of ct_PATTERN - | Targ_unfold of ct_UNFOLD - | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST - | Targ_string of ct_STRING - | Targ_fixtac of ct_FIXTAC - | Targ_cofixtac of ct_COFIXTAC - | Targ_tacexp of ct_TACTIC_COM - | Targ_redexp of ct_RED_COM;; - -type iVARG = Varg_binder of ct_BINDER - | Varg_binderlist of ct_BINDER_LIST - | Varg_bindernelist of ct_BINDER_NE_LIST - | Varg_call of ct_ID * iVARG list - | Varg_constr of ct_FORMULA - | Varg_sorttype of ct_SORT_TYPE - | Varg_constrlist of ct_FORMULA list - | Varg_ident of ct_ID - | Varg_int of ct_INT - | Varg_intlist of ct_INT_LIST - | Varg_none - | Varg_string of ct_STRING - | Varg_tactic of ct_TACTIC_COM - | Varg_ast of ct_AST - | Varg_astlist of ct_AST_LIST - | Varg_tactic_arg of iTARG - | Varg_varglist of iVARG list;; - - -let coerce_iVARG_to_FORMULA = - function - | Varg_constr x -> x - | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x - | Varg_ident id -> CT_coerce_ID_to_FORMULA id - | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";; - -let coerce_iVARG_to_ID = - function Varg_ident id -> id - | _ -> xlate_error "coerce_iVARG_to_ID";; - -let coerce_VARG_to_ID = - function - | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) -> - x - | _ -> xlate_error "coerce_VARG_to_ID";; - -let xlate_ident_opt = - function - | None -> ctv_ID_OPT_NONE - | Some id -> ctf_ID_OPT_SOME (xlate_ident id) - -let xlate_id_to_id_or_int_opt s = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));; - -let xlate_int_to_id_or_int_opt n = - CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_ID_OR_INT (CT_int n));; - -let none_in_id_or_int_opt = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_NONE_to_ID_OPT(CT_none));; - -let xlate_int_opt = function - | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n) - | None -> CT_coerce_NONE_to_INT_OPT CT_none - -let xlate_int_or_var_opt_to_int_opt = function - | Some (ArgArg n) -> CT_coerce_INT_to_INT_OPT (CT_int n) - | Some (ArgVar _) -> xlate_error "int_or_var: TODO" - | None -> CT_coerce_NONE_to_INT_OPT CT_none - -let apply_or_by_notation f = function - | AN x -> f x - | ByNotation _ -> xlate_error "TODO: ByNotation" - -let tac_qualid_to_ct_ID ref = - CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) - -let loc_qualid_to_ct_ID ref = - CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) - -let int_of_meta n = int_of_string (string_of_id n) -let is_int_meta n = try let _ = int_of_meta n in true with _ -> false - -let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l) - -let reference_to_ct_ID = function - | Ident (_,id) -> CT_ident (Names.string_of_id id) - | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) - -let xlate_class = function - | FunClass -> CT_ident "FUNCLASS" - | SortClass -> CT_ident "SORTCLASS" - | RefClass qid -> loc_qualid_to_ct_ID qid - -let id_to_pattern_var ctid = - match ctid with - | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" - | CT_ident "_" -> - CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) - | CT_ident id_string -> - CT_coerce_ID_OPT_to_MATCH_PATTERN - (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) - | CT_metac _ -> assert false;; - -exception Not_natural;; - -let xlate_sort = - function - | RProp Term.Pos -> CT_sortc "Set" - | RProp Term.Null -> CT_sortc "Prop" - | RType None -> CT_sortc "Type" - | RType (Some u) -> xlate_error "xlate_sort";; - - -let xlate_qualid a = - let d,i = Libnames.repr_qualid a in - let l = Names.repr_dirpath d in - List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; - -(* // The next two functions should be modified to make direct reference - to a notation operator *) -let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; - -let xlate_reference = function - Ident(_,i) -> CT_ident (string_of_id i) - | Qualid(_, q) -> CT_ident (xlate_qualid q);; -let rec xlate_match_pattern = - function - | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference s) - | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_") - | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f) - | CPatCstr (_, f1 , (arg1 :: args)) -> - CT_pattern_app - (id_to_pattern_var (xlate_reference f1), - CT_match_pattern_ne_list - (xlate_match_pattern arg1, - List.map xlate_match_pattern args)) - | CPatAlias (_, pattern, id) -> - CT_pattern_as - (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) - | CPatOr (_,l) -> xlate_error "CPatOr: TODO" - | CPatDelimiters(_, key, p) -> - CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) - | CPatPrim (_,Numeral n) -> - CT_coerce_NUM_to_MATCH_PATTERN - (CT_int_encapsulator(Bigint.to_string n)) - | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, (l,[])) -> - CT_pattern_notation(CT_string s, - CT_match_pattern_list(List.map xlate_match_pattern l)) - | CPatNotation(_, s, (l,_)) -> - xlate_error "CPatNotation (recursive notation): TODO" -;; - - -let xlate_id_opt_aux = function - Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id)) - | Anonymous -> ctv_ID_OPT_NONE;; - -let xlate_id_opt (_, v) = xlate_id_opt_aux v;; - -let xlate_id_opt_ne_list = function - [] -> assert false - | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);; - - -let rec last = function - [] -> assert false - | [a] -> a - | a::tl -> last tl;; - -let rec decompose_last = function - [] -> assert false - | [a] -> [], a - | a::tl -> let rl, b = decompose_last tl in (a::rl), b;; - -let make_fix_struct (n,bl) = - let names = names_of_local_assums bl in - let nn = List.length names in - if nn = 1 || n = None then ctv_ID_OPT_NONE - else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));; - -let rec xlate_binder = function - (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) -and xlate_return_info = function -| (Some Anonymous, None) | (None, None) -> - CT_coerce_NONE_to_RETURN_INFO CT_none -| (None, Some t) -> CT_return(xlate_formula t) -| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t) -| (Some _, None) -> assert false -and xlate_formula_opt = - function - | None -> ctv_FORMULA_OPT_NONE - | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e) - -and xlate_binder_l = function - LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) - | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, - xlate_formula v)) -and - xlate_match_pattern_ne_list = function - [] -> assert false - | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, - List.map xlate_match_pattern l) -and translate_one_equation = function - (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) - | _ -> xlate_error "TODO: disjunctive multiple patterns" -and - xlate_binder_ne_list = function - [] -> assert false - | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) -and - xlate_binder_list = function - l -> CT_binder_list( List.map xlate_binder_l l) -and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function - - CRef r -> varc (xlate_reference r) - | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) - | CProdN(_,ll,b) as whole_term -> - let rec gather_binders = function - CProdN(_, ll, b) -> - ll@(gather_binders b) - | _ -> [] in - let rec fetch_ultimate_body = function - CProdN(_, _, b) -> fetch_ultimate_body b - | a -> a in - CT_prodc(xlate_binder_ne_list (gather_binders whole_term), - xlate_formula (fetch_ultimate_body b)) - | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) - | CLetIn(_, v, a, b) -> - CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) - | CAppExpl(_, (Some n, r), l) -> - let l', last = decompose_last l in - CT_proj(xlate_formula last, - CT_formula_ne_list - (CT_bang(varc (xlate_reference r)), - List.map xlate_formula l')) - | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) - | CAppExpl(_, (None, r), l) -> - CT_appc(CT_bang(varc (xlate_reference r)), - xlate_formula_ne_list l) - | CApp(_, (Some n,f), l) -> - let l', last = decompose_last l in - CT_proj(xlate_formula_expl last, - CT_formula_ne_list - (xlate_formula f, List.map xlate_formula_expl l')) - | CApp(_, (_,f), l) -> - CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) - | CRecord (_,_,_) -> xlate_error "CRecord: TODO" - | CCases (_, _, _, [], _) -> assert false - | CCases (_, _, ret_type, tm::tml, eqns)-> - CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, - List.map xlate_matched_formula tml), - xlate_formula_opt ret_type, - CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns)) - | CLetTuple (_,a::l, ret_info, c, b) -> - CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a, - List.map xlate_id_opt_aux l), - xlate_return_info ret_info, - xlate_formula c, - xlate_formula b) - | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" - | CIf (_,c, ret_info, b1, b2) -> - CT_if - (xlate_formula c, xlate_return_info ret_info, - xlate_formula b1, xlate_formula b2) - - | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) - | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) - | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" - | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" - | CPrim (_, Numeral i) -> - CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) - | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" - | CHole _ -> CT_existvarc -(* I assume CDynamic has been inserted to make free form extension of - the language possible, but this would go agains the logic of pcoq anyway. *) - | CDynamic (_, _) -> assert false - | CDelimiters (_, key, num) -> - CT_num_encapsulator(CT_num_type key , xlate_formula num) - | CCast (_, e, CastConv (_, t)) -> - CT_coerce_TYPED_FORMULA_to_FORMULA - (CT_typed_formula(xlate_formula e, xlate_formula t)) - | CCast (_, e, CastCoerce) -> assert false - | CPatVar (_, (_,i)) when is_int_meta i -> - CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i))) - | CPatVar (_, (false, s)) -> - CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s)) - | CPatVar (_, (true, s)) -> - xlate_error "Second order variable not supported" - | CEvar _ -> xlate_error "CEvar not supported" - | CCoFix (_, (_, id), lm::lmi) -> - let strip_mutcorec ((_, fid), bl,arf, ardef) = - CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, - xlate_formula arf, xlate_formula ardef) in - CT_cofixc(xlate_ident id, - (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) - | CFix (_, (_, id), lm::lmi) -> - let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) = - let struct_arg = make_fix_struct (n, bl) in - let arf = xlate_formula arf in - let ardef = xlate_formula ardef in - match xlate_binder_list bl with - | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), - struct_arg, arf, ardef) - | _ -> xlate_error "mutual recursive" in - CT_fixc (xlate_ident id, - CT_fix_binder_list - (CT_coerce_FIX_REC_to_FIX_BINDER - (strip_mutrec lm), List.map - (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) - lmi)) - | CCoFix _ -> assert false - | CFix _ -> assert false -and xlate_matched_formula = function - (f, (Some x, Some y)) -> - CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y) - | (f, (None, Some y)) -> - CT_formula_in(xlate_formula f, xlate_formula y) - | (f, (Some x, None)) -> - CT_formula_as(xlate_formula f, xlate_id_opt_aux x) - | (f, (None, None)) -> - CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) -and xlate_formula_expl = function - (a, None) -> xlate_formula a - | (a, Some (_,ExplByPos (i, _))) -> - xlate_error "explicitation of implicit by rank not supported" - | (a, Some (_,ExplByName i)) -> - CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) -and xlate_formula_expl_ne_list = function - [] -> assert false - | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) -and xlate_formula_ne_list = function - [] -> assert false - | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; - -let (xlate_ident_or_metaid: - Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function - AI (_, x) -> xlate_ident x - | MetaId(_, x) -> CT_metaid x;; - -let nums_of_occs (b,nums) = - if b then nums - else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums - -let xlate_hyp = function - | AI (_,id) -> xlate_ident id - | MetaId _ -> xlate_error "MetaId should occur only in quotations" - -let xlate_hyp_location = - function - | (occs, AI (_,id)), InHypTypeOnly -> - CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) - | (occs, AI (_,id)), InHypValueOnly -> - CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) - | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr -> - CT_coerce_UNFOLD_to_HYP_LOCATION - (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | ((_,a::l as occs), AI (_,id)), InHyp -> - let nums = nums_of_occs occs in - let a = List.hd nums and l = List.tl nums in - CT_coerce_UNFOLD_to_HYP_LOCATION - (CT_unfold_occ (xlate_ident id, - CT_int_ne_list(num_or_var_to_int a, - nums_or_var_to_int_list_aux l))) - | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *) - | (_, MetaId _),_ -> - xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" - - - -let xlate_clause cls = - let hyps_info = - match cls.onhyps with - None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star - | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in - CT_clause - (hyps_info, - if cls.concl_occs <> no_occurrences_expr then - CT_coerce_STAR_to_STAR_OPT CT_star - else - CT_coerce_NONE_to_STAR_OPT CT_none) - -(** Tactics - *) -let strip_targ_spec_list = - function - | Targ_spec_list x -> x - | _ -> xlate_error "strip tactic: non binding-list argument";; - -let strip_targ_binding = - function - | Targ_binding x -> x - | _ -> xlate_error "strip tactic: non-binding argument";; - -let strip_targ_command = - function - | Targ_command x -> x - | Targ_binding_com x -> x - | _ -> xlate_error "strip tactic: non-command argument";; - -let strip_targ_ident = - function - | Targ_ident x -> x - | _ -> xlate_error "strip tactic: non-ident argument";; - -let strip_targ_int = - function - | Targ_int x -> x - | _ -> xlate_error "strip tactic: non-int argument";; - -let strip_targ_pattern = - function - | Targ_pattern x -> x - | _ -> xlate_error "strip tactic: non-pattern argument";; - -let strip_targ_unfold = - function - | Targ_unfold x -> x - | _ -> xlate_error "strip tactic: non-unfold argument";; - -let strip_targ_fixtac = - function - | Targ_fixtac x -> x - | _ -> xlate_error "strip tactic: non-fixtac argument";; - -let strip_targ_cofixtac = - function - | Targ_cofixtac x -> x - | _ -> xlate_error "strip tactic: non-cofixtac argument";; - -(*Need to transform formula to id for "Prolog" tactic problem *) -let make_ID_from_FORMULA = - function - | CT_coerce_ID_to_FORMULA id -> id - | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";; - -let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);; - -let xlate_quantified_hypothesis = function - | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) - | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) - -let xlate_quantified_hypothesis_opt = function - | None -> - CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE - | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n - | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; - -let xlate_id_or_int = function - ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) - | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; - -let xlate_explicit_binding (loc,h,c) = - CT_binding (xlate_quantified_hypothesis h, xlate_formula c) - -let xlate_bindings = function - | ImplicitBindings l -> - CT_coerce_FORMULA_LIST_to_SPEC_LIST - (CT_formula_list (List.map xlate_formula l)) - | ExplicitBindings l -> - CT_coerce_BINDING_LIST_to_SPEC_LIST - (CT_binding_list (List.map xlate_explicit_binding l)) - | NoBindings -> - CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list []) - -let strip_targ_spec_list = - function - | Targ_spec_list x -> x - | _ -> xlate_error "strip_tar_spec_list";; - -let strip_targ_intropatt = - function - | Targ_intropatt x -> x - | _ -> xlate_error "strip_targ_intropatt";; - -let get_flag r = - let conv_flags, red_ids = - let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in - if r.rDelta then - [CT_delta], CT_unfbut csts - else - (if r.rConst = [] - then (* probably useless: just for compatibility *) [] - else [CT_delta]), - CT_unf csts in - let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in - let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in - let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in - (* Rem: EVAR flag obsolète *) - conv_flags, red_ids - -let rec xlate_intro_pattern (loc,pat) = match pat with - | IntroOrAndPattern [] -> assert false - | IntroOrAndPattern (fp::ll) -> - CT_disj_pattern - (CT_intro_patt_list(List.map xlate_intro_pattern fp), - List.map - (fun l -> - CT_intro_patt_list(List.map xlate_intro_pattern l)) - ll) - | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) - | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) - | IntroAnonymous -> xlate_error "TODO: IntroAnonymous" - | IntroFresh _ -> xlate_error "TODO: IntroFresh" - | IntroRewrite _ -> xlate_error "TODO: IntroRewrite" - -let compute_INV_TYPE = function - FullInversionClear -> CT_inv_clear - | SimpleInversion -> CT_inv_simple - | FullInversion -> CT_inv_regular - -let is_tactic_special_case = function - "AutoRewrite" -> true - | _ -> false;; - -let xlate_context_pattern = function - | Term v -> - CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) - | Subterm (b, idopt, v) -> (* TODO: application pattern *) - CT_context(xlate_ident_opt idopt, xlate_formula v) - - -let xlate_match_context_hyps = function - | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b) - | Def (na,b,t) -> xlate_error "TODO: Let hyps" - (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *) - -let xlate_arg_to_id_opt = function - Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) - | None -> ctv_ID_OPT_NONE;; - -let xlate_largs_to_id_opt largs = - match List.map xlate_arg_to_id_opt largs with - fst::rest -> fst, rest - | _ -> assert false;; - -let xlate_int_or_constr = function - ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) - | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings" - | ElimOnIdent(_,i) -> - CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) - | ElimOnAnonHyp i -> - CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT(CT_int i));; - -let xlate_using = function - None -> CT_coerce_NONE_to_USING(CT_none) - | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; - -let xlate_one_unfold_block = function - ((true,[]),qid) -> - CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid) - | (((_,_::_) as occs), qid) -> - let l = nums_of_occs occs in - CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, - nums_or_var_to_int_ne_list (List.hd l) (List.tl l)) - | ((false,[]), qid) -> xlate_error "Unused" -;; - -let xlate_with_names = function - None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE - | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) - -let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level - -let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = - function - | TacVoid -> - CT_void - | Tacexp t -> - CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) - | Integer n -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n))) - | Reference r -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r))) - | TacDynamic _ -> - failwith "Dynamics not treated in xlate_ast" - | ConstrMayEval (ConstrTerm c) -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c)) - | ConstrMayEval(ConstrEval(r,c)) -> - CT_coerce_EVAL_CMD_to_TACTIC_ARG - (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, - xlate_formula c)) - | ConstrMayEval(ConstrTypeOf(c)) -> - CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) - | MetaIdArg _ -> - xlate_error "MetaIdArg should only be used in quotations" - | t -> - CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t) - -and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = - function - (* Moved from xlate_tactic *) - | TacCall (_, r, a::l) -> - CT_simple_user_tac - (reference_to_ct_ID r, - CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l)) - | Reference (Ident (_,s)) -> ident_tac s - | ConstrMayEval(ConstrTerm a) -> - CT_formula_marker(xlate_formula a) - | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None) - | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s)) - | TacFreshId _ -> xlate_error "TODO: fresh with many args" - | t -> xlate_error "TODO LATER: result other than tactic or constr" - -and xlate_red_tactic = - function - | Red true -> xlate_error "" - | Red false -> CT_red - | CbvVm -> CT_cbvvm - | Hnf -> CT_hnf - | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE - | Simpl (Some (occs,c)) -> - let l = nums_of_occs occs in - CT_simpl - (CT_coerce_PATTERN_to_PATTERN_OPT - (CT_pattern_occ - (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c))) - | Cbv flag_list -> - let conv_flags, red_ids = get_flag flag_list in - CT_cbv (CT_conversion_flag_list conv_flags, red_ids) - | Lazy flag_list -> - let conv_flags, red_ids = get_flag flag_list in - CT_lazy (CT_conversion_flag_list conv_flags, red_ids) - | Unfold unf_list -> - let ct_unf_list = List.map xlate_one_unfold_block unf_list in - (match ct_unf_list with - | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) - | [] -> error "there should be at least one thing to unfold") - | Fold formula_list -> - CT_fold(CT_formula_list(List.map xlate_formula formula_list)) - | Pattern l -> - let pat_list = List.map (fun (occs,c) -> - CT_pattern_occ - (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)), - xlate_formula c)) l in - (match pat_list with - | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) - | [] -> error "Expecting at least one pattern in a Pattern command") - | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" - -and xlate_local_rec_tac = function - (* TODO LATER: local recursive tactics and global ones should be handled in - the same manner *) - | ((_,x),Tacexp (TacFun (argl,tac))) -> - let fst, rest = xlate_largs_to_id_opt argl in - CT_rec_tactic_fun(xlate_ident x, - CT_id_opt_ne_list(fst, rest), - xlate_tactic tac) - | _ -> xlate_error "TODO: more general argument of 'let rec in'" - -and xlate_tactic = - function - | TacFun (largs, t) -> - let fst, rest = xlate_largs_to_id_opt largs in - CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) - | TacThen (t1,[||],t2,[||]) -> - (match xlate_tactic t1 with - CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) - | t -> CT_then (t,[xlate_tactic t2])) - | TacThen _ -> xlate_error "TacThen generalization TODO" - | TacThens(t1,[]) -> assert false - | TacThens(t1,t::l) -> - let ct = xlate_tactic t in - let cl = List.map xlate_tactic l in - (match xlate_tactic t1 with - CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)]) - | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)])) - | TacFirst([]) -> assert false - | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l) - | TacSolve([]) -> assert false - | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l) - | TacComplete _ -> xlate_error "TODO: tactical complete" - | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) - | TacTry t -> CT_try (xlate_tactic t) - | TacRepeat t -> CT_repeat(xlate_tactic t) - | TacAbstract(t,id_opt) -> - CT_abstract((match id_opt with - None -> ctv_ID_OPT_NONE - | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), - xlate_tactic t) - | TacProgress t -> CT_progress(xlate_tactic t) - | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2) - | TacMatch (true,_,_) -> failwith "TODO: lazy match" - | TacMatch (false, exp, rules) -> - CT_match_tac(xlate_tactic exp, - match List.map - (function - | Pat ([],p,tac) -> - CT_match_tac_rule(xlate_context_pattern p, - mk_let_value tac) - | Pat (_,p,tac) -> xlate_error"No hyps in pure Match" - | All tac -> - CT_match_tac_rule - (CT_coerce_FORMULA_to_CONTEXT_PATTERN - CT_existvarc, - mk_let_value tac)) rules with - | [] -> assert false - | fst::others -> - CT_match_tac_rules(fst, others)) - | TacMatchGoal (_,_,[]) | TacMatchGoal (true,_,_) -> failwith "" - | TacMatchGoal (false,false,rule1::rules) -> - CT_match_context(xlate_context_rule rule1, - List.map xlate_context_rule rules) - | TacMatchGoal (false,true,rule1::rules) -> - CT_match_context_reverse(xlate_context_rule rule1, - List.map xlate_context_rule rules) - | TacLetIn (false, l, t) -> - let cvt_clause = - function - ((_,s),ConstrMayEval v) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_DEF_BODY_to_LET_VALUE - (formula_to_def_body v)) - | ((_,s),Tacexp t) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_tactic t)) - | ((_,s),t) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_call_or_tacarg t)) in - let cl_l = List.map cvt_clause l in - (match cl_l with - | [] -> assert false - | fst::others -> - CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) - | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition" - | TacLetIn(true, f1::l, t) -> - let tl = CT_rec_tactic_fun_list - (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in - CT_rec_tactic_in(tl, xlate_tactic t) - | TacAtom (_, t) -> xlate_tac t - | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) - | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count, - ctf_STRING_OPT_SOME (CT_string s)) - | TacFail (count, _) -> xlate_error "TODO: generic fail message" - | TacId [] -> CT_idtac ctf_STRING_OPT_NONE - | TacId [MsgString s] -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s)) - | TacId _ -> xlate_error "TODO: generic idtac message" - | TacInfo t -> CT_info(xlate_tactic t) - | TacArg a -> xlate_call_or_tacarg a - -and xlate_tac = - function - | TacExtend (_, "firstorder", tac_opt::l) -> - let t1 = - match - out_gen (wit_opt rawwit_main_tactic) tac_opt - with - | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in - (match l with - [] -> CT_firstorder t1 - | [l1] -> - (match genarg_tag l1 with - List1ArgType PreIdentArgType -> - let l2 = List.map - (fun x -> CT_ident x) - (out_gen (wit_list1 rawwit_pre_ident) l1) in - let fst,l3 = - match l2 with fst::l3 -> fst,l3 | [] -> assert false in - CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) - | List1ArgType RefArgType -> - let l2 = List.map reference_to_ct_ID - (out_gen (wit_list1 rawwit_ref) l1) in - let fst,l3 = - match l2 with fst::l3 -> fst, l3 | [] -> assert false in - CT_firstorder_with(t1, CT_id_ne_list(fst, l3)) - | _ -> assert false) - | _ -> assert false) - | TacExtend (_, "refine", [c]) -> - CT_refine (xlate_formula (snd (out_gen rawwit_casted_open_constr c))) - | TacExtend (_,"absurd",[c]) -> - CT_absurd (xlate_formula (out_gen rawwit_constr c)) - | TacExtend (_,"contradiction",[opt_c]) -> - (match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with - None -> CT_contradiction - | Some(c, b) -> - let c1 = xlate_formula c in - let bindings = xlate_bindings b in - CT_contradiction_thm(c1, bindings)) - | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) - | TacChange (Some(l,c), f, b) -> - (* TODO LATER: combine with other constructions of pattern_occ *) - let l = nums_of_occs l in - CT_change_local( - CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), - xlate_formula c), - xlate_formula f, - xlate_clause b) - | TacExtend (_,"contradiction",[]) -> CT_contradiction - | TacDoubleInduction (n1, n2) -> - CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2) - | TacExtend (_,"discriminate", []) -> - CT_discriminate_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE) - | TacExtend (_,"discriminate", [id]) -> - CT_discriminate_eq - (xlate_quantified_hypothesis_opt - (Some (out_gen rawwit_quant_hyp id))) - | TacExtend (_,"simplify_eq", []) -> - CT_simplify_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_NONE_to_ID_OPT CT_none)) - | TacExtend (_,"simplify_eq", [id]) -> - let id1 = out_gen rawwit_quant_hyp id in - let id2 = CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT - (xlate_quantified_hypothesis id1) in - CT_simplify_eq id2 - | TacExtend (_,"injection", []) -> - CT_injection_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE) - | TacExtend (_,"injection", [id]) -> - CT_injection_eq - (xlate_quantified_hypothesis_opt - (Some (out_gen rawwit_quant_hyp id))) - | TacExtend (_,"injection_as", [idopt;ipat]) -> - xlate_error "TODO: injection as" - | TacFix (idopt, n) -> - CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) - | TacMutualFix (false, id, n, fixtac_list) -> - let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in - CT_fixtactic - (ctf_ID_OPT_SOME (xlate_ident id), CT_int n, - CT_fix_tac_list (List.map f fixtac_list)) - | TacMutualFix (true, id, n, fixtac_list) -> - xlate_error "TODO: non user-visible fix" - | TacCofix idopt -> - CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list []) - | TacMutualCofix (false, id, cofixtac_list) -> - let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in - CT_cofixtactic - (CT_coerce_ID_to_ID_OPT (xlate_ident id), - CT_cofix_tac_list (List.map f cofixtac_list)) - | TacMutualCofix (true, id, cofixtac_list) -> - xlate_error "TODO: non user-visible cofix" - | TacIntrosUntil (NamedHyp id) -> - CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) - | TacIntrosUntil (AnonHyp n) -> - CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) - | TacIntroMove (Some id1, MoveAfter id2) -> - CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2) - | TacIntroMove (None, MoveAfter id2) -> - CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_hyp id2) - | TacMove (true, id1, MoveAfter id2) -> - CT_move_after(xlate_hyp id1, xlate_hyp id2) - | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal" - | TacMove _ -> xlate_error "TODO: move before, at top, at bottom" - | TacIntroPattern patt_list -> - CT_intros - (CT_intro_patt_list (List.map xlate_intro_pattern patt_list)) - | TacIntroMove (Some id, MoveToEnd true) -> - CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) - | TacIntroMove (None, MoveToEnd true) -> - CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) - | TacIntroMove _ -> xlate_error "TODO" - | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl) - | TacRight (false,bindl) -> CT_right (xlate_bindings bindl) - | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl) - | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl) - | TacSplit _ | TacRight _ | TacLeft _ -> - xlate_error "TODO: esplit, eright, etc" - | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) -> - let c1 = xlate_formula (out_gen rawwit_constr c1) in - let c2 = xlate_formula (out_gen rawwit_constr c2) in - let cl = - (* J.F. : 18/08/2006 - Hack to coerce the "clause" argument of replace to a real clause - To be remove if we can reuse the clause grammar entrie defined in g_tactic - *) - let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in - let cl_as_xlate_arg = - {cl_as_clause with - Tacexpr.onhyps = - Option.map - (fun l -> - List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l - ) - cl_as_clause.Tacexpr.onhyps - } - in - cl_as_xlate_arg - in - let cl = xlate_clause cl in - let tac_opt = - match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with - | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | Some tac -> - let tac = xlate_tactic tac in - CT_coerce_TACTIC_COM_to_TACTIC_OPT tac - in - CT_replace_with (c1, c2,cl,tac_opt) - | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> - let cl = xlate_clause cl - and c = xlate_formula (fst cbindl) - and bindl = xlate_bindings (snd cbindl) in - if b then CT_rewrite_lr (c, bindl, cl) - else CT_rewrite_rl (c, bindl, cl) - | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by" - | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once" - | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite" - | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) -> - let t = out_gen rawwit_main_tactic t in - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) - else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) - | TacExtend (_,"conditional_rewrite", [t; b; cbindl; id]) -> - let t = out_gen rawwit_main_tactic t in - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in - if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id) - else CT_condrewrite_rl (xlate_tactic t, c, bindl, id) - | TacExtend (_,"dependent_rewrite", [b; c]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - (match c with - | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> - if b then CT_deprewrite_lr id else CT_deprewrite_rl id - | _ -> xlate_error "dependent rewrite on term: not supported") - | TacExtend (_,"dependent_rewrite", [b; c; id]) -> - xlate_error "dependent rewrite on terms in hypothesis: not supported" - | TacExtend (_,"cut_rewrite", [b; c]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) - else CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) - | TacExtend (_,"cut_rewrite", [b; c; id]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - let id = xlate_ident (snd (out_gen rawwit_var id)) in - if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) - else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) - | TacExtend(_, "subst", [l]) -> - CT_subst - (CT_id_list - (List.map (fun x -> CT_ident (string_of_id x)) - (out_gen (wit_list1 rawwit_ident) l))) - | TacReflexivity -> CT_reflexivity - | TacSymmetry cls -> CT_symmetry(xlate_clause cls) - | TacTransitivity c -> CT_transitivity (xlate_formula c) - | TacAssumption -> CT_assumption - | TacExact c -> CT_exact (xlate_formula c) - | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c) - | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c) - | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) - | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) - | TacDestructConcl -> CT_dconcl - | TacSuperAuto (nopt,l,a3,a4) -> - CT_superauto( - xlate_int_opt nopt, - xlate_qualid_list l, - (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none), - (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none)) - | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt) - | TacAuto (nopt, [], Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt) - | TacAuto (nopt, [], None) -> - CT_auto_with (xlate_int_or_var_opt_to_int_opt nopt, - CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | TacAuto (nopt, [], Some (id1::idl)) -> - CT_auto_with(xlate_int_or_var_opt_to_int_opt nopt, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( - CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl))) - | TacAuto (nopt, _::_, _) -> - xlate_error "TODO: auto using" - |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) -> - let (id_list:ct_ID list) = - List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in - let fst, (id_list1: ct_ID list) = - match id_list with [] -> assert false | a::tl -> a,tl in - let t1 = - match t with - [t0] -> - CT_coerce_TACTIC_COM_to_TACTIC_OPT - (xlate_tactic(out_gen rawwit_main_tactic t0)) - | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | _ -> assert false in - CT_autorewrite (CT_id_ne_list(fst, id_list1), t1) - | TacExtend (_,"eauto", [nopt; popt; lems; idl]) -> - let first_n = - match out_gen (wit_opt rawwit_int_or_var) nopt with - | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n - | None -> none_in_id_or_int_opt in - let second_n = - match out_gen (wit_opt rawwit_int_or_var) popt with - | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n - | None -> none_in_id_or_int_opt in - let _lems = - match out_gen Eauto.rawwit_auto_using lems with - | [] -> [] - | _ -> xlate_error "TODO: eauto using" in - let idl = out_gen Eauto.rawwit_hintbases idl in - (match idl with - None -> CT_eauto_with(first_n, - second_n, - CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | Some [] -> CT_eauto(first_n, second_n) - | Some (a::l) -> - CT_eauto_with(first_n, second_n, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR - (CT_id_ne_list - (CT_ident a, - List.map (fun x -> CT_ident x) l)))) - | TacExtend (_,"prolog", [cl; n]) -> - let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in - (match out_gen rawwit_int_or_var n with - | ArgVar _ -> xlate_error "" - | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) - (* eapply now represented by TacApply (true,cbindl) - | TacExtend (_,"eapply", [cbindl]) -> -*) - | TacTrivial ([],Some []) -> CT_trivial - | TacTrivial ([],None) -> - CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | TacTrivial ([],Some (id1::idl)) -> - CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( - (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl)))) - | TacTrivial (_::_,_) -> - xlate_error "TODO: trivial using" - | TacReduce (red, l) -> - CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (true,false,[c,bindl],None) -> - CT_apply (xlate_formula c, xlate_bindings bindl) - | TacApply (true,true,[c,bindl],None) -> - CT_eapply (xlate_formula c, xlate_bindings bindl) - | TacApply (_,_,_,_) -> - xlate_error "TODO: simple (e)apply and iterated apply and apply in" - | TacConstructor (false,n_or_meta, bindl) -> - let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" - in CT_constructor (CT_int n, xlate_bindings bindl) - | TacConstructor _ -> xlate_error "TODO: econstructor" - | TacSpecialize (nopt, (c,sl)) -> - CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl) - | TacGeneralize [] -> xlate_error "" - | TacGeneralize ((((true,[]),first),Anonymous) :: cl) - when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr - & na = Anonymous) cl -> - CT_generalize - (CT_formula_ne_list (xlate_formula first, - List.map (fun ((_,c),_) -> xlate_formula c) cl)) - | TacGeneralize _ -> xlate_error "TODO: Generalize at and as" - | TacGeneralizeDep c -> - CT_generalize_dependent (xlate_formula c) - | TacElimType c -> CT_elim_type (xlate_formula c) - | TacCaseType c -> CT_case_type (xlate_formula c) - | TacElim (false,(c1,sl), u) -> - CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u) - | TacCase (false,(c1,sl)) -> - CT_casetac (xlate_formula c1, xlate_bindings sl) - | TacElim (true,_,_) | TacCase (true,_) - | TacInductionDestruct (_,true,_) -> - xlate_error "TODO: eelim, ecase, edestruct, einduction" - | TacSimpleInductionDestruct (true,h) -> - CT_induction (xlate_quantified_hypothesis h) - | TacSimpleInductionDestruct (false,h) -> - CT_destruct (xlate_quantified_hypothesis h) - | TacCut c -> CT_cut (xlate_formula c) - | TacLApply c -> CT_use (xlate_formula c) - | TacDecompose ([],c) -> - xlate_error "Decompose : empty list of identifiers?" - | TacDecompose (id::l,c) -> - let id' = apply_or_by_notation tac_qualid_to_ct_ID id in - let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in - CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c) - | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c) - | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c) - | TacClear (false,[]) -> - xlate_error "Clear expects a non empty list of identifiers" - | TacClear (false,id::idl) -> - let idl' = List.map xlate_hyp idl in - CT_clear (CT_id_ne_list (xlate_hyp id, idl')) - | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'" - | TacRevert _ -> xlate_error "TODO: revert" - | (*For translating tactics/Inv.v *) - TacInversion (NonDepInversion (k,idl,l),quant_hyp) -> - CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp, - xlate_with_names l, - CT_id_list (List.map xlate_hyp idl)) - | TacInversion (DepInversion (k,copt,l),quant_hyp) -> - let id = xlate_quantified_hypothesis quant_hyp in - CT_depinversion (compute_INV_TYPE k, id, - xlate_with_names l, xlate_formula_opt copt) - | TacInversion (InversionUsing (c,idlist), id) -> - let id = xlate_quantified_hypothesis id in - CT_use_inversion (id, xlate_formula c, - CT_id_list (List.map xlate_hyp idlist)) - | TacExtend (_,"omega", []) -> CT_omega - | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2) - | TacRename _ -> xlate_error "TODO: add support for n-ary rename" - | TacClearBody([]) -> assert false - | TacClearBody(a::l) -> - CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) - | TacDAuto (a, b, []) -> - CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) - | TacDAuto (a, b, _) -> - xlate_error "TODO: dauto using" - | TacInductionDestruct(true,false,[a,b,(None,c),None]) -> - CT_new_destruct - (List.map xlate_int_or_constr a, xlate_using b, - xlate_with_names c) - | TacInductionDestruct(false,false,[a,b,(None,c),None]) -> - CT_new_induction - (List.map xlate_int_or_constr a, xlate_using b, - xlate_with_names c) - | TacInductionDestruct(_,false,_) -> - xlate_error "TODO: clause 'in' and full 'as' of destruct/induction" - | TacLetTac (na, c, cl, true) when cl = nowhere -> - CT_pose(xlate_id_opt_aux na, xlate_formula c) - | TacLetTac (na, c, cl, true) -> - CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, - (* TODO LATER: This should be shared with Unfold, - but the structures are different *) - xlate_clause cl) - | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, Some (_,IntroIdentifier id), c) -> - CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, None, c) -> - CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> - CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), None, c) -> - CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert _ -> - xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" - | TacAnyConstructor(false,Some tac) -> - CT_any_constructor - (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) - | TacAnyConstructor(false,None) -> - CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) - | TacAnyConstructor _ -> xlate_error "TODO: econstructor" - | TacExtend(_, "ring", [args]) -> - CT_ring - (CT_formula_list - (List.map xlate_formula - (out_gen (wit_list0 rawwit_constr) args))) - | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal" - | TacExtend (_,id, l) -> - print_endline ("Extratactics : "^ id); - CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) - | TacAlias _ -> xlate_error "Alias not supported" - -and coerce_genarg_to_TARG x = - match Genarg.genarg_tag x with - (* Basic types *) - | BoolArgType -> xlate_error "TODO: generic boolean argument" - | IntArgType -> - let n = out_gen rawwit_int x in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n))) - | IntOrVarArgType -> - let x = match out_gen rawwit_int_or_var x with - | ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) - | ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x) - | StringArgType -> - let s = CT_string (out_gen rawwit_string x) in - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT - (CT_coerce_STRING_to_ID_OR_STRING s)) - | PreIdentArgType -> - let id = CT_ident (out_gen rawwit_pre_ident x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | IntroPatternArgType -> - xlate_error "TODO" - | IdentArgType true -> - let id = xlate_ident (out_gen rawwit_ident x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | IdentArgType false -> - xlate_error "TODO" - | VarArgType -> - let id = xlate_ident (snd (out_gen rawwit_var x)) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | RefArgType -> - let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - (* Specific types *) - | SortArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT - (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) - | ConstrArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) - | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" - | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | OpenConstrArgType b -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula - (snd (out_gen - (rawwit_open_constr_gen b) x)))) - | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = Option.get (Pcoq.tactic_genarg_level s) in - let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in - CT_coerce_TACTIC_COM_to_TARG t - | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" - | BindingsArgType -> xlate_error "TODO: generic with bindings" - | RedExprArgType -> xlate_error "TODO: generic red expr" - | List0ArgType l -> xlate_error "TODO: lists of generic arguments" - | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" - | OptArgType x -> xlate_error "TODO: optional generic arguments" - | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" - | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" -and xlate_context_rule = - function - | Pat (hyps, concl_pat, tactic) -> - CT_context_rule - (CT_context_hyp_list (List.map xlate_match_context_hyps hyps), - xlate_context_pattern concl_pat, xlate_tactic tactic) - | All tactic -> - CT_def_context_rule (xlate_tactic tactic) -and formula_to_def_body = - function - | ConstrEval (red, f) -> - CT_coerce_EVAL_CMD_to_DEF_BODY( - CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, - xlate_red_tactic red, xlate_formula f)) - | ConstrContext((_, id), f) -> - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY - (CT_context - (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)), - xlate_formula f)) - | ConstrTypeOf f -> CT_type_of (xlate_formula f) - | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) - -and mk_let_value = function - TacArg (ConstrMayEval v) -> - CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) - | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; - -let coerce_genarg_to_VARG x = - match Genarg.genarg_tag x with - (* Basic types *) - | BoolArgType -> xlate_error "TODO: generic boolean argument" - | IntArgType -> - let n = out_gen rawwit_int x in - CT_coerce_ID_OR_INT_OPT_to_VARG - (CT_coerce_INT_OPT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_INT_OPT (CT_int n))) - | IntOrVarArgType -> - (match out_gen rawwit_int_or_var x with - | ArgArg n -> - CT_coerce_ID_OR_INT_OPT_to_VARG - (CT_coerce_INT_OPT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_INT_OPT (CT_int n))) - | ArgVar (_,id) -> - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT (xlate_ident id)))) - | StringArgType -> - let s = CT_string (out_gen rawwit_string x) in - CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s) - | PreIdentArgType -> - let id = CT_ident (out_gen rawwit_pre_ident x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | IntroPatternArgType -> - xlate_error "TODO" - | IdentArgType true -> - let id = xlate_ident (out_gen rawwit_ident x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | IdentArgType false -> - xlate_error "TODO" - | VarArgType -> - let id = xlate_ident (snd (out_gen rawwit_var x)) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | RefArgType -> - let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - (* Specific types *) - | SortArgType -> - CT_coerce_FORMULA_OPT_to_VARG - (CT_coerce_FORMULA_to_FORMULA_OPT - (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) - | ConstrArgType -> - CT_coerce_FORMULA_OPT_to_VARG - (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) - | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" - | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = Option.get (Pcoq.tactic_genarg_level s) in - let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in - CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) - | OpenConstrArgType _ -> xlate_error "TODO: generic open constr" - | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" - | BindingsArgType -> xlate_error "TODO: generic with bindings" - | RedExprArgType -> xlate_error "TODO: red expr as generic argument" - | List0ArgType l -> xlate_error "TODO: lists of generic arguments" - | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" - | OptArgType x -> xlate_error "TODO: optional generic arguments" - | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" - | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" - - -let xlate_thm x = CT_thm (string_of_theorem_kind x) - -let xlate_defn k = CT_defn (string_of_definition_kind k) - -let xlate_var x = CT_var (match x with - | (Global,Definitional) -> "Parameter" - | (Global,Logical) -> "Axiom" - | (Local,Definitional) -> "Variable" - | (Local,Logical) -> "Hypothesis" - | (Global,Conjectural) -> "Conjecture" - | (Local,Conjectural) -> xlate_error "No local conjecture");; - - -let xlate_dep = - function - | true -> CT_dep "Induction for" - | false -> CT_dep "Minimality for";; - -let xlate_locn = - function - | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n) - | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top") - | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev") - | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next") - -let xlate_search_restr = - function - | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none - | SearchInside (m1::l1) -> - CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, - List.map loc_qualid_to_ct_ID l1)) - | SearchOutside (m1::l1) -> - CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, - List.map loc_qualid_to_ct_ID l1)) - | SearchInside [] -> xlate_error "bad extra argument for Search" - -let xlate_check = - function - | "CHECK" -> "Check" - | "PRINTTYPE" -> "Type" - | _ -> xlate_error "xlate_check";; - -let build_constructors l = - let f (coe,((_,id),c)) = - if coe then CT_constr_coercion (xlate_ident id, xlate_formula c) - else CT_constr (xlate_ident id, xlate_formula c) in - CT_constr_list (List.map f l) - -let build_record_field_list l = - let build_record_field ((coe,d),not) = match d with - | AssumExpr (id,c) -> - if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) - else - CT_recconstr(xlate_id_opt id, xlate_formula c) - | DefExpr (id,c,topt) -> - if coe then - CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c, - xlate_formula_opt topt) - else - CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in - CT_recconstr_list (List.map build_record_field l);; - -let get_require_flags impexp spec = - let ct_impexp = - match impexp with - | None -> CT_coerce_NONE_to_IMPEXP CT_none - | Some false -> CT_import - | Some true -> CT_export in - let ct_spec = - match spec with - | None -> ctv_SPEC_OPT_NONE - | Some true -> CT_spec - | Some false -> ctv_SPEC_OPT_NONE in - ct_impexp, ct_spec;; - -let cvt_optional_eval_for_definition c1 optional_eval = - match optional_eval with - None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1) - | Some red -> - CT_coerce_EVAL_CMD_to_DEF_BODY( - CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, - xlate_red_tactic red, - xlate_formula c1)) - -let cvt_vernac_binder = function - | b,(id::idl,c) -> - let l,t = - CT_id_opt_ne_list - (xlate_ident_opt (Some (snd id)), - List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), - xlate_formula c in - if b then - CT_binder_coercion(l,t) - else - CT_binder(l,t) - | _, _ -> xlate_error "binder with no left part, rejected";; - -let cvt_vernac_binders = function - a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args) - | [] -> assert false;; - - -let xlate_comment = function - CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c) - | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT - (CT_coerce_STRING_to_ID_OR_STRING(CT_string s)) - | CommentInt n -> - CT_coerce_FORMULA_to_SCOMMENT_CONTENT - (CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));; - -let translate_opt_notation_decl = function - None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) - | Some(s, f, sc) -> - let tr_sc = - match sc with - None -> ctv_ID_OPT_NONE - | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in - CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; - -let xlate_level = function - Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n) - | Extend.NextLevel -> CT_next_level;; - -let xlate_syntax_modifier = function - Extend.SetItemLevel((s::sl), level) -> - CT_set_item_level - (CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl), - xlate_level level) - | Extend.SetItemLevel([], _) -> assert false - | Extend.SetLevel level -> CT_set_level (CT_int level) - | Extend.SetAssoc Gramext.LeftA -> CT_lefta - | Extend.SetAssoc Gramext.RightA -> CT_righta - | Extend.SetAssoc Gramext.NonA -> CT_nona - | Extend.SetEntryType(x,typ) -> - CT_entry_type(CT_ident x, - match typ with - Extend.ETIdent -> CT_ident "ident" - | Extend.ETReference -> CT_ident "global" - | Extend.ETBigint -> CT_ident "bigint" - | _ -> xlate_error "syntax_type not parsed") - | Extend.SetOnlyParsing -> CT_only_parsing - | Extend.SetFormat(_,s) -> CT_format(CT_string s);; - - -let rec xlate_module_type = function - | CMTEident(_, qid) -> - CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) - | CMTEwith(mty, decl) -> - let mty1 = xlate_module_type mty in - (match decl with - CWith_Definition((_, idl), c) -> - CT_module_type_with_def(mty1, - CT_id_list (List.map xlate_ident idl), - xlate_formula c) - | CWith_Module((_, idl), (_, qid)) -> - CT_module_type_with_mod(mty1, - CT_id_list (List.map xlate_ident idl), - CT_ident (xlate_qualid qid))) - | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";; - - -let xlate_module_binder_list (l:module_binder list) = - CT_module_binder_list - (List.map (fun (_, idl, mty) -> - let idl1 = - List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in - let fst,idl2 = match idl1 with - [] -> assert false - | fst::idl2 -> fst,idl2 in - CT_module_binder - (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);; - -let xlate_module_type_check_opt = function - None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK - (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) - | Some(mty, true) -> CT_only_check(xlate_module_type mty) - | Some(mty, false) -> - CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK - (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT - (xlate_module_type mty));; - -let rec xlate_module_expr = function - CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR - (CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid))) - | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1, - xlate_module_expr me2) - -let rec xlate_vernac = - function - | VernacDeclareTacticDefinition (true, tacs) -> - (match List.map - (function - (id, _, body) -> - CT_tac_def(reference_to_ct_ID id, xlate_tactic body)) - tacs with - [] -> assert false - | fst::tacs1 -> - CT_tactic_definition - (CT_tac_def_ne_list(fst, tacs1))) - | VernacDeclareTacticDefinition(false, _) -> - xlate_error "obsolete tactic definition not handled" - | VernacLoad (verbose,s) -> - CT_load ( - (match verbose with - | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none - | true -> CT_verbose), - CT_coerce_STRING_to_ID_OR_STRING (CT_string s)) - | VernacCheckMayEval (Some red, numopt, f) -> - let red = xlate_red_tactic red in - CT_coerce_EVAL_CMD_to_COMMAND - (CT_eval (xlate_int_opt numopt, red, xlate_formula f)) - |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s) - | VernacAddLoadPath (false,str,None) -> - CT_addpath (CT_string str, ctv_ID_OPT_NONE) - | VernacAddLoadPath (false,str,Some x) -> - CT_addpath (CT_string str, - CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) - | VernacAddLoadPath (true,str,None) -> - CT_recaddpath (CT_string str, ctv_ID_OPT_NONE) - | VernacAddLoadPath (_,str, Some x) -> - CT_recaddpath (CT_string str, - CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) - | VernacRemoveLoadPath str -> CT_delpath (CT_string str) - | VernacToplevelControl Quit -> CT_quit - | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported" - (*ML commands *) - | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str) - | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str) - | VernacDeclareMLModule [] -> failwith "" - | VernacDeclareMLModule (str :: l) -> - CT_ml_declare_modules - (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l)) - | VernacGoal c -> - CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c)) - | VernacAbort (Some (_,id)) -> - CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) - | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE - | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL - | VernacRestart -> CT_restart - | VernacSolve (n, tac, b) -> - CT_solve (CT_int n, xlate_tactic tac, - if b then CT_dotdot - else CT_coerce_NONE_to_DOTDOT_OPT CT_none) - -(* MMode *) - - | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> - anomaly "No MMode in CTcoq" - - -(* /MMode *) - - | VernacFocus nopt -> CT_focus (xlate_int_opt nopt) - | VernacUnfocus -> CT_unfocus - |VernacExtend("Extraction", [f;l]) -> - let file = out_gen rawwit_string f in - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in - CT_extract_to_file(CT_string file, - CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("ExtractionInline", [l]) -> - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in - CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("ExtractionNoInline", [l]) -> - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in - CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("Field", - [fth;ainv;ainvl;div]) -> - (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) - [fth;ainv;ainvl] - with - [fth1;ainv1;ainvl1] -> - let adiv1 = - xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in - CT_add_field(fth1, ainv1, ainvl1, adiv1) - |_ -> assert false) - | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) -> - let orient = out_gen Extraargs.rawwit_orient o in - let formula_list = out_gen (wit_list1 rawwit_constr) f in - let base = out_gen rawwit_pre_ident b in - let t = - match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId [] - in - let ct_orient = match orient with - | true -> CT_lr - | false -> CT_rl in - let f_ne_list = match List.map xlate_formula formula_list with - (fst::rest) -> CT_formula_ne_list(fst,rest) - | _ -> assert false in - CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) - | VernacCreateHintDb (local,dbname,b) -> - xlate_error "TODO: VernacCreateHintDb" - | VernacHints (local,dbnames,h) -> - let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in - (match h with - | HintsConstructors l -> - let n1, names = match List.map tac_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - if local then - CT_local_hints(CT_ident "Constructors", - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident "Constructors", - CT_id_ne_list(n1, names), dblist) - | HintsExtern (n, c, t) -> - let pat = match c with - | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) - | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) - in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) - | HintsImmediate l -> - let f1, formulas = match List.map xlate_formula l with - a :: tl -> a, tl - | _ -> failwith "" in - let l' = CT_formula_ne_list(f1, formulas) in - if local then - (match h with - HintsResolve _ -> - CT_local_hints_resolve(l', dblist) - | HintsImmediate _ -> - CT_local_hints_immediate(l', dblist) - | _ -> assert false) - else - (match h with - HintsResolve _ -> CT_hints_resolve(l', dblist) - | HintsImmediate _ -> CT_hints_immediate(l', dblist) - | _ -> assert false) - | HintsResolve l -> - let f1, formulas = match List.map xlate_formula (List.map pi3 l) with - a :: tl -> a, tl - | _ -> failwith "" in - let l' = CT_formula_ne_list(f1, formulas) in - if local then - (match h with - HintsResolve _ -> - CT_local_hints_resolve(l', dblist) - | HintsImmediate _ -> - CT_local_hints_immediate(l', dblist) - | _ -> assert false) - else - (match h with - HintsResolve _ -> CT_hints_resolve(l', dblist) - | HintsImmediate _ -> CT_hints_immediate(l', dblist) - | _ -> assert false) - | HintsUnfold l -> - let n1, names = match List.map loc_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - if local then - CT_local_hints(CT_ident "Unfold", - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - | HintsTransparency (l,b) -> - let n1, names = match List.map loc_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - let ty = if b then "Transparent" else "Opaque" in - if local then - CT_local_hints(CT_ident ty, - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) - | HintsDestruct(id, n, loc, f, t) -> - let dl = match loc with - ConclLocation() -> CT_conclusion_location - | HypLocation true -> CT_discardable_hypothesis - | HypLocation false -> CT_hypothesis_location in - if local then - CT_local_hint_destruct - (xlate_ident id, CT_int n, - dl, xlate_formula f, xlate_tactic t, dblist) - else - CT_hint_destruct - (xlate_ident id, CT_int n, dl, xlate_formula f, - xlate_tactic t, dblist) -) - | VernacEndProof (Proved (true,None)) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE) - | VernacEndProof (Proved (false,None)) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE) - | VernacEndProof (Proved (b,Some ((_,s), Some kind))) -> - CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind), - ctf_ID_OPT_SOME (xlate_ident s)) - | VernacEndProof (Proved (b,Some ((_,s),None))) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), - ctf_ID_OPT_SOME (xlate_ident s)) - | VernacEndProof Admitted -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE) - | VernacSetOpacity (_,l) -> - CT_strategy(CT_level_list - (List.map (fun (l,q) -> - (level_to_ct_LEVEL l, - CT_id_list(List.map loc_qualid_to_ct_ID q))) l)) - | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n)) - | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt) - | VernacShow ShowNode -> CT_show_node - | VernacShow ShowProof -> CT_show_proof - | VernacShow ShowTree -> CT_show_tree - | VernacShow ShowProofNames -> CT_show_proofs - | VernacShow (ShowIntros true) -> CT_show_intros - | VernacShow (ShowIntros false) -> CT_show_intro - | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1) - | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n) - | VernacShow ShowExistentials -> CT_show_existentials - | VernacShow ShowScript -> CT_show_script - | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)" - | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)" - | VernacGo arg -> CT_go (xlate_locn arg) - | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l) - | VernacShow (ExplainTree l) -> - CT_explain_prooftree (nums_to_int_list l) - | VernacCheckGuard -> CT_guarded - | VernacPrint p -> - (match p with - PrintFullContext -> CT_print_all - | PrintName id -> CT_print_id (loc_qualid_to_ct_ID id) - | PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id) - | PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id) - | PrintModules -> CT_print_modules - | PrintGrammar name -> CT_print_grammar CT_grammar_none - | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) - | PrintHintDbName id -> - CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) - | PrintRewriteHintDbName id -> - CT_print_rewrite_hintdb (CT_ident id) - | PrintHint id -> - CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) - | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE - | PrintLoadPath None -> CT_print_loadpath - | PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir" - | PrintMLLoadPath -> CT_ml_print_path - | PrintMLModules -> CT_ml_print_modules - | PrintGraph -> CT_print_graph - | PrintClasses -> CT_print_classes - | PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid) - | PrintCoercions -> CT_print_coercions - | PrintCoercionPaths (id1, id2) -> - CT_print_path (xlate_class id1, xlate_class id2) - | PrintCanonicalConversions -> - xlate_error "TODO: Print Canonical Structures" - | PrintAssumptions _ -> - xlate_error "TODO: Print Needed Assumptions" - | PrintInstances _ -> - xlate_error "TODO: Print Instances" - | PrintTypeClasses -> - xlate_error "TODO: Print TypeClasses" - | PrintInspect n -> CT_inspect (CT_int n) - | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) - | PrintTables -> CT_print_tables - | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) - | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) - | PrintScopes -> CT_print_scopes - | PrintScope id -> CT_print_scope (CT_ident id) - | PrintVisibility id_opt -> - CT_print_visibility - (match id_opt with - Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) - | None -> ctv_ID_OPT_NONE) - | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid) - | PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid)) - | VernacBeginSection (_,id) -> - CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id)) - | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id) - | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) -> - CT_coerce_THEOREM_GOAL_to_COMMAND( - CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, - xlate_binder_list bl, xlate_formula c)) - | VernacStartTheoremProof _ -> - xlate_error "TODO: Mutually dependent theorems" - | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt)) - | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> - CT_coerce_THEOREM_GOAL_to_COMMAND - (CT_theorem_goal - (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k), - xlate_ident s, xlate_binder_list bl, xlate_formula typ)) - | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) -> - CT_definition - (xlate_defn kind, xlate_ident s, xlate_binder_list bl, - cvt_optional_eval_for_definition c red_option, - xlate_formula_opt typ_opt) - | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline" - (*inline : bool -> automatic delta reduction at fonctor application*) - (* CT_variable (xlate_var kind, cvt_vernac_binders b)*) - | VernacCheckMayEval (None, numopt, c) -> - CT_check (xlate_formula c) - | VernacSearch (s,x) -> - let translated_restriction = xlate_search_restr x in - (match s with - | SearchPattern c -> - CT_search_pattern(xlate_formula c, translated_restriction) - | SearchHead id -> - CT_search(loc_qualid_to_ct_ID id, translated_restriction) - | SearchRewrite c -> - CT_search_rewrite(xlate_formula c, translated_restriction) - | SearchAbout (a::l) -> - let xlate_search_about_item (b,it) = - if not b then xlate_error "TODO: negative searchabout constraint"; - match it with - SearchSubPattern (CRef x) -> - CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString (s,None) -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string s) - | SearchString _ | SearchSubPattern _ -> - xlate_error - "TODO: search subpatterns or notation with explicit scope" - in - CT_search_about - (CT_id_or_string_ne_list(xlate_search_about_item a, - List.map xlate_search_about_item l), - translated_restriction) - | SearchAbout [] -> assert false) - -(* | (\*Record from tactics/Record.v *\) *) -(* VernacRecord *) -(* (_, (add_coercion, (_,s)), binders, c1, *) -(* rec_constructor_or_none, field_list) -> *) -(* let record_constructor = *) -(* xlate_ident_opt (Option.map snd rec_constructor_or_none) in *) -(* CT_record *) -(* ((if add_coercion then CT_coercion_atm else *) -(* CT_coerce_NONE_to_COERCION_OPT(CT_none)), *) -(* xlate_ident s, xlate_binder_list binders, *) -(* xlate_formula (Option.get c1), record_constructor, *) -(* build_record_field_list field_list) *) - | VernacInductive (isind, lmi) -> - let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in - let strip_mutind = function - (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) -> - CT_ind_spec - (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c), - build_constructors constructors, - translate_opt_notation_decl notopt) - | _ -> xlate_error "TODO: Record notation in (Co)Inductive" in - CT_mind_decl - (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) - | VernacFixpoint ([],_) -> xlate_error "mutual recursive" - | VernacFixpoint ((lm :: lmi),boxed) -> - let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) = - let struct_arg = make_fix_struct (n, bl) in - let arf = xlate_formula arf in - let ardef = xlate_formula ardef in - match xlate_binder_list bl with - | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), - struct_arg, arf, ardef) - | _ -> xlate_error "mutual recursive" in - CT_fix_decl - (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) - | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" - | VernacCoFixpoint ((lm :: lmi),boxed) -> - let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) = - CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, - xlate_formula arf, xlate_formula ardef) in - CT_cofix_decl - (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)) - | VernacScheme [] -> xlate_error "induction scheme" - | VernacScheme (lm :: lmi) -> - let strip_ind = function - | (Some (_,id), InductionScheme (depstr, inde, sort)) -> - CT_scheme_spec - (xlate_ident id, xlate_dep depstr, - CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), - xlate_sort sort) - | (None, InductionScheme (depstr, inde, sort)) -> - CT_scheme_spec - (xlate_ident (id_of_string ""), xlate_dep depstr, - CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), - xlate_sort sort) - | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in - CT_ind_scheme - (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi)) - | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme" - | VernacSyntacticDefinition ((_,id), ([],c), false, _) -> - CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None) - | VernacSyntacticDefinition ((_,id), _, _, _) -> - xlate_error"TODO: Local abbreviations and abbreviations with parameters" - (* Modules and Module Types *) - | VernacInclude (_) -> xlate_error "TODO : Include " - | VernacDeclareModuleType((_, id), bl, mty_o) -> - CT_module_type_decl(xlate_ident id, - xlate_module_binder_list bl, - match mty_o with - None -> - CT_coerce_ID_OPT_to_MODULE_TYPE_OPT - ctv_ID_OPT_NONE - | Some mty1 -> - CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT - (xlate_module_type mty1)) - | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) -> - CT_module(xlate_ident id, - xlate_module_binder_list bl, - xlate_module_type_check_opt mty_o, - match mexpr_o with - None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE - | Some m -> xlate_module_expr m) - | VernacDeclareModule(_,(_, id), bl, mty_o) -> - CT_declare_module(xlate_ident id, - xlate_module_binder_list bl, - xlate_module_type_check_opt (Some mty_o), - CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE) - | VernacRequire (impexp, spec, id::idl) -> - let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require (ct_impexp, ct_spec, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( - CT_id_ne_list(loc_qualid_to_ct_ID id, - List.map loc_qualid_to_ct_ID idl))) - | VernacRequire (_,_,[]) -> - xlate_error "Require should have at least one id argument" - | VernacRequireFrom (impexp, spec, filename) -> - let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require(ct_impexp, ct_spec, - CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) - - | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) - | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) - | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) - | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) - | VernacArgumentsScope(true, qid, l) -> - CT_arguments_scope(loc_qualid_to_ct_ID qid, - CT_id_opt_list - (List.map - (fun x -> - match x with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) - | VernacArgumentsScope(false, qid, l) -> - xlate_error "TODO: Arguments Scope Global" - | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) - | VernacBindScope(id, a::l) -> - let xlate_class_rawexpr = function - FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" - | RefClass qid -> loc_qualid_to_ct_ID qid in - CT_bind_scope(CT_ident id, - CT_id_ne_list(xlate_class_rawexpr a, - List.map xlate_class_rawexpr l)) - | VernacBindScope(id, []) -> assert false - | VernacNotation(b, c, (s,modif_list), opt_scope) -> - let translated_s = CT_string s in - let formula = xlate_formula c in - let translated_modif_list = - CT_modifier_list(List.map xlate_syntax_modifier modif_list) in - let translated_scope = match opt_scope with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x) in - if b then - CT_local_define_notation - (translated_s, formula, translated_modif_list, translated_scope) - else - CT_define_notation(translated_s, formula, - translated_modif_list, translated_scope) - | VernacSyntaxExtension(b,(s,modif_list)) -> - let translated_s = CT_string s in - let translated_modif_list = - CT_modifier_list(List.map xlate_syntax_modifier modif_list) in - if b then - CT_local_reserve_notation(translated_s, translated_modif_list) - else - CT_reserve_notation(translated_s, translated_modif_list) - | VernacInfix (b,(str,modl),id, opt_scope) -> - let id1 = loc_qualid_to_ct_ID id in - let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in - let s = CT_string str in - let translated_scope = match opt_scope with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x) in - if b then - CT_local_infix(s, id1,modl1, translated_scope) - else - CT_infix(s, id1,modl1, translated_scope) - | VernacCoercion (s, id1, id2, id3) -> - let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in - let local_opt = - match s with - (* Cannot decide whether it is a global or a Local but at toplevel *) - | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none - | Local -> CT_local in - CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1, - xlate_class id2, xlate_class id3) - - | VernacIdentityCoercion (s, (_,id1), id2, id3) -> - let id_opt = CT_identity in - let local_opt = - match s with - (* Cannot decide whether it is a global or a Local but at toplevel *) - | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none - | Local -> CT_local in - CT_coercion (local_opt, id_opt, xlate_ident id1, - xlate_class id2, xlate_class id3) - - (* Type Classes *) - | VernacDeclareInstance _|VernacContext _| - VernacInstance (_, _, _, _, _) -> - xlate_error "TODO: Type Classes commands" - - | VernacResetName id -> CT_reset (xlate_ident (snd id)) - | VernacResetInitial -> CT_restore_state (CT_ident "Initial") - | VernacExtend (s, l) -> - CT_user_vernac - (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacList((_, a)::l) -> - CT_coerce_COMMAND_LIST_to_COMMAND - (CT_command_list(xlate_vernac a, - List.map (fun (_, x) -> xlate_vernac x) l)) - | VernacList([]) -> assert false - | VernacNop -> CT_proof_no_op - | VernacComments l -> - CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) - | VernacDeclareImplicits(true, id, opt_positions) -> - CT_implicits - (reference_to_ct_ID id, - match opt_positions with - None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none - | Some l -> - CT_coerce_ID_LIST_to_ID_LIST_OPT - (CT_id_list - (List.map - (function ExplByPos (x,_), _, _ - -> xlate_error - "explication argument by rank is obsolete" - | ExplByName id, _, _ -> CT_ident (string_of_id id)) l))) - | VernacDeclareImplicits(false, id, opt_positions) -> - xlate_error "TODO: Implicit Arguments Global" - | VernacReserve((_,a)::l, f) -> - CT_reserve(CT_id_ne_list(xlate_ident a, - List.map (fun (_,x) -> xlate_ident x) l), - xlate_formula f) - | VernacReserve([], _) -> assert false - | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id) - | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id) - | VernacLocate(LocateModule _) -> xlate_error "TODO: Locate Module" - | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s) - | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s) - | VernacTime(v) -> CT_time(xlate_vernac v) - | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) - |VernacExactProof f -> CT_proof(xlate_formula f) - | VernacSetOption (table, BoolValue true) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_set_option(table1) - | VernacSetOption (table, v) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - let value = - match v with - | BoolValue _ -> assert false - | StringValue s -> - CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s) - | IntValue n -> - CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in - CT_set_option_value(table1, value) - | VernacUnsetOption(table) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_unset_option(table1) - | VernacAddOption (table, l) -> - let values = - List.map - (function - | QualidRefValue x -> - CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | StringRefValue x -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in - let fst, values1 = - match values with [] -> assert false | a::b -> (a,b) in - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1)) - | VernacImport(true, a::l) -> - CT_export_id(CT_id_ne_list(reference_to_ct_ID a, - List.map reference_to_ct_ID l)) - | VernacImport(false, a::l) -> - CT_import_id(CT_id_ne_list(reference_to_ct_ID a, - List.map reference_to_ct_ID l)) - | VernacImport(_, []) -> assert false - | VernacProof t -> CT_proof_with(xlate_tactic t) - | (VernacGlobalCheck _|VernacPrintOption _| - VernacMemOption (_, _)|VernacRemoveOption (_, _) - | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _| - VernacSolveExistential (_, _)|VernacCanonical _ | - VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _) - -> xlate_error "TODO: vernac" -and level_to_ct_LEVEL = function - Conv_oracle.Opaque -> CT_Opaque - | Conv_oracle.Level n -> CT_Level (CT_int n) - | Conv_oracle.Expand -> CT_Expand;; - - -let rec xlate_vernac_list = - function - | VernacList (v::l) -> - CT_command_list - (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l) - | VernacList [] -> xlate_error "xlate_command_list" - | _ -> xlate_error "Not a list of commands";; diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli deleted file mode 100644 index 2e2b95fe..00000000 --- a/contrib/interface/xlate.mli +++ /dev/null @@ -1,8 +0,0 @@ -open Ascent;; - -val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;; -val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;; -val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;; -val xlate_ident : Names.identifier -> ct_ID;; -val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;; - |