diff options
Diffstat (limited to 'toplevel')
42 files changed, 8578 insertions, 0 deletions
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml new file mode 100644 index 00000000..21098a57 --- /dev/null +++ b/toplevel/cerrors.ml @@ -0,0 +1,134 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: cerrors.ml,v 1.12.2.2 2004/07/16 20:48:17 herbelin Exp $ *) + +open Pp +open Util +open Ast +open Indtypes +open Type_errors +open Pretype_errors +open Lexer + +let print_loc loc = + if loc = dummy_loc then + (str"<unknown>") + else + let loc = unloc loc in + (int (fst loc) ++ str"-" ++ int (snd loc)) + +let guill s = "\""^s^"\"" + +let where s = + if !Options.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) + +let report () = (str "." ++ spc () ++ str "Please report.") + +(* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *) + +let rec explain_exn_default = function + | Stream.Failure -> + hov 0 (str "Anomaly: uncaught Stream.Failure.") + | Stream.Error txt -> + hov 0 (str "Syntax error: " ++ str txt) + | Token.Error txt -> + hov 0 (str "Syntax error: " ++ str txt) + | Sys_error msg -> + hov 0 (str "Anomaly: uncaught exception Sys_error " ++ str (guill msg) ++ report ()) + | UserError(s,pps) -> + hov 1 (str "User error: " ++ where s ++ pps) + | Out_of_memory -> + hov 0 (str "Out of memory") + | Stack_overflow -> + hov 0 (str "Stack overflow") + | Ast.No_match s -> + hov 0 (str "Anomaly: Ast matching error: " ++ str s ++ report ()) + | Anomaly (s,pps) -> + hov 1 (str "Anomaly: " ++ where s ++ pps ++ report ()) + | Match_failure(filename,pos1,pos2) -> + hov 1 (str "Anomaly: Match failure in file " ++ str (guill filename) ++ + if Sys.ocaml_version = "3.06" then + (str " from character " ++ int pos1 ++ + str " to " ++ int pos2) + else + (str " at line " ++ int pos1 ++ + str " character " ++ int pos2) + ++ report ()) + | Not_found -> + hov 0 (str "Anomaly: uncaught exception Not_found" ++ report ()) + | Failure s -> + hov 0 (str "Anomaly: uncaught exception Failure " ++ str (guill s) ++ report ()) + | Invalid_argument s -> + hov 0 (str "Anomaly: uncaught exception Invalid_argument " ++ str (guill s) ++ report ()) + | Sys.Break -> + hov 0 (fnl () ++ str "User Interrupt.") + | Univ.UniverseInconsistency -> + hov 0 (str "Error: Universe Inconsistency.") + | TypeError(ctx,te) -> + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te) + | PretypeError(ctx,te) -> + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te) + | InductiveError e -> + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e) + | Cases.PatternMatchingError (env,e) -> + hov 0 + (str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e) + | Logic.RefinerError e -> + hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e) + | Nametab.GlobalizationError q -> + hov 0 (str "Error:" ++ spc () ++ + str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment") + | Nametab.GlobalizationConstantError q -> + hov 0 (str "Error:" ++ spc () ++ + str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q) + | Refiner.FailError (i,s) -> + let s = if s="" then "" else " \""^s^"\"" in + hov 0 (str "Error: Tactic failure" ++ str s ++ + if i=0 then mt () else str " (level " ++ int i ++ str").") + | Stdpp.Exc_located (loc,exc) -> + hov 0 ((if loc = dummy_loc then (mt ()) + else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) + ++ explain_exn_default exc) + | Lexer.Error Illegal_character -> + hov 0 (str "Syntax error: Illegal character.") + | Lexer.Error Unterminated_comment -> + hov 0 (str "Syntax error: Unterminated comment.") + | Lexer.Error Unterminated_string -> + hov 0 (str "Syntax error: Unterminated string.") + | Lexer.Error Undefined_token -> + hov 0 (str "Syntax error: Undefined token.") + | Lexer.Error (Bad_token s) -> + hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".") + | Assert_failure (s,b,e) -> + hov 0 (str "Anomaly: assert failure" ++ spc () ++ + (if s <> "" then + if Sys.ocaml_version = "3.06" then + (str ("(file \"" ^ s ^ "\", characters ") ++ + int b ++ str "-" ++ int e ++ str ")") + else + (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ + str ", characters " ++ int e ++ str "-" ++ + int (e+6) ++ str ")") + else + (mt ())) ++ + report ()) + | reraise -> + hov 0 (str "Anomaly: Uncaught exception " ++ + str (Printexc.to_string reraise) ++ report ()) + +let raise_if_debug e = + if !Options.debug then raise e + +let _ = Tactic_debug.explain_logic_error := explain_exn_default + +let explain_exn_function = ref explain_exn_default + +let explain_exn e = !explain_exn_function e diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli new file mode 100644 index 00000000..09d79cec --- /dev/null +++ b/toplevel/cerrors.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: cerrors.mli,v 1.2.6.1 2004/07/16 19:31:47 herbelin Exp $ i*) + +(*i*) +open Pp +open Util +(*i*) + +(* Error report. *) + +val print_loc : loc -> std_ppcmds + +val explain_exn : exn -> std_ppcmds + +val explain_exn_function : (exn -> std_ppcmds) ref +val explain_exn_default : exn -> std_ppcmds + +val raise_if_debug : exn -> unit diff --git a/toplevel/class.ml b/toplevel/class.ml new file mode 100644 index 00000000..429469b1 --- /dev/null +++ b/toplevel/class.ml @@ -0,0 +1,460 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: class.ml,v 1.44.2.2 2004/07/16 19:31:47 herbelin Exp $ *) + +open Util +open Pp +open Names +open Nameops +open Term +open Termops +open Inductive +open Declarations +open Entries +open Environ +open Inductive +open Lib +open Classops +open Declare +open Libnames +open Nametab +open Decl_kinds +open Safe_typing + +let strength_min4 stre1 stre2 stre3 stre4 = + strength_min ((strength_min (stre1,stre2)),(strength_min (stre3,stre4))) + +let id_of_varid c = match kind_of_term c with + | Var id -> id + | _ -> anomaly "class__id_of_varid" + +(* lf liste des variable dont depend la coercion f + lc liste des variable dont depend la classe source *) + +let rec stre_unif_cond = function + | ([],[]) -> Global + | (v::l,[]) -> variable_strength v + | ([],v::l) -> variable_strength v + | (v1::l1,v2::l2) -> + if v1=v2 then + stre_unif_cond (l1,l2) + else + let stre1 = (variable_strength v1) + and stre2 = (variable_strength v2) in + strength_min (stre1,stre2) + +(* Errors *) + +type coercion_error_kind = + | AlreadyExists + | NotAFunction + | NoSource of cl_typ option + | ForbiddenSourceClass of cl_typ + | NotUniform + | NoTarget + | WrongTarget of cl_typ * cl_typ + | NotAClass of global_reference + | NotEnoughClassArgs of cl_typ + +exception CoercionError of coercion_error_kind + +let explain_coercion_error g = function + | AlreadyExists -> + (Printer.pr_global g ++ str" is already a coercion") + | NotAFunction -> + (Printer.pr_global g ++ str" is not a function") + | NoSource (Some cl) -> + (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " + ++ Printer.pr_global g) + | NoSource None -> + (str ": cannot find the source class of " ++ Printer.pr_global g) + | ForbiddenSourceClass cl -> + pr_class cl ++ str " cannot be a source class" + | NotUniform -> + (Printer.pr_global g ++ + str" does not respect the inheritance uniform condition"); + | NoTarget -> + (str"Cannot find the target class") + | WrongTarget (clt,cl) -> + (str"Found target class " ++ pr_class cl ++ + str " instead of " ++ pr_class clt) + | NotAClass ref -> + (str "Type of " ++ Printer.pr_global ref ++ + str " does not end with a sort") + | NotEnoughClassArgs cl -> + (str"Wrong number of parameters for " ++ pr_class cl) + +(* Verifications pour l'ajout d'une classe *) + +let rec arity_sort a = match kind_of_term a with + | Sort (Prop _ | Type _) -> 0 + | Prod (_,_,c) -> (arity_sort c) +1 + | LetIn (_,_,_,c) -> arity_sort c (* Utile ?? *) + | Cast (c,_) -> arity_sort c + | _ -> raise Not_found + +let check_reference_arity ref = + try arity_sort (Global.type_of_global ref) + with Not_found -> raise (CoercionError (NotAClass ref)) + +let check_arity = function + | CL_FUN | CL_SORT -> 0 + | CL_CONST sp -> check_reference_arity (ConstRef sp) + | CL_SECVAR sp -> check_reference_arity (VarRef sp) + | CL_IND sp -> check_reference_arity (IndRef sp) + +(* try_add_class : cl_typ -> strength option -> bool -> unit *) + +let strength_of_cl = function + | CL_CONST kn -> constant_strength (sp_of_global (ConstRef kn)) + | CL_SECVAR sp -> variable_strength sp + | _ -> Global + +let try_add_class cl streopt fail_if_exists = + if not (class_exists cl) then + let p = check_arity cl in + let stre' = strength_of_cl cl in + let stre = match streopt with + | Some stre -> strength_min (stre,stre') + | None -> stre' + in + declare_class (cl,stre,p) + else + if fail_if_exists then errorlabstrm "try_add_new_class" + (pr_class cl ++ str " is already a class") + + +(* Coercions *) + +(* check that the computed target is the provided one *) +let check_target clt = function + | Some cl when cl <> clt -> raise (CoercionError (WrongTarget(clt,cl))) + | _ -> () + +(* condition d'heritage uniforme *) + +let uniform_cond nargs lt = + let rec aux = function + | (0,[]) -> true + | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l)) + | _ -> false + in + aux (nargs,lt) + +let id_of_cl = function + | CL_FUN -> id_of_string "FUNCLASS" + | CL_SORT -> id_of_string "SORTCLASS" + | CL_CONST kn -> id_of_label (label kn) + | CL_IND ind -> + let (_,mip) = Global.lookup_inductive ind in + mip.mind_typename + | CL_SECVAR id -> id + +let class_of_ref = function + | ConstRef sp -> CL_CONST sp + | IndRef sp -> CL_IND sp + | VarRef id -> CL_SECVAR id + | ConstructRef _ as c -> + errorlabstrm "class_of_ref" + (str "Constructors, such as " ++ Printer.pr_global c ++ + str " cannot be used as class") + +(* +lp est la liste (inverse'e) des arguments de la coercion +ids est le nom de la classe source +sps_opt est le sp de la classe source dans le cas des structures +retourne: +la classe source +nbre d'arguments de la classe +le constr de la class +la liste des variables dont depend la classe source +l'indice de la classe source dans la liste lp +*) + +let get_source lp source = + match source with + | None -> + let (cl1,lv1) = + match lp with + | [] -> raise Not_found + | t1::_ -> find_class_type t1 + in + (cl1,lv1,1) + | Some cl -> + let rec aux = function + | [] -> raise Not_found + | t1::lt -> + try + let cl1,lv1 = find_class_type t1 in + if cl = cl1 then cl1,lv1,(List.length lt+1) + else raise Not_found + with Not_found -> aux lt + in aux (List.rev lp) + +let get_target t ind = + if (ind > 1) then + CL_FUN + else + fst (find_class_type t) + +let prods_of t = + let rec aux acc d = match kind_of_term d with + | Prod (_,c1,c2) -> aux (c1::acc) c2 + | Cast (c,_) -> aux acc c + | _ -> (d,acc) + in + aux [] t + +let get_strength stre ref cls clt = + let stres = (snd (class_info cls)).cl_strength in + let stret = (snd (class_info clt)).cl_strength in + let stref = strength_of_global ref in +(* 01/00: Supprimé la prise en compte de la force des variables locales. Sens ? + let streunif = stre_unif_cond (s_vardep,f_vardep) in + *) + let streunif = Global in + let stre' = strength_min4 stres stret stref streunif in + strength_min (stre,stre') + +(* coercion identité *) + +let error_not_transparent source = + errorlabstrm "build_id_coercion" + (pr_class source ++ str " must be a transparent constant") + +let build_id_coercion idf_opt source = + let env = Global.env () in + let vs = match source with + | CL_CONST sp -> mkConst sp + | _ -> error_not_transparent source in + let c = match constant_opt_value env (destConst vs) with + | Some c -> c + | None -> error_not_transparent source in + let lams,t = Sign.decompose_lam_assum c in + let val_f = + it_mkLambda_or_LetIn + (mkLambda (Name (id_of_string "x"), + applistc vs (extended_rel_list 0 lams), + mkRel 1)) + lams + in + let typ_f = + it_mkProd_wo_LetIn + (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t)) + lams + in + (* juste pour verification *) + let _ = + if not + (Reductionops.is_conv_leq env Evd.empty + (Typing.type_of env Evd.empty val_f) typ_f) + then + error ("cannot be defined as coercion - "^ + "maybe a bad number of arguments") + in + let idf = + match idf_opt with + | Some idf -> idf + | None -> + id_of_string ("Id_"^(string_of_class source)^"_"^ + (string_of_class (fst (find_class_type t)))) + in + let constr_entry = (* Cast is necessary to express [val_f] is identity *) + DefinitionEntry + { const_entry_body = mkCast (val_f, typ_f); + const_entry_type = Some typ_f; + const_entry_opaque = false } in + let (_,kn) = declare_constant idf (constr_entry,Decl_kinds.IsDefinition) in + ConstRef kn + +let check_source = function +| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) +| _ -> () + +(* +nom de la fonction coercion +strength de f +nom de la classe source (optionnel) +sp de la classe source (dans le cas des structures) +nom de la classe target (optionnel) +booleen "coercion identite'?" + +lorque source est None alors target est None aussi. +*) + +let add_new_coercion_core coef stre source target isid = + check_source source; + let env = Global.env () in + let v = constr_of_reference coef in + let vj = Retyping.get_judgment_of env Evd.empty v in + if coercion_exists coef then raise (CoercionError AlreadyExists); + let tg,lp = prods_of (vj.uj_type) in + let llp = List.length lp in + if llp = 0 then raise (CoercionError NotAFunction); + let (cls,lvs,ind) = + try + get_source lp source + with Not_found -> + raise (CoercionError (NoSource source)) + in + check_source (Some cls); + if not (uniform_cond (llp-ind) lvs) then + raise (CoercionError NotUniform); + let clt = + try + get_target tg ind + with Not_found -> + raise (CoercionError NoTarget) + in + check_target clt target; + try_add_class cls None false; + try_add_class clt None false; + let stre' = get_strength stre coef cls clt in + declare_coercion coef vj stre' isid cls clt (List.length lvs) + +let try_add_new_coercion_core ref b c d e = + try add_new_coercion_core ref b c d e + with CoercionError e -> + errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e) + +let try_add_new_coercion ref stre = + try_add_new_coercion_core ref stre None None false + +let try_add_new_coercion_subclass cl stre = + let coe_ref = build_id_coercion None cl in + try_add_new_coercion_core coe_ref stre (Some cl) None true + +let try_add_new_coercion_with_target ref stre ~source ~target = + try_add_new_coercion_core ref stre (Some source) (Some target) false + +let try_add_new_identity_coercion id stre ~source ~target = + let ref = build_id_coercion (Some id) source in + try_add_new_coercion_core ref stre (Some source) (Some target) true + +let try_add_new_coercion_with_source ref stre ~source = + try_add_new_coercion_core ref stre (Some source) None false + +let add_coercion_hook stre ref = + try_add_new_coercion ref stre; + Options.if_verbose message + (string_of_qualid (shortest_qualid_of_global Idset.empty ref) + ^ " is now a coercion") + +let add_subclass_hook stre ref = + let cl = class_of_ref ref in + try_add_new_coercion_subclass cl stre + +(* try_add_new_class : global_reference -> strength -> unit *) + +let class_of_global = function + | VarRef sp -> CL_SECVAR sp + | ConstRef sp -> CL_CONST sp + | IndRef sp -> CL_IND sp + | ConstructRef _ as ref -> raise (CoercionError (NotAClass ref)) + +let try_add_new_class ref stre = + try try_add_class (class_of_global ref) (Some stre) true + with CoercionError e -> + errorlabstrm "try_add_new_class" (explain_coercion_error ref e) + +(* fonctions pour le discharge: encore un peu sale mais ça s'améliore *) + +type coercion_entry = + global_reference * strength * bool * cl_typ * cl_typ * int + +let add_new_coercion (ref,stre,isid,cls,clt,n) = + (* Un peu lourd, tout cela pour trouver l'instance *) + let env = Global.env () in + let v = constr_of_reference ref in + let vj = Retyping.get_judgment_of env Evd.empty v in + declare_coercion ref vj stre isid cls clt n + +let count_extra_abstractions hyps ids_to_discard = + let _,n = + List.fold_left + (fun (hyps,n as sofar) id -> + match hyps with + | (hyp,None,_)::rest when id = hyp ->(rest, n+1) + | _ -> sofar) + (hyps,0) ids_to_discard + in n + +let defined_in_sec kn olddir = + let _,dir,_ = repr_kn kn in + dir = olddir + +(* This moves the global path one step below *) +let process_global olddir = function + | VarRef _ -> + anomaly "process_global only processes global surviving the section" + | ConstRef kn as x -> + if defined_in_sec kn olddir then + let newkn = Lib.make_kn (id_of_label (label kn)) in + ConstRef newkn + else x + | IndRef (kn,i) as x -> + if defined_in_sec kn olddir then + let newkn = Lib.make_kn (id_of_label (label kn)) in + IndRef (newkn,i) + else x + | ConstructRef ((kn,i),j) as x -> + if defined_in_sec kn olddir then + let newkn = Lib.make_kn (id_of_label (label kn)) in + ConstructRef ((newkn,i),j) + else x + +let process_class olddir ids_to_discard x = + let (cl,{cl_strength=stre; cl_param=p}) = x in +(* let env = Global.env () in*) + match cl with + | CL_SECVAR _ -> x + | CL_CONST kn -> + if defined_in_sec kn olddir then + let newkn = Lib.make_kn (id_of_label (label kn)) in + let hyps = (Global.lookup_constant kn).const_hyps in + let n = count_extra_abstractions hyps ids_to_discard in + (CL_CONST newkn,{cl_strength=stre;cl_param=p+n}) + else + x + | CL_IND (kn,i) -> + if defined_in_sec kn olddir then + let newkn = Lib.make_kn (id_of_label (label kn)) in + let hyps = (Global.lookup_mind kn).mind_hyps in + let n = count_extra_abstractions hyps ids_to_discard in + (CL_IND (newkn,i),{cl_strength=stre;cl_param=p+n}) + else + x + | _ -> anomaly "process_class" + +let process_cl sec_sp cl = + match cl with + | CL_SECVAR id -> cl + | CL_CONST kn -> + if defined_in_sec kn sec_sp then + let newkn = Lib.make_kn (id_of_label (label kn)) in + CL_CONST newkn + else + cl + | CL_IND (kn,i) -> + if defined_in_sec kn sec_sp then + let newkn = Lib.make_kn (id_of_label (label kn)) in + CL_IND (newkn,i) + else + cl + | _ -> cl + +let process_coercion olddir ids_to_discard (coe,coeinfo,cls,clt) = + let hyps = context_of_global_reference coe in + let nargs = count_extra_abstractions hyps ids_to_discard in + (process_global olddir coe, + coercion_strength coeinfo, + coercion_identity coeinfo, + process_cl olddir cls, + process_cl olddir clt, + nargs + coercion_params coeinfo) diff --git a/toplevel/class.mli b/toplevel/class.mli new file mode 100644 index 00000000..b0350985 --- /dev/null +++ b/toplevel/class.mli @@ -0,0 +1,68 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: class.mli,v 1.17.6.1 2004/07/16 19:31:47 herbelin Exp $ i*) + +(*i*) +open Names +open Term +open Classops +open Declare +open Libnames +open Decl_kinds +open Nametab +(*i*) + +(* Classes and coercions. *) + +(* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion + from [src] to [tg] *) +val try_add_new_coercion_with_target : global_reference -> strength -> + source:cl_typ -> target:cl_typ -> unit + +(* [try_add_new_coercion ref s] declares [ref], assumed to be of type + [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) +val try_add_new_coercion : global_reference -> strength -> unit + +(* [try_add_new_coercion_subclass cst s] expects that [cst] denotes a + transparent constant which unfolds to some class [tg]; it declares + an identity coercion from [cst] to [tg], named something like + ["Id_cst_tg"] *) +val try_add_new_coercion_subclass : cl_typ -> strength -> unit + +(* [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion + from [src] to [tg] where the target is inferred from the type of [ref] *) +val try_add_new_coercion_with_source : global_reference -> strength -> + source:cl_typ -> unit + +(* [try_add_new_identity_coercion id s src tg] enriches the + environment with a new definition of name [id] declared as an + identity coercion from [src] to [tg] *) +val try_add_new_identity_coercion : identifier -> strength -> + source:cl_typ -> target:cl_typ -> unit + +val add_coercion_hook : Tacexpr.declaration_hook + +val add_subclass_hook : Tacexpr.declaration_hook + +(* [try_add_new_class ref] declares [ref] as a new class; usually, + this is done implicitely by [try_add_new_coercion]'s functions *) +val try_add_new_class : global_reference -> strength -> unit + +(*s This is used for the discharge *) +type coercion_entry + +val add_new_coercion : coercion_entry -> unit + +val process_class : + dir_path -> identifier list -> + (cl_typ * cl_info_typ) -> (cl_typ * cl_info_typ) +val process_coercion : + dir_path -> identifier list -> coercion -> coercion_entry + +val class_of_ref : global_reference -> cl_typ diff --git a/toplevel/command.ml b/toplevel/command.ml new file mode 100644 index 00000000..b9a47781 --- /dev/null +++ b/toplevel/command.ml @@ -0,0 +1,701 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: command.ml,v 1.116.2.1 2004/07/16 19:31:47 herbelin Exp $ *) + +open Pp +open Util +open Options +open Term +open Termops +open Declarations +open Entries +open Inductive +open Environ +open Reduction +open Tacred +open Declare +open Nametab +open Names +open Libnames +open Nameops +open Topconstr +open Library +open Libobject +open Constrintern +open Proof_type +open Tacmach +open Safe_typing +open Nametab +open Typeops +open Indtypes +open Vernacexpr +open Decl_kinds +open Pretyping +open Symbols + +let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b)) +let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b)) + +let rec abstract_rawconstr c = function + | [] -> c + | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_rawconstr c bl) + | LocalRawAssum (idl,t)::bl -> + List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl + (abstract_rawconstr c bl) + +let rec prod_rawconstr c = function + | [] -> c + | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_rawconstr c bl) + | LocalRawAssum (idl,t)::bl -> + List.fold_right (fun x b -> mkProdC([x],t,b)) idl + (prod_rawconstr c bl) + +let rec destSubCast c = match kind_of_term c with + | Lambda (x,t,c) -> + let (b,u) = destSubCast c in mkLambda (x,t,b), mkProd (x,t,u) + | LetIn (x,b,t,c) -> + let (d,u) = destSubCast c in mkLetIn (x,b,t,d), mkLetIn (x,b,t,u) + | Cast (b,u) -> (b,u) + | _ -> assert false + +let rec adjust_conclusion a cs = function + | CProdN (loc,bl,c) -> CProdN (loc,bl,adjust_conclusion a cs c) + | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,adjust_conclusion a cs c) + | CHole loc -> + let (nar,name,params) = a in + if nar <> 0 then + user_err_loc (loc,"", + str "Cannot infer the non constant arguments of the conclusion of " + ++ pr_id cs); + let args = List.map (fun id -> CRef(Ident(loc,id))) params in + CAppExpl (loc,(None,Ident(loc,name)),List.rev args) + | c -> c + +(* Commands of the interface *) + +(* 1| Constant definitions *) + +let definition_message id = + if_verbose message ((string_of_id id) ^ " is defined") + +let constant_entry_of_com (bl,com,comtypopt,opacity) = + let sigma = Evd.empty in + let env = Global.env() in + match comtypopt with + None -> + let b = abstract_rawconstr com bl in + let j = judgment_of_rawconstr sigma env b in + { const_entry_body = j.uj_val; + const_entry_type = Some (Evarutil.refresh_universes j.uj_type); + const_entry_opaque = opacity } + | Some comtyp -> + (* We use a cast to avoid troubles with evars in comtyp *) + (* that can only be resolved knowing com *) + let b = abstract_rawconstr (mkCastC (com,comtyp)) bl in + let (body,typ) = destSubCast (interp_constr sigma env b) in + { const_entry_body = body; + const_entry_type = Some typ; + const_entry_opaque = opacity } + +let red_constant_entry ce = function + | None -> ce + | Some red -> + let body = ce.const_entry_body in + { ce with const_entry_body = + reduction_of_redexp red (Global.env()) Evd.empty body } + +let declare_global_definition ident ce local = + let (_,kn) = declare_constant ident (DefinitionEntry ce,IsDefinition) in + if local = Local then + msg_warning (pr_id ident ++ str" is declared as a global definition"); + definition_message ident; + ConstRef kn + +let declare_definition ident (local,_) bl red_option c typopt hook = + let ce = constant_entry_of_com (bl,c,typopt,false) in + if bl<>[] && red_option <> None then + error "Evaluation under a local context not supported"; + let ce' = red_constant_entry ce red_option in + let r = match local with + | Local when Lib.sections_are_opened () -> + let c = + SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in + let _ = declare_variable ident (Lib.cwd(), c, IsDefinition) in + definition_message ident; + if Pfedit.refining () then + msgerrnl (str"Warning: Local definition " ++ pr_id ident ++ + str" is not visible from current goals"); + VarRef ident + | (Global|Local) -> + declare_global_definition ident ce' local in + hook local r + +let syntax_definition ident c local onlyparse = + let c = snd (interp_aconstr [] [] c) in + let onlyparse = !Options.v7_only or onlyparse in + Syntax_def.declare_syntactic_definition local ident onlyparse c + +(* 2| Variable/Hypothesis/Parameter/Axiom declarations *) + +let assumption_message id = + if_verbose message ((string_of_id id) ^ " is assumed") + +let declare_one_assumption is_coe (local,kind) c (_,ident) = + let r = match local with + | Local when Lib.sections_are_opened () -> + let r = + declare_variable ident + (Lib.cwd(), SectionLocalAssum c, IsAssumption kind) in + assumption_message ident; + if is_verbose () & Pfedit.refining () then + msgerrnl (str"Warning: Variable " ++ pr_id ident ++ + str" is not visible from current goals"); + VarRef ident + | (Global|Local) -> + let (_,kn) = + declare_constant ident (ParameterEntry c, IsAssumption kind) in + assumption_message ident; + if local=Local & Options.is_verbose () then + msg_warning (pr_id ident ++ str" is declared as a parameter" ++ + str" because it is at a global level"); + ConstRef kn in + if is_coe then Class.try_add_new_coercion r local + +let declare_assumption idl is_coe k bl c = + let c = prod_rawconstr c bl in + let c = interp_type Evd.empty (Global.env()) c in + List.iter (declare_one_assumption is_coe k c) idl + +(* 3a| Elimination schemes for mutual inductive definitions *) + +open Indrec + +let non_type_eliminations = + [ (InProp,elimination_suffix InProp); + (InSet,elimination_suffix InSet) ] + +let declare_one_elimination ind = + let (mib,mip) = Global.lookup_inductive ind in + let mindstr = string_of_id mip.mind_typename in + let declare s c t = + let id = id_of_string s in + let kn = Declare.declare_internal_constant id + (DefinitionEntry + { const_entry_body = c; + const_entry_type = t; + const_entry_opaque = false }, + Decl_kinds.IsDefinition) in + definition_message id; + kn + in + let env = Global.env () in + let sigma = Evd.empty in + let elim_scheme = Indrec.build_indrec env sigma ind in + let npars = mip.mind_nparams in + let make_elim s = Indrec.instanciate_indrec_scheme s npars elim_scheme in + let kelim = mip.mind_kelim in + (* in case the inductive has a type elimination, generates only one + induction scheme, the other ones share the same code with the + apropriate type *) + if List.mem InType kelim then + let elim = make_elim (new_sort_in_family InType) in + let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in + let c = mkConst (snd cte) and t = constant_type (Global.env()) (snd cte) in + List.iter (fun (sort,suff) -> + let (t',c') = + Indrec.instanciate_type_indrec_scheme (new_sort_in_family sort) + npars c t in + let _ = declare (mindstr^suff) c' (Some t') in ()) + non_type_eliminations + else (* Impredicative or logical inductive definition *) + List.iter + (fun (sort,suff) -> + if List.mem sort kelim then + let elim = make_elim (new_sort_in_family sort) in + let _ = declare (mindstr^suff) elim None in ()) + non_type_eliminations + +let declare_eliminations sp = + let mib = Global.lookup_mind sp in + if mib.mind_finite then + for i = 0 to Array.length mib.mind_packets - 1 do + declare_one_elimination (sp,i) + done + +(* 3b| Mutual Inductive definitions *) + +let minductive_message = function + | [] -> error "no inductive definition" + | [x] -> (pr_id x ++ str " is defined") + | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ + spc () ++ str "are defined") + +let recursive_message v = + match Array.length v with + | 0 -> error "no recursive definition" + | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are recursively defined") + +let corecursive_message v = + match Array.length v with + | 0 -> error "no corecursive definition" + | 1 -> (Printer.pr_global v.(0) ++ str " is corecursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are corecursively defined") + +let interp_mutual lparams lnamearconstrs finite = + let allnames = + List.fold_left (fun acc (id,_,_,l) -> id::(List.map fst l)@acc) + [] lnamearconstrs in + if not (list_distinct allnames) then + error "Two inductive objects have the same name"; + let nparams = local_binders_length lparams + and sigma = Evd.empty + and env0 = Global.env() in + let env_params, params = + List.fold_left + (fun (env, params) d -> match d with + | LocalRawAssum ([_,na],(CHole _ as t)) -> + let t = interp_binder sigma env na t in + let d = (na,None,t) in + (push_rel d env, d::params) + | LocalRawAssum (nal,t) -> + let t = interp_type sigma env t in + let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in + let ctx = List.rev ctx in + (push_rel_context ctx env, ctx@params) + | LocalRawDef ((_,na),c) -> + let c = judgment_of_rawconstr sigma env c in + let d = (na, Some c.uj_val, c.uj_type) in + (push_rel d env,d::params)) + (env0,[]) lparams + in + (* Builds the params of the inductive entry *) + let params' = + List.map (fun (na,b,t) -> + let id = match na with + | Name id -> id + | Anonymous -> anomaly "Unnamed inductive variable" in + match b with + | None -> (id, LocalAssum t) + | Some b -> (id, LocalDef b)) params + in + let paramassums = + List.fold_right (fun d l -> match d with + (id,LocalAssum _) -> id::l | (_,LocalDef _) -> l) params' [] in + let indnames = + List.map (fun (id,_,_,_)-> id) lnamearconstrs @ paramassums in + let nparamassums = List.length paramassums in + let (ind_env,ind_impls,arityl) = + List.fold_left + (fun (env, ind_impls, arl) (recname, _, arityc, _) -> + let arity = interp_type sigma env_params arityc in + let fullarity = it_mkProd_or_LetIn arity params in + let env' = Termops.push_rel_assum (Name recname,fullarity) env in + let argsc = compute_arguments_scope fullarity in + let ind_impls' = + if Impargs.is_implicit_args() then + let impl = Impargs.compute_implicits false env_params fullarity in + let paramimpl,_ = list_chop nparamassums impl in + let l = List.fold_right + (fun imp l -> if Impargs.is_status_implicit imp then + Impargs.name_of_implicit imp::l else l) paramimpl [] in + (recname,(l,impl,argsc))::ind_impls + else + (recname,([],[],argsc))::ind_impls in + (env', ind_impls', (arity::arl))) + (env0, [], []) lnamearconstrs + in + (* Names of parameters as arguments of the inductive type (defs removed) *) + let lparargs = + List.flatten + (List.map (function (id,LocalAssum _) -> [id] | _ -> []) params') in + let notations = + List.fold_right (fun (_,ntnopt,_,_) l -> option_cons ntnopt l) + lnamearconstrs [] in + let fs = States.freeze() in + (* Declare the notations for the inductive types pushed in local context*) + try + List.iter (fun (df,c,scope) -> (* No scope for tmp notation *) + Metasyntax.add_notation_interpretation df ind_impls c None) notations; + let ind_env_params = push_rel_context params ind_env in + + let mispecvec = + List.map2 + (fun ar (name,_,_,lname_constr) -> + let constrnames, bodies = List.split lname_constr in + (* Compute the conclusions of constructor types *) + (* for inductive given in ML syntax *) + let nar = + List.length (fst (Reductionops.splay_arity env_params Evd.empty ar)) + in + let bodies = + List.map2 (adjust_conclusion (nar,name,lparargs)) + constrnames bodies + in + + (* Interpret the constructor types *) + let constrs = + List.map + (interp_type_with_implicits sigma ind_env_params + (paramassums,ind_impls)) + bodies + in + + (* Build the inductive entry *) + { mind_entry_params = params'; + mind_entry_typename = name; + mind_entry_arity = ar; + mind_entry_consnames = constrnames; + mind_entry_lc = constrs }) + (List.rev arityl) lnamearconstrs + in + States.unfreeze fs; + notations, { mind_entry_finite = finite; mind_entry_inds = mispecvec } + with e -> States.unfreeze fs; raise e + +let declare_mutual_with_eliminations isrecord mie = + let lrecnames = + List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in + let (_,kn) = declare_mind isrecord mie in + if_verbose ppnl (minductive_message lrecnames); + declare_eliminations kn; + kn + +(* Very syntactical equality *) +let eq_la d1 d2 = match d1,d2 with + | LocalRawAssum (nal,ast), LocalRawAssum (nal',ast') -> + List.for_all2 (fun (_,na) (_,na') -> na = na') nal nal' + & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false) + | LocalRawDef ((_,id),ast), LocalRawDef ((_,id'),ast') -> + id=id' & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false) + | _ -> false + +let extract_coe lc = + List.fold_right + (fun (addcoe,((_,(id:identifier)),t)) (l1,l2) -> + ((if addcoe then id::l1 else l1), (id,t)::l2)) lc ([],[]) + +let extract_coe_la_lc = function + | [] -> anomaly "Vernacentries: empty list of inductive types" + | ((_,id),ntn,la,ar,lc)::rest -> + let rec check = function + | [] -> [],[] + | ((_,id),ntn,la',ar,lc)::rest -> + if (List.length la = List.length la') && + (List.for_all2 eq_la la la') + then + let mcoes, mspec = check rest in + let coes, lc' = extract_coe lc in + (coes::mcoes,(id,ntn,ar,lc')::mspec) + else + error ("Parameters should be syntactically the same "^ + "for each inductive type") + in + let mcoes, mspec = check rest in + let coes, lc' = extract_coe lc in + (coes,la,(id,ntn,ar,lc'):: mspec) + +let build_mutual lind finite = + let ((coes:identifier list),lparams,lnamearconstructs) = extract_coe_la_lc lind in + let notations,mie = interp_mutual lparams lnamearconstructs finite in + let kn = declare_mutual_with_eliminations false mie in + (* Declare the notations now bound to the inductive types *) + List.iter (fun (df,c,scope) -> + Metasyntax.add_notation_interpretation df [] c scope) notations; + List.iter + (fun id -> + Class.try_add_new_coercion (locate (make_short_qualid id)) Global) coes + +(* try to find non recursive definitions *) + +let list_chop_hd i l = match list_chop i l with + | (l1,x::l2) -> (l1,x,l2) + | _ -> assert false + +let collect_non_rec env = + let rec searchrec lnonrec lnamerec ldefrec larrec nrec = + try + let i = + list_try_find_i + (fun i f -> + if List.for_all (fun def -> not (occur_var env f def)) ldefrec + then i else failwith "try_find_i") + 0 lnamerec + in + let (lf1,f,lf2) = list_chop_hd i lnamerec in + let (ldef1,def,ldef2) = list_chop_hd i ldefrec in + let (lar1,ar,lar2) = list_chop_hd i larrec in + let newlnv = + try + match list_chop i nrec with + | (lnv1,_::lnv2) -> (lnv1@lnv2) + | _ -> [] (* nrec=[] for cofixpoints *) + with Failure "list_chop" -> [] + in + searchrec ((f,def,ar)::lnonrec) + (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv + with Failure "try_find_i" -> + (List.rev lnonrec, + (Array.of_list lnamerec, Array.of_list ldefrec, + Array.of_list larrec, Array.of_list nrec)) + in + searchrec [] + +let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list) = + let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef + and sigma = Evd.empty + and env0 = Global.env() + and nv = Array.of_list (List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef) in + (* Build the recursive context and notations for the recursive types *) + let (rec_sign,rec_impls,arityl) = + List.fold_left + (fun (env,impls,arl) ((recname,_,bl,arityc,_),_) -> + let arityc = prod_rawconstr arityc bl in + let arity = interp_type sigma env0 arityc in + let impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits false env0 arity + else [] in + let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in + (Environ.push_named (recname,None,arity) env, impls', arity::arl)) + (env0,[],[]) lnameargsardef in + let arityl = List.rev arityl in + let notations = + List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) + lnameargsardef [] in + + let recdef = + + (* Declare local notations *) + let fs = States.freeze() in + let def = + try + List.iter (fun (df,c,scope) -> (* No scope for tmp notation *) + Metasyntax.add_notation_interpretation df [] c None) notations; + List.map2 + (fun ((_,_,bl,_,def),_) arity -> + let def = abstract_rawconstr def bl in + interp_casted_constr_with_implicits + sigma rec_sign rec_impls def arity) + lnameargsardef arityl + with e -> + States.unfreeze fs; raise e in + States.unfreeze fs; def + in + + let (lnonrec,(namerec,defrec,arrec,nvrec)) = + collect_non_rec env0 lrecnames recdef arityl (Array.to_list nv) in + let recvec = + Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in + let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in + let rec declare i fi = + let ce = + { const_entry_body = mkFix ((nvrec,i),recdecls); + const_entry_type = Some arrec.(i); + const_entry_opaque = false } in + let (_,kn) = declare_constant fi (DefinitionEntry ce, IsDefinition) in + (ConstRef kn) + in + (* declare the recursive definitions *) + let lrefrec = Array.mapi declare namerec in + if_verbose ppnl (recursive_message lrefrec); + (* The others are declared as normal definitions *) + let var_subst id = (id, global_reference id) in + let _ = + List.fold_left + (fun subst (f,def,t) -> + let ce = { const_entry_body = replace_vars subst def; + const_entry_type = Some t; + const_entry_opaque = false } in + let _ = declare_constant f (DefinitionEntry ce, IsDefinition) in + warning ((string_of_id f)^" is non-recursively defined"); + (var_subst f) :: subst) + (List.map var_subst (Array.to_list namerec)) + lnonrec + in + List.iter (fun (df,c,scope) -> + Metasyntax.add_notation_interpretation df [] c scope) notations + +let build_corecursive lnameardef = + let lrecnames = List.map (fun (f,_,_,_) -> f) lnameardef + and sigma = Evd.empty + and env0 = Global.env() in + let fs = States.freeze() in + let (rec_sign,arityl) = + try + List.fold_left + (fun (env,arl) (recname,bl,arityc,_) -> + let arityc = prod_rawconstr arityc bl in + let arj = type_judgment_of_rawconstr Evd.empty env0 arityc in + let arity = arj.utj_val in + let _ = declare_variable recname + (Lib.cwd(),SectionLocalAssum arj.utj_val,IsAssumption Definitional) in + (Environ.push_named (recname,None,arity) env, (arity::arl))) + (env0,[]) lnameardef + with e -> + States.unfreeze fs; raise e in + let arityl = List.rev arityl in + let recdef = + try + List.map (fun (_,bl,arityc,def) -> + let arityc = prod_rawconstr arityc bl in + let def = abstract_rawconstr def bl in + let arity = interp_constr sigma rec_sign arityc in + interp_casted_constr sigma rec_sign def arity) + lnameardef + with e -> + States.unfreeze fs; raise e + in + States.unfreeze fs; + let (lnonrec,(namerec,defrec,arrec,_)) = + collect_non_rec env0 lrecnames recdef arityl [] in + let recvec = + Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in + let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in + let rec declare i fi = + let ce = + { const_entry_body = mkCoFix (i, recdecls); + const_entry_type = Some (arrec.(i)); + const_entry_opaque = false } + in + let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in + (ConstRef kn) + in + let lrefrec = Array.mapi declare namerec in + if_verbose ppnl (corecursive_message lrefrec); + let var_subst id = (id, global_reference id) in + let _ = + List.fold_left + (fun subst (f,def,t) -> + let ce = { const_entry_body = replace_vars subst def; + const_entry_type = Some t; + const_entry_opaque = false } in + let _ = declare_constant f (DefinitionEntry ce,IsDefinition) in + warning ((string_of_id f)^" is non-recursively defined"); + (var_subst f) :: subst) + (List.map var_subst (Array.to_list namerec)) + lnonrec + in () + +let build_scheme lnamedepindsort = + let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort + and sigma = Evd.empty + and env0 = Global.env() in + let lrecspec = + List.map + (fun (_,dep,indid,sort) -> + let ind = Nametab.global_inductive indid in + let (mib,mip) = Global.lookup_inductive ind in + (ind,mib,mip,dep,interp_elimination_sort sort)) + lnamedepindsort + in + let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in + let rec declare decl fi lrecref = + let decltype = Retyping.get_type_of env0 Evd.empty decl in + let decltype = Evarutil.refresh_universes decltype in + let ce = { const_entry_body = decl; + const_entry_type = Some decltype; + const_entry_opaque = false } in + let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in + ConstRef kn :: lrecref + in + let lrecref = List.fold_right2 declare listdecl lrecnames [] in + if_verbose ppnl (recursive_message (Array.of_list lrecref)) + +let rec generalize_rawconstr c = function + | [] -> c + | LocalRawDef (id,b)::bl -> mkLetInC(id,b,generalize_rawconstr c bl) + | LocalRawAssum (idl,t)::bl -> + List.fold_right (fun x b -> mkProdC([x],t,b)) idl + (generalize_rawconstr c bl) + +let start_proof id kind c hook = + let sign = Global.named_context () in + let sign = clear_proofs sign in + Pfedit.start_proof id kind sign c hook + +let start_proof_com sopt kind (bl,t) hook = + let id = match sopt with + | Some id -> + (* We check existence here: it's a bit late at Qed time *) + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + errorlabstrm "start_proof" (pr_id id ++ str " already exists"); + id + | None -> + next_global_ident_away false (id_of_string "Unnamed_thm") + (Pfedit.get_all_proof_names ()) + in + let env = Global.env () in + let c = interp_type Evd.empty env (generalize_rawconstr t bl) in + let _ = Typeops.infer_type env c in + start_proof id kind c hook + +let save id const kind hook = + let {const_entry_body = pft; + const_entry_type = tpo; + const_entry_opaque = opacity } = const in + let l,r = match kind with + | IsLocal when Lib.sections_are_opened () -> + let c = SectionLocalDef (pft, tpo, opacity) in + let _ = declare_variable id (Lib.cwd(), c, IsDefinition) in + (Local, VarRef id) + | IsLocal -> + let k = IsDefinition in + let _,kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) + | IsGlobal k -> + let k = theorem_kind_of_goal_kind k in + let _,kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) in + hook l r; + Pfedit.delete_current_proof (); + definition_message id + +let save_named opacity = + let id,(const,persistence,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + save id const persistence hook + +let check_anonymity id save_ident = + if atompart_of_id id <> "Unnamed_thm" then + error "This command can only be used for unnamed theorem" +(* + message("Overriding name "^(string_of_id id)^" and using "^save_ident) +*) + +let save_anonymous opacity save_ident = + let id,(const,persistence,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + save save_ident const persistence hook + +let save_anonymous_with_strength kind opacity save_ident = + let id,(const,_,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + (* we consider that non opaque behaves as local for discharge *) + save save_ident const (IsGlobal (Proof kind)) hook + +let admit () = + let (id,k,typ,hook) = Pfedit.current_proof_statement () in +(* Contraire aux besoins d'interactivité... + if k <> IsGlobal (Proof Conjecture) then + error "Only statements declared as conjecture can be admitted"; +*) + let (_,kn) = declare_constant id (ParameterEntry typ, IsConjecture) in + hook Global (ConstRef kn); + Pfedit.delete_current_proof (); + assumption_message id + +let get_current_context () = + try Pfedit.get_current_goal_context () + with e when Logic.catchable_exception e -> + (Evd.empty, Global.env()) diff --git a/toplevel/command.mli b/toplevel/command.mli new file mode 100644 index 00000000..7997288c --- /dev/null +++ b/toplevel/command.mli @@ -0,0 +1,85 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: command.mli,v 1.38.2.1 2004/07/16 19:31:47 herbelin Exp $ i*) + +(*i*) +open Util +open Names +open Term +open Nametab +open Declare +open Library +open Libnames +open Nametab +open Tacexpr +open Vernacexpr +open Rawterm +open Topconstr +open Decl_kinds +(*i*) + +(*s Declaration functions. The following functions take ASTs, + transform them into [constr] and then call the corresponding + functions of [Declare]; they return an absolute reference to the + defined object *) + +val declare_definition : identifier -> definition_kind -> + local_binder list -> Tacred.red_expr option -> constr_expr -> + constr_expr option -> declaration_hook -> unit + +val syntax_definition : identifier -> constr_expr -> bool -> bool -> unit + +val declare_assumption : identifier located list -> + coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> unit + +val build_mutual : inductive_expr list -> bool -> unit + +val declare_mutual_with_eliminations : + bool -> Entries.mutual_inductive_entry -> mutual_inductive + +val build_recursive : (fixpoint_expr * decl_notation) list -> unit + +val build_corecursive : cofixpoint_expr list -> unit + +val build_scheme : (identifier located * bool * reference * rawsort) list -> unit + +val generalize_rawconstr : constr_expr -> local_binder list -> constr_expr + +val start_proof : identifier -> goal_kind -> constr -> + declaration_hook -> unit + +val start_proof_com : identifier option -> goal_kind -> + (local_binder list * constr_expr) -> declaration_hook -> unit + +(*s [save_named b] saves the current completed proof under the name it +was started; boolean [b] tells if the theorem is declared opaque; it +fails if the proof is not completed *) + +val save_named : bool -> unit + +(* [save_anonymous b name] behaves as [save_named] but declares the theorem +under the name [name] and respects the strength of the declaration *) + +val save_anonymous : bool -> identifier -> unit + +(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but + declares the theorem under the name [name] and gives it the + strength [strength] *) + +val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit + +(* [admit ()] aborts the current goal and save it as an assmumption *) + +val admit : unit -> unit + +(* [get_current_context ()] returns the evar context and env of the + current open proof if any, otherwise returns the empty evar context + and the current global env *) + +val get_current_context : unit -> Evd.evar_map * Environ.env diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml new file mode 100644 index 00000000..4a4f7828 --- /dev/null +++ b/toplevel/coqinit.ml @@ -0,0 +1,115 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: coqinit.ml,v 1.30.2.1 2004/07/16 19:31:47 herbelin Exp $ *) + +open Pp +open System +open Toplevel + +let (/) = Filename.concat + +let set_debug () = Options.debug := true + +(* Loading of the ressource file. + rcfile is either $HOME/.coqrc.VERSION, or $HOME/.coqrc if the first one + does not exist. *) + +let rcfile = ref (home/".coqrc") +let rcfile_specified = ref false +let set_rcfile s = rcfile := s; rcfile_specified := true +let set_rcuser s = rcfile := ("~"^s)/".coqrc" + +let load_rc = ref true +let no_load_rc () = load_rc := false + +let load_rcfile() = + if !load_rc then + try + if !rcfile_specified then + if file_readable_p !rcfile then + Vernac.load_vernac false !rcfile + else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) + else if file_readable_p (!rcfile^"."^Coq_config.version) then + Vernac.load_vernac false (!rcfile^"."^Coq_config.version) + else if file_readable_p !rcfile then + Vernac.load_vernac false !rcfile + else () + (* + Options.if_verbose + mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^ + " found. Skipping rcfile loading.")) + *) + with e -> + (msgnl (str"Load of rcfile failed."); + raise e) + else + Options.if_verbose msgnl (str"Skipping rcfile loading.") + +let add_ml_include s = + Mltop.add_ml_dir s + +(* Puts dir in the path of ML and in the LoadPath *) +let coq_add_path s = Mltop.add_path s (Names.make_dirpath [Nameops.coq_root]) +let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root]) + +(* By the option -include -I or -R of the command line *) +let includes = ref [] +let push_include (s, alias) = includes := (s,alias,false) :: !includes +let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes + +(* Because find puts "./" and the loadpath is not nicely pretty-printed *) +let hm2 s = + let n = String.length s in + if n > 1 && s.[0] = '.' && s.[1] = '/' then String.sub s 2 (n-2) else s + +let getenv_else s dft = try Sys.getenv s with Not_found -> dft + +(* Initializes the LoadPath according to COQLIB and Coq_config *) +let init_load_path () = + (* developper specific directories to open *) + let dev = if Coq_config.local then [ "dev" ] else [] in + let coqlib = + if Coq_config.local || !Options.boot then Coq_config.coqtop + (* variable COQLIB overrides the default library *) + else getenv_else "COQLIB" Coq_config.coqlib in + (* first user-contrib *) + let user_contrib = coqlib/"user-contrib" in + if Sys.file_exists user_contrib then + Mltop.add_path user_contrib Nameops.default_root_prefix; + (* then standard library *) + let vdirs = + if !Options.v7 then [ "theories7"; "contrib7" ] + else [ "theories"; "contrib" ] in + let dirs = + (if !Options.v7 then "states7" else "states") :: dev @ vdirs in + List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; + let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in + add_ml_include camlp4; + (* then current directory *) + Mltop.add_path "." Nameops.default_root_prefix; + (* additional loadpath, given with -I -include -R options *) + List.iter + (fun (s,alias,reci) -> + if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) + (List.rev !includes) +let init_library_roots () = + includes := [] + +(* Initialises the Ocaml toplevel before launching it, so that it can + find the "include" file in the *source* directory *) +(* We only assume that the variable COQTOP is set *) +let init_ocaml_path () = + let coqtop = getenv_else "COQTOP" Coq_config.coqtop in + let add_subdir dl = + Mltop.add_ml_dir (List.fold_left (/) coqtop dl) + in + List.iter add_subdir + [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; + [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; + [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli new file mode 100644 index 00000000..e029d8ac --- /dev/null +++ b/toplevel/coqinit.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: coqinit.mli,v 1.7.16.1 2004/07/16 19:31:47 herbelin Exp $ i*) + +(* Initialization. *) + +val set_debug : unit -> unit + +val set_rcfile : string -> unit +val set_rcuser : string -> unit + +val no_load_rc : unit -> unit +val load_rcfile : unit -> unit + +val push_include : string * Names.dir_path -> unit +val push_rec_include : string * Names.dir_path -> unit + +val init_load_path : unit -> unit +val init_library_roots : unit -> unit + +val init_ocaml_path : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml new file mode 100644 index 00000000..aa765b16 --- /dev/null +++ b/toplevel/coqtop.ml @@ -0,0 +1,325 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: coqtop.ml,v 1.72.2.3 2004/07/16 19:31:47 herbelin Exp $ *) + +open Pp +open Util +open System +open Options +open Names +open Libnames +open Nameops +open States +open Toplevel +open Coqinit + +let get_version_date () = + try + let ch = open_in (Coq_config.coqtop^"/make.result") in + let l = input_line ch in + let i = String.index l ' ' in + let j = String.index_from l (i+1) ' ' in + "checked out on "^(String.sub l (i+1) (j-i-1)) + with _ -> Coq_config.date + +let print_header () = + Printf.printf "Welcome to Coq %s%s (%s)\n" + Coq_config.version + (if !Options.v7 then " (V7 syntax)" else "") + (get_version_date ()); + flush stdout + +let memory_stat = ref false + +let print_memory_stat () = + if !memory_stat then + Format.printf "total heap size = %d kbytes\n" (heap_size_kb ()) + +let _ = at_exit print_memory_stat + +let engagement = ref None +let set_engagement c = engagement := Some c +let engage () = + match !engagement with Some c -> Global.set_engagement c | None -> () + +let set_batch_mode () = batch_mode := true + +let toplevel_name = ref (make_dirpath [id_of_string "Top"]) +let set_toplevel_name dir = toplevel_name := dir + +let remove_top_ml () = Mltop.remove () + +let inputstate = ref None +let set_inputstate s = inputstate:= Some s +let inputstate () = + match !inputstate with + | Some "" -> () + | Some s -> intern_state s + | None -> intern_state "initial.coq" + +let outputstate = ref "" +let set_outputstate s = outputstate:=s +let outputstate () = if !outputstate <> "" then extern_state !outputstate + +let check_coq_overwriting p = + if string_of_id (List.hd (repr_dirpath p)) = "Coq" then + error "The \"Coq\" logical root directory is reserved for the Coq library" + +let set_include d p = push_include (d,p) +let set_rec_include d p = check_coq_overwriting p; push_rec_include (d,p) +let set_default_include d = set_include d Nameops.default_root_prefix +let set_default_rec_include d = set_rec_include d Nameops.default_root_prefix + +let load_vernacular_list = ref ([] : (string * bool) list) +let add_load_vernacular verb s = + load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list +let load_vernacular () = + List.iter + (fun (s,b) -> + if Options.do_translate () then + with_option translate_file (Vernac.load_vernac b) s + else + Vernac.load_vernac b s) + (List.rev !load_vernacular_list) + +let load_vernacular_obj = ref ([] : string list) +let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj +let load_vernac_obj () = + List.iter Library.read_library_from_file (List.rev !load_vernacular_obj) + +let require_list = ref ([] : string list) +let add_require s = require_list := s :: !require_list +let require () = + List.iter (fun s -> Library.require_library_from_file None None s false) + (List.rev !require_list) + +let compile_list = ref ([] : (bool * string) list) +let add_compile verbose s = + set_batch_mode (); + Options.make_silent true; + compile_list := (verbose,s) :: !compile_list +let compile_files () = + let init_state = States.freeze() in + List.iter + (fun (v,f) -> + States.unfreeze init_state; + if Options.do_translate () then + with_option translate_file (Vernac.compile v) f + else + Vernac.compile v f) + (List.rev !compile_list) + +let re_exec_version = ref "" +let set_byte () = re_exec_version := "byte" +let set_opt () = re_exec_version := "opt" + +(* Re-exec Coq in bytecode or native code if necessary. [s] is either + ["byte"] or ["opt"]. Notice that this is possible since the nature of + the toplevel has already been set in [Mltop] by the main file created + by coqmktop (see scripts/coqmktop.ml). *) + +let re_exec is_ide = + let s = !re_exec_version in + let is_native = (Mltop.get()) = Mltop.Native in + let prog = Sys.argv.(0) in + let coq = Filename.basename prog in + if (is_native && s = "byte") || ((not is_native) && s = "opt") + then begin + let s = if s = "" then if is_native then "opt" else "byte" else s in + let newprog = + let dir = Filename.dirname prog in + let coqtop = if is_ide then "coqide." else "coqtop." in + let com = coqtop ^ s ^ Coq_config.exec_extension in + if dir <> "." then Filename.concat dir com else com + in + Sys.argv.(0) <- newprog; + Unix.handle_unix_error (Unix.execvp newprog) Sys.argv + end + +(*s Parsing of the command line. + We no longer use [Arg.parse], in order to use share [Usage.print_usage] + between coqtop and coqc. *) + +let usage () = + if !batch_mode then + Usage.print_usage_coqc () + else + Usage.print_usage_coqtop () ; + flush stderr ; + exit 1 + +let warning s = msg_warning (str s) + +let ide_args = ref [] +let parse_args is_ide = + let rec parse = function + | [] -> () + + | "-impredicative-set" :: rem -> + set_engagement Environ.ImpredicativeSet; parse rem + + | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem + | ("-I"|"-include") :: [] -> usage () + + | "-R" :: d :: p :: rem ->set_rec_include d (dirpath_of_string p);parse rem + | "-R" :: ([] | [_]) -> usage () + + | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem + | "-top" :: [] -> usage () + + | "-q" :: rem -> no_load_rc (); parse rem + + | "-opt" :: rem -> set_opt(); parse rem + | "-byte" :: rem -> set_byte(); parse rem + | "-full" :: rem -> warning "option -full deprecated\n"; parse rem + + | "-batch" :: rem -> set_batch_mode (); parse rem + | "-boot" :: rem -> boot := true; no_load_rc (); parse rem + | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem + | "-outputstate" :: s :: rem -> set_outputstate s; parse rem + | "-outputstate" :: [] -> usage () + + | "-nois" :: rem -> set_inputstate ""; parse rem + + | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem + | ("-inputstate"|"-is") :: [] -> usage () + + | "-load-ml-object" :: f :: rem -> Mltop.dir_ml_load f; parse rem + | "-load-ml-object" :: [] -> usage () + + | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem + | "-load-ml-source" :: [] -> usage () + + | ("-load-vernac-source"|"-l") :: f :: rem -> + add_load_vernacular false f; parse rem + | ("-load-vernac-source"|"-l") :: [] -> usage () + + | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> + add_load_vernacular true f; parse rem + | ("-load-vernac-source-verbose"|"-lv") :: [] -> usage () + + | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem + | "-load-vernac-object" :: [] -> usage () + + | "-dump-glob" :: f :: rem -> dump_into_file f; parse rem + | "-dump-glob" :: [] -> usage () + + | "-require" :: f :: rem -> add_require f; parse rem + | "-require" :: [] -> usage () + + | "-compile" :: f :: rem -> add_compile false f; parse rem + | "-compile" :: [] -> usage () + + | "-compile-verbose" :: f :: rem -> add_compile true f; parse rem + | "-compile-verbose" :: [] -> usage () + + | "-dont-load-proofs" :: rem -> Options.dont_load_proofs := true; parse rem + + | "-translate" :: rem -> make_translate true; parse rem + + | "-unsafe" :: f :: rem -> add_unsafe f; parse rem + | "-unsafe" :: [] -> usage () + + | "-debug" :: rem -> set_debug (); parse rem + + | "-emacs" :: rem -> Options.print_emacs := true; parse rem + + | "-where" :: _ -> print_endline Coq_config.coqlib; exit 0 + + | ("-quiet"|"-silent") :: rem -> Options.make_silent true; parse rem + + | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () + + | ("-v"|"--version") :: _ -> Usage.version () + + | "-init-file" :: f :: rem -> set_rcfile f; parse rem + | "-init-file" :: [] -> usage () + + | "-user" :: u :: rem -> set_rcuser u; parse rem + | "-user" :: [] -> usage () + + | "-notactics" :: rem -> remove_top_ml (); parse rem + + | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem + + | ("-m" | "--memory") :: rem -> memory_stat := true; parse rem + + | "-xml" :: rem -> Options.xml_export := true; parse rem + + (* Scanned in Options! *) + | "-v7" :: rem -> (* Options.v7 := true; *) parse rem + | "-v8" :: rem -> (* Options.v7 := false; *) parse rem + + (* Translator options *) + | "-strict-implicit" :: rem -> + Options.translate_strict_impargs := false; parse rem + + | s :: rem -> + if is_ide then begin + ide_args := s :: !ide_args; + parse rem + end else begin + prerr_endline ("Don't know what to do with " ^ s); usage () + end + in + try + parse (List.tl (Array.to_list Sys.argv)) + with + | UserError(_,s) as e -> begin + try + Stream.empty s; exit 1 + with Stream.Failure -> + msgnl (Cerrors.explain_exn e); exit 1 + end + | e -> begin msgnl (Cerrors.explain_exn e); exit 1 end + + +(* To prevent from doing the initialization twice *) +let initialized = ref false + +let init is_ide = + if not !initialized then begin + initialized := true; + Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + Lib.init(); + try + parse_args is_ide; + re_exec is_ide; + if_verbose print_header (); + init_load_path (); + inputstate (); + engage (); + if not !batch_mode then Declaremods.start_library !toplevel_name; + init_library_roots (); + load_vernac_obj (); + require (); + load_rcfile(); + load_vernacular (); + compile_files (); + outputstate (); + with e -> + flush_all(); + if not !batch_mode then message "Error during initialization :"; + msgnl (Toplevel.print_toplevel_error e); + exit 1 + end; + if !batch_mode then (flush_all(); Profile.print_profile (); exit 0); + Lib.declare_initial_state () + +let init_ide () = init true; List.rev !ide_args + +let start () = + init false; + Toplevel.loop(); + (* Initialise and launch the Ocaml toplevel *) + Coqinit.init_ocaml_path(); + Mltop.ocaml_toploop(); + exit 1 + +(* [Coqtop.start] will be called by the code produced by coqmktop *) diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli new file mode 100644 index 00000000..ef8b4b37 --- /dev/null +++ b/toplevel/coqtop.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: coqtop.mli,v 1.5.4.1 2004/07/16 19:31:47 herbelin Exp $ i*) + +(* The Coq main module. The following function [start] will parse the + command line, print the banner, initialize the load path, load the input + state, load the files given on the command line, load the ressource file, + produce the output state if any, and finally will launch [Toplevel.loop]. *) + +val start : unit -> unit + +(* [init_ide] is to be used by the Coq IDE. + It does everything [start] does, except launching the toplevel loop. + It returns the list of Coq files given on the command line. *) + +val init_ide : unit -> string list + diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml new file mode 100644 index 00000000..688885b1 --- /dev/null +++ b/toplevel/discharge.ml @@ -0,0 +1,328 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: discharge.ml,v 1.81.2.1 2004/07/16 19:31:48 herbelin Exp $ *) + +open Pp +open Util +open Names +open Nameops +open Sign +open Term +open Declarations +open Entries +open Inductive +open Instantiate +open Reduction +open Cooking +open Typeops +open Libnames +open Libobject +open Lib +open Nametab +open Declare +open Impargs +open Classops +open Class +open Recordops +open Library +open Indtypes +open Nametab +open Decl_kinds + +let recalc_sp dir sp = + let (_,spid) = repr_path sp in Libnames.make_path dir spid + +let recalc_kn dir kn = + let (mp,_,l) = Names.repr_kn kn in + Names.make_kn mp dir l + +let rec find_var id = function + | [] -> false + | (x,b,_)::l -> if x = id then b=None else find_var id l + +let build_abstract_list sec_sp hyps ids_to_discard = + let l1,l2 = + List.split + (List.fold_left + (fun vars id -> + if find_var id hyps then (mkVar id, Libnames.make_path sec_sp id)::vars + else vars) + [] ids_to_discard) in + Array.of_list l1, l2 + +(* Discharge of inductives is done here (while discharge of constants + is done by the kernel for efficiency). *) + +let abstract_inductive sec_sp ids_to_abs hyps inds = + let abstract_one_assum id t inds = + let ntyp = List.length inds in + let new_refs = + list_tabulate (fun k -> applist(mkRel (k+2),[mkRel 1])) ntyp in + let inds' = + List.map + (function (np,tname,arity,cnames,lc) -> + let arity' = mkNamedProd id t arity in + let lc' = + List.map (fun b -> mkNamedProd id t (substl new_refs b)) lc + in + (np,tname,arity',cnames,lc')) + inds + in + inds' in + let abstract_one_def id c inds = + List.map + (function (np,tname,arity,cnames,lc) -> + let arity' = replace_vars [id, c] arity in + let lc' = List.map (replace_vars [id, c]) lc in + (np,tname,arity',cnames,lc')) + inds in + let abstract_once ((hyps,inds,vars) as sofar) id = + match hyps with + | (hyp,None,t as d)::rest when id = hyp -> + let inds' = abstract_one_assum hyp t inds in + (rest, inds', (mkVar id, Libnames.make_path sec_sp id)::vars) + | (hyp,Some b,t as d)::rest when id = hyp -> + let inds' = abstract_one_def hyp b inds in + (rest, inds', vars) + | _ -> sofar in + let (_,inds',vars) = + List.fold_left abstract_once (hyps,inds,[]) ids_to_abs in + let inds'' = + List.map + (fun (nparams,a,arity,c,lc) -> + let nparams' = nparams + (List.length vars) in + let params, short_arity = decompose_prod_n_assum nparams' arity in + let shortlc = + List.map (fun c -> snd (decompose_prod_n_assum nparams' c))lc in + let params' = + List.map + (function + | (Name id,None,p) -> id, Entries.LocalAssum p + | (Name id,Some p,_) -> id, Entries.LocalDef p + | (Anonymous,_,_) -> anomaly"Unnamed inductive local variable") + params in + { mind_entry_params = params'; + mind_entry_typename = a; + mind_entry_arity = short_arity; + mind_entry_consnames = c; + mind_entry_lc = shortlc }) + inds' in + let l1,l2 = List.split vars in + (inds'', Array.of_list l1, l2) + +let process_inductive sec_sp osecsp nsecsp oldenv (ids_to_discard,modlist) mib = + assert (Array.length mib.mind_packets > 0); + let finite = mib.mind_finite in + let inds = + array_map_to_list + (fun mip -> + let nparams = mip.mind_nparams in + let arity = expmod_type modlist mip.mind_user_arity in + let lc = Array.map (expmod_type modlist) mip.mind_user_lc in + (nparams, + mip.mind_typename, + arity, + Array.to_list mip.mind_consnames, + Array.to_list lc)) + mib.mind_packets + in + let hyps = mib.mind_hyps in + let hyps' = + Sign.fold_named_context + (fun (x,b,t) sgn -> + Sign.add_named_decl + (x, option_app (expmod_constr modlist) b,expmod_constr modlist t) + sgn) + mib.mind_hyps ~init:empty_named_context in + let (inds',abs_vars,discharged_hyps ) = + abstract_inductive sec_sp ids_to_discard hyps' inds in + let lmodif_one_mind i = + let nbc = Array.length mib.mind_packets.(i).mind_consnames in + (((osecsp,i), DO_ABSTRACT ((nsecsp,i),abs_vars)), + list_tabulate + (function j -> + let j' = j + 1 in + (((osecsp,i),j'), DO_ABSTRACT (((nsecsp,i),j'),abs_vars))) + nbc) + in + let indmodifs,cstrmodifs = + List.split (list_tabulate lmodif_one_mind mib.mind_ntypes) in + ({ mind_entry_finite = finite; + mind_entry_inds = inds' }, + indmodifs, + List.flatten cstrmodifs, + discharged_hyps) + +(* Discharge messages. *) + +let constant_message id = + Options.if_verbose ppnl (pr_id id ++ str " is discharged.") + +let inductive_message inds = + Options.if_verbose + ppnl + (hov 0 + (match inds with + | [] -> assert false + | [ind] -> + (pr_id ind.mind_entry_typename ++ str " is discharged.") + | l -> + (prlist_with_sep pr_coma + (fun ind -> pr_id ind.mind_entry_typename) l ++ + spc () ++ str "are discharged."))) + +(* Discharge operations for the various objects of the environment. *) + +type opacity = bool + +type discharge_operation = + | Variable of identifier * section_variable_entry * local_kind * + implicits_flags * Dischargedhypsmap.discharged_hyps + | Constant of identifier * recipe * global_kind * constant * + implicits_flags * Dischargedhypsmap.discharged_hyps + | Inductive of mutual_inductive_entry * implicits_flags * + Dischargedhypsmap.discharged_hyps + | Class of cl_typ * cl_info_typ + | Struc of inductive * (unit -> struc_typ) + | Objdef of constant + | Coercion of coercion_entry + | Require of library_reference + | Constraints of Univ.constraints + +(* Main function to traverse the library segment and compute the various + discharge operations. *) + +let process_object oldenv olddir full_olddir newdir +(* {dir -> newdir} {sec_sp -> full_olddir, olddir} *) + (ops,ids_to_discard,(constl,indl,cstrl as work_alist)) ((sp,kn),lobj) = + let tag = object_tag lobj in + match tag with + | "VARIABLE" -> + let ((id,c,t),cst) = get_variable_with_constraints (basename sp) in + (* VARIABLE means local (entry Variable/Hypothesis/Local and are *) + (* always discharged *) + (Constraints cst :: ops, id :: ids_to_discard, work_alist) + + | "CONSTANT" -> + (* CONSTANT means never discharge (though visibility may vary) *) + let kind = constant_kind sp in + let kn = Nametab.locate_constant (qualid_of_sp sp) in + let lab = label kn in + let cb = Environ.lookup_constant kn oldenv in + let imp = is_implicit_constant kn in + let newkn = recalc_kn newdir kn in + let abs_vars,discharged_hyps0 = + build_abstract_list full_olddir cb.const_hyps ids_to_discard in + (* let's add the new discharged hypothesis to those already discharged*) + let discharged_hyps = + discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in + let mods = [ (kn, DO_ABSTRACT(newkn,abs_vars)) ] + in + let r = { d_from = cb; + d_modlist = work_alist; + d_abstract = ids_to_discard } in + let op = Constant (id_of_label lab,r,kind,newkn,imp,discharged_hyps) in + (op :: ops, ids_to_discard, (mods@constl, indl, cstrl)) + + | "INDUCTIVE" -> + let kn = Nametab.locate_mind (qualid_of_sp sp) in + let mib = Environ.lookup_mind kn oldenv in + let newkn = recalc_kn newdir kn in + let imp = is_implicit_inductive_definition kn in +(* let imp = is_implicit_args (* CHANGE *) in*) + let (mie,indmods,cstrmods,discharged_hyps0) = + process_inductive full_olddir kn newkn oldenv (ids_to_discard,work_alist) mib in + (* let's add the new discharged hypothesis to those already discharged*) + let discharged_hyps = + discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in + ((Inductive(mie,imp,discharged_hyps)) :: ops, ids_to_discard, + (constl,indmods@indl,cstrmods@cstrl)) + + | "CLASS" -> + let ((cl,clinfo) as x) = outClass lobj in + if clinfo.cl_strength = Local then + (ops,ids_to_discard,work_alist) + else + let (y1,y2) = process_class olddir ids_to_discard x in + ((Class (y1,y2))::ops, ids_to_discard, work_alist) + + | "COERCION" -> + let (_,coeinfo,_,_ as x) = outCoercion lobj in + if coercion_strength coeinfo = Local then + (ops,ids_to_discard,work_alist) + else + let y = process_coercion olddir ids_to_discard x in + ((Coercion y)::ops, ids_to_discard, work_alist) + + | "STRUCTURE" -> + let ((kn,i),info) = outStruc lobj in + let newkn = recalc_kn newdir kn in + let strobj () = + let mib = Environ.lookup_mind newkn (Global.env ()) in + { s_CONST = info.s_CONST; + s_PARAM = mib.mind_packets.(0).mind_nparams; + s_PROJ = List.map (option_app (fun kn -> recalc_kn newdir kn)) info.s_PROJ } in + ((Struc ((newkn,i),strobj))::ops, ids_to_discard, work_alist) + + | "OBJDEF1" -> + let kn = outObjDef1 lobj in + let new_kn = recalc_kn newdir kn in + ((Objdef new_kn)::ops, ids_to_discard, work_alist) + + | "REQUIRE" -> + let c = out_require lobj in + ((Require c)::ops, ids_to_discard, work_alist) + + | _ -> (ops,ids_to_discard,work_alist) + +let process_item oldenv olddir full_olddir newdir acc = function + | (sp,Leaf lobj) -> + process_object oldenv olddir full_olddir newdir acc (sp,lobj) + | (_,_) -> acc + +let process_operation = function + | Variable (id,expmod_a,stre,imp,discharged_hyps) -> + (* Warning:parentheses needed to get a side-effect from with_implicits *) + with_implicits imp (redeclare_variable id discharged_hyps) + (Lib.cwd(),expmod_a,stre) + | Constant (id,r,stre,kn,imp,discharged_hyps) -> + with_implicits imp (redeclare_constant id discharged_hyps) (r,stre); + constant_message id + | Inductive (mie,imp,discharged_hyps) -> + let _ = with_implicits imp (redeclare_inductive discharged_hyps) mie in + inductive_message mie.mind_entry_inds + | Class (y1,y2) -> + Lib.add_anonymous_leaf (inClass (y1,y2)) + | Struc (newsp,strobj) -> + Lib.add_anonymous_leaf (inStruc (newsp,strobj ())) + | Objdef newsp -> + begin try Recordobj.objdef_declare (ConstRef newsp) with _ -> () end + | Coercion y -> add_new_coercion y + | Require y -> reload_library y + | Constraints y -> Global.add_constraints y + +let catch_not_found f x = + try f x + with Not_found -> + error ("Something is missing; perhaps a reference to a"^ + " module required inside the section") + +let close_section _ s = + let oldenv = Global.env() in + let prefix,decls,fs = close_section false s in + let full_olddir, (_,olddir) = prefix in + let newdir = fst (split_dirpath olddir) in + let (ops,ids,_) = + List.fold_left + (process_item oldenv olddir full_olddir newdir) ([],[],([],[],[])) decls + in + let ids = last_section_hyps olddir in + Summary.section_unfreeze_summaries fs; + catch_not_found (List.iter process_operation) (List.rev ops); + Nametab.push_dir (Until 1) full_olddir (DirClosedSection full_olddir) diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli new file mode 100644 index 00000000..c80b93ce --- /dev/null +++ b/toplevel/discharge.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: discharge.mli,v 1.6.16.1 2004/07/16 19:31:48 herbelin Exp $ i*) + +open Names + +(* This module implements the discharge mechanism. It provides a function to + close the last opened section. That function calls [Lib.close_section] and + then re-introduce all the discharged versions of the objects that were + defined in the section. *) + +val close_section : bool -> identifier -> unit diff --git a/toplevel/doc.tex b/toplevel/doc.tex new file mode 100644 index 00000000..f2550fda --- /dev/null +++ b/toplevel/doc.tex @@ -0,0 +1,10 @@ + +\newpage +\section*{The Coq toplevel} + +\ocwsection \label{toplevel} +This chapter describes the highest modules of the \Coq\ system. +They are organized as follows: + +\bigskip +\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center} diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml new file mode 100644 index 00000000..b5185cd3 --- /dev/null +++ b/toplevel/fhimsg.ml @@ -0,0 +1,362 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: fhimsg.ml,v 1.19.2.1 2004/07/16 19:31:48 herbelin Exp $ *) + +open Pp +open Util +open Names +open Term +open Sign +open Environ +open Type_errors +open Reduction +open G_minicoq + +module type Printer = sig + val pr_term : path_kind -> env -> constr -> std_ppcmds +end + +module Make = functor (P : Printer) -> struct + + let print_decl k env (s,typ) = + let ptyp = P.pr_term k env typ in + (spc () ++ pr_id s ++ str" : " ++ ptyp) + + let print_binding k env = function + | Anonymous,ty -> + (spc () ++ str"_" ++ str" : " ++ P.pr_term k env ty) + | Name id,ty -> + (spc () ++ pr_id id ++ str" : " ++ P.pr_term k env ty) + +(**** + let sign_it_with f sign e = + snd (fold_named_context + (fun (id,v,t) (sign,e) -> (add_named_decl (id,v,t) sign, f id t sign e)) + sign (empty_named_context,e)) + + let dbenv_it_with f env e = + snd (dbenv_it + (fun na t (env,e) -> (add_rel_decl (na,t) env, f na t env e)) + env (gLOB(get_globals env),e)) +****) + + let pr_env k env = + let sign_env = + fold_named_context + (fun env (id,_,t) pps -> + let pidt = print_decl k env (id,t) in (pps ++ fnl () ++ pidt)) + env (mt ()) + in + let db_env = + fold_rel_context + (fun env (na,_,t) pps -> + let pnat = print_binding k env (na,t) in (pps ++ fnl () ++ pnat)) + env (mt ()) + in + (sign_env ++ db_env) + + let pr_ne_ctx header k env = + if rel_context env = [] && named_context env = [] then + (mt ()) + else + (header ++ pr_env k env) + + +let explain_unbound_rel k ctx n = + let pe = pr_ne_ctx (str"in environment") k ctx in + (str"Unbound reference: " ++ pe ++ fnl () ++ + str"The reference " ++ int n ++ str" is free") + +let explain_not_type k ctx c = + let pe = pr_ne_ctx (str"In environment") k ctx in + let pc = P.pr_term k ctx c in + (pe ++ cut () ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++ + str"should be typed by Set, Prop or Type.");; + +let explain_bad_assumption k ctx c = + let pc = P.pr_term k ctx c in + (str "Cannot declare a variable or hypothesis over the term" ++ + brk(1,1) ++ pc ++ spc () ++ str "because this term is not a type.");; + +let explain_reference_variables id = + (str "the constant" ++ spc () ++ pr_id id ++ spc () ++ + str "refers to variables which are not in the context") + +let msg_bad_elimination ctx k = function + | Some(ki,kp,explanation) -> + let pki = P.pr_term k ctx ki in + let pkp = P.pr_term k ctx kp in + (hov 0 + (fnl () ++ str "Elimination of an inductive object of sort : " ++ + pki ++ brk(1,0) ++ + str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++ + str "because" ++ spc () ++ str explanation)) + | None -> + (mt ()) + +let explain_elim_arity k ctx ind aritylst c pj okinds = + let pi = P.pr_term k ctx ind in + let ppar = prlist_with_sep pr_coma (P.pr_term k ctx) aritylst in + let pc = P.pr_term k ctx c in + let pp = P.pr_term k ctx pj.uj_val in + let ppt = P.pr_term k ctx pj.uj_type in + (str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++ + str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++ + str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ + str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++ + str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++ + msg_bad_elimination ctx k okinds) + +let explain_case_not_inductive k ctx cj = + let pc = P.pr_term k ctx cj.uj_val in + let pct = P.pr_term k ctx cj.uj_type in + (str "In Cases expression" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not an inductive definition") + +let explain_number_branches k ctx cj expn = + let pc = P.pr_term k ctx cj.uj_val in + let pct = P.pr_term k ctx cj.uj_val in + (str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++ + str "of type" ++ brk(1,1) ++ pct ++ spc () ++ + str "expects " ++ int expn ++ str " branches") + +let explain_ill_formed_branch k ctx c i actty expty = + let pc = P.pr_term k ctx c in + let pa = P.pr_term k ctx actty in + let pe = P.pr_term k ctx expty in + (str "In Cases expression on term" ++ brk(1,1) ++ pc ++ + spc () ++ str "the branch " ++ int (i+1) ++ + str " has type" ++ brk(1,1) ++ pa ++ spc () ++ + str "which should be:" ++ brk(1,1) ++ pe) + +let explain_generalization k ctx (name,var) c = + let pe = pr_ne_ctx (str"in environment") k ctx in + let pv = P.pr_term k ctx var in + let pc = P.pr_term k (push_rel (name,None,var) ctx) c in + (str"Illegal generalization: " ++ pe ++ fnl () ++ + str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ + str"over" ++ brk(1,1) ++ pc ++ spc () ++ + str"which should be typed by Set, Prop or Type.") + +let explain_actual_type k ctx c ct pt = + let pe = pr_ne_ctx (str"In environment") k ctx in + let pc = P.pr_term k ctx c in + let pct = P.pr_term k ctx ct in + let pt = P.pr_term k ctx pt in + (pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str"does not have type" ++ brk(1,1) ++ pt ++ fnl () ++ + str"Actually, it has type" ++ brk(1,1) ++ pct) + +let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = + let ctx = make_all_name_different ctx in + let pe = pr_ne_ctx (str"in environment") k ctx in + let pr = pr_term k ctx rator.uj_val in + let prt = pr_term k ctx rator.uj_type in + let term_string = if List.length randl > 1 then "terms" else "term" in + let many = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in + let appl = prlist_with_sep pr_fnl + (fun c -> + let pc = pr_term k ctx c.uj_val in + let pct = pr_term k ctx c.uj_type in + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl + in + (str"Illegal application (Type Error): " ++ pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl ++ fnl () ++ + str"The " ++int n ++ str (many^" term of type ") ++ + pr_term k ctx actualtyp ++ + str" should be of type " ++ pr_term k ctx exptyp) + +let explain_cant_apply_not_functional k ctx rator randl = + let ctx = make_all_name_different ctx in + let pe = pr_ne_ctx (str"in environment") k ctx in + let pr = pr_term k ctx rator.uj_val in + let prt = pr_term k ctx rator.uj_type in + let term_string = if List.length randl > 1 then "terms" else "term" in + let appl = prlist_with_sep pr_fnl + (fun c -> + let pc = pr_term k ctx c.uj_val in + let pct = pr_term k ctx c.uj_type in + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl + in + (str"Illegal application (Non-functional construction): " ++ pe ++ fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl ++ fnl ()) + +(* (co)fixpoints *) +let explain_ill_formed_rec_body k ctx err names i vdefs = + let str = match err with + + (* Fixpoint guard errors *) + | NotEnoughAbstractionInFixBody -> + (str "Not enough abstractions in the definition") + | RecursionNotOnInductiveType -> + (str "Recursive definition on a non inductive type") + | RecursionOnIllegalTerm -> + (str "Recursive call applied to an illegal term") + | NotEnoughArgumentsForFixCall -> + (str "Not enough arguments for the recursive call") + + (* CoFixpoint guard errors *) + (* TODO : récupérer le contexte des termes pour pouvoir les afficher *) + | CodomainNotInductiveType c -> + (str "The codomain is" ++ spc () ++ P.pr_term k ctx c ++ spc () ++ + str "which should be a coinductive type") + | NestedRecursiveOccurrences -> + (str "Nested recursive occurrences") + | UnguardedRecursiveCall c -> + (str "Unguarded recursive call") + | RecCallInTypeOfAbstraction c -> + (str "Not allowed recursive call in the domain of an abstraction") + | RecCallInNonRecArgOfConstructor c -> + (str "Not allowed recursive call in a non-recursive argument of constructor") + | RecCallInTypeOfDef c -> + (str "Not allowed recursive call in the type of a recursive definition") + | RecCallInCaseFun c -> + (str "Not allowed recursive call in a branch of cases") + | RecCallInCaseArg c -> + (str "Not allowed recursive call in the argument of cases") + | RecCallInCasePred c -> + (str "Not allowed recursive call in the type of cases in") + | NotGuardedForm c -> + str "Sub-expression " ++ prterm_env ctx c ++ spc() ++ + str "not in guarded form (should be a constructor, Cases or CoFix)" +in + let pvd = P.pr_term k ctx vdefs.(i) in + let s = + match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in + (str ++ fnl () ++ str"The " ++ + if Array.length vdefs = 1 then (mt ()) else (int (i+1) ++ str "-th ") ++ + str"recursive definition" ++ spc () ++ str s ++ + spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++ + str "is not well-formed") + +let explain_ill_typed_rec_body k ctx i lna vdefj vargs = + let pvd = P.pr_term k ctx (vdefj.(i)).uj_val in + let pvdt = P.pr_term k ctx (vdefj.(i)).uj_type in + let pv = P.pr_term k ctx vargs.(i) in + (str"The " ++ + if Array.length vdefj = 1 then (mt ()) else (int (i+1) ++ str "-th") ++ + str"recursive definition" ++ spc () ++ pvd ++ spc () ++ + str "has type" ++ spc () ++ pvdt ++spc () ++ str "it should be" ++ spc () ++ pv) + +let explain_not_inductive k ctx c = + let pc = P.pr_term k ctx c in + (str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "is not an inductive definition") + +let explain_ml_case k ctx mes c ct br brt = + let pc = P.pr_term k ctx c in + let pct = P.pr_term k ctx ct in + let expln = + match mes with + | "Inductive" -> (pct ++ str "is not an inductive definition") + | "Predicate" -> (str "ML case not allowed on a predicate") + | "Absurd" -> (str "Ill-formed case expression on an empty type") + | "Decomp" -> + let plf = P.pr_term k ctx br in + let pft = P.pr_term k ctx brt in + (str "The branch " ++ plf ++ ws 1 ++ cut () ++ str "has type " ++ pft ++ + ws 1 ++ cut () ++ + str "does not correspond to the inductive definition") + | "Dependent" -> + (str "ML case not allowed for a dependent case elimination") + | _ -> (mt ()) + in + hov 0 (str "In ML case expression on " ++ pc ++ ws 1 ++ cut () ++ + str "of type" ++ ws 1 ++ pct ++ ws 1 ++ cut () ++ + str "which is an inductive predicate." ++ fnl () ++ expln) +(* +let explain_cant_find_case_type loc k ctx c = + let pe = P.pr_term k ctx c in + Ast.user_err_loc + (loc,"pretype", + hov 3 (str "Cannot infer type of whole Case expression on" ++ + ws 1 ++ pe)) +*) +let explain_type_error k ctx = function + | UnboundRel n -> + explain_unbound_rel k ctx n + | NotAType c -> + explain_not_type k ctx c.uj_val + | BadAssumption c -> + explain_bad_assumption k ctx c + | ReferenceVariables id -> + explain_reference_variables id + | ElimArity (ind, aritylst, c, pj, okinds) -> + explain_elim_arity k ctx (mkMutInd ind) aritylst c pj okinds + | CaseNotInductive cj -> + explain_case_not_inductive k ctx cj + | NumberBranches (cj, n) -> + explain_number_branches k ctx cj n + | IllFormedBranch (c, i, actty, expty) -> + explain_ill_formed_branch k ctx c i actty expty + | Generalization (nvar, c) -> + explain_generalization k ctx nvar c.uj_val + | ActualType (c, ct, pt) -> + explain_actual_type k ctx c ct pt + | CantApplyBadType (s, rator, randl) -> + explain_cant_apply_bad_type k ctx s rator randl + | CantApplyNonFunctional (rator, randl) -> + explain_cant_apply_not_functional k ctx rator randl + | IllFormedRecBody (i, lna, vdefj, vargs) -> + explain_ill_formed_rec_body k ctx i lna vdefj vargs + | IllTypedRecBody (i, lna, vdefj, vargs) -> + explain_ill_typed_rec_body k ctx i lna vdefj vargs +(* + | NotInductive c -> + explain_not_inductive k ctx c + | MLCase (mes,c,ct,br,brt) -> + explain_ml_case k ctx mes c ct br brt +*) + | _ -> + (str "Unknown type error (TODO)") + +let explain_refiner_bad_type k ctx arg ty conclty = + errorlabstrm "Logic.conv_leq_goal" + (str"refiner was given an argument" ++ brk(1,1) ++ + P.pr_term k ctx arg ++ spc () ++ + str"of type" ++ brk(1,1) ++ P.pr_term k ctx ty ++ spc () ++ + str"instead of" ++ brk(1,1) ++ P.pr_term k ctx conclty) + +let explain_refiner_occur_meta k ctx t = + errorlabstrm "Logic.mk_refgoals" + (str"cannot refine with term" ++ brk(1,1) ++ P.pr_term k ctx t ++ + spc () ++ str"because there are metavariables, and it is" ++ + spc () ++ str"neither an application nor a Case") + +let explain_refiner_cannot_applt k ctx t harg = + errorlabstrm "Logic.mkARGGOALS" + (str"in refiner, a term of type " ++ brk(1,1) ++ + P.pr_term k ctx t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++ + P.pr_term k ctx harg) + +let explain_occur_check k ctx ev rhs = + let id = "?" ^ string_of_int ev in + let pt = P.pr_term k ctx rhs in + errorlabstrm "Trad.occur_check" + (str"Occur check failed: tried to define " ++ str id ++ + str" with term" ++ brk(1,1) ++ pt) + +let explain_not_clean k ctx sp t = + let c = mkRel (Intset.choose (free_rels t)) in + let id = string_of_id (Names.basename sp) in + let var = P.pr_term k ctx c in + errorlabstrm "Trad.not_clean" + (str"Tried to define " ++ str id ++ + str" with a term using variable " ++ var ++ spc () ++ + str"which is not in its scope.") + +end diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli new file mode 100644 index 00000000..10175e2a --- /dev/null +++ b/toplevel/fhimsg.mli @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: fhimsg.mli,v 1.8.16.1 2004/07/16 19:31:48 herbelin Exp $ i*) + +(*i*) +open Pp +open Names +open Term +open Sign +open Environ +open Type_errors +(*i*) + +(* This module provides functions to explain the various typing errors. + It is parameterized by a function to pretty-print a term in a given + context. *) + +module type Printer = sig + val pr_term : path_kind -> env -> constr -> std_ppcmds +end + +(*s The result is a module which provides a function [explain_type_error] + to explain a type error for a given kind in a given env, which are + usually the three arguments carried by the exception [TypeError] + (see \refsec{typeerrors}). *) + +module Make (P : Printer) : sig + +val explain_type_error : path_kind -> env -> type_error -> std_ppcmds + +val pr_ne_ctx : std_ppcmds -> path_kind -> env -> std_ppcmds + +val explain_unbound_rel : path_kind -> env -> int -> std_ppcmds + +val explain_not_type : path_kind -> env -> constr -> std_ppcmds + +val explain_bad_assumption : path_kind -> env -> constr -> std_ppcmds + +val explain_reference_variables : identifier -> std_ppcmds + +val explain_elim_arity : + path_kind -> env -> constr -> constr list -> constr + -> unsafe_judgment -> (constr * constr * string) option -> std_ppcmds + +val explain_case_not_inductive : + path_kind -> env -> unsafe_judgment -> std_ppcmds + +val explain_number_branches : + path_kind -> env -> unsafe_judgment -> int -> std_ppcmds + +val explain_ill_formed_branch : + path_kind -> env -> constr -> int -> constr -> constr -> std_ppcmds + +val explain_generalization : + path_kind -> env -> name * types -> constr -> std_ppcmds + +val explain_actual_type : + path_kind -> env -> constr -> constr -> constr -> std_ppcmds + +val explain_ill_formed_rec_body : + path_kind -> env -> guard_error -> + name array -> int -> constr array -> std_ppcmds + +val explain_ill_typed_rec_body : + path_kind -> env -> int -> name list -> unsafe_judgment array + -> types array -> std_ppcmds + +end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml new file mode 100644 index 00000000..de341bd9 --- /dev/null +++ b/toplevel/himsg.ml @@ -0,0 +1,665 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: himsg.ml,v 1.86.2.2 2004/07/16 19:31:49 herbelin Exp $ *) + +open Pp +open Util +open Options +open Names +open Nameops +open Term +open Termops +open Inductive +open Indtypes +open Sign +open Environ +open Pretype_errors +open Type_errors +open Reduction +open Cases +open Logic +open Printer +open Ast +open Rawterm + +let quote s = if !Options.v7 then s else h 0 (str "\"" ++ s ++ str "\"") + +let prterm c = quote (prterm c) +let prterm_env e c = quote (prterm_env e c) +let prjudge_env e c = let v,t = prjudge_env e c in (quote v,quote t) + +let nth i = + let many = match i mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in + int i ++ str many + +let pr_db ctx i = + try + match lookup_rel i ctx with + Name id, _, _ -> pr_id id + | Anonymous, _, _ -> str"<>" + with Not_found -> str"UNBOUND_REL_"++int i + +let explain_unbound_rel ctx n = + let pe = pr_ne_context_of (str "In environment") ctx in + str"Unbound reference: " ++ pe ++ + str"The reference " ++ int n ++ str " is free" + +let explain_unbound_var ctx v = + let var = pr_id v in + str"No such section variable or assumption : " ++ var + +let explain_not_type ctx j = + let pe = pr_ne_context_of (str"In environment") ctx in + let pc,pt = prjudge_env ctx j in + pe ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++ + str"has type" ++ spc () ++ pt ++ spc () ++ + str"which should be Set, Prop or Type." + +let explain_bad_assumption ctx j = + let pe = pr_ne_context_of (str"In environment") ctx in + let pc,pt = prjudge_env ctx j in + pe ++ str "cannot declare a variable or hypothesis over the term" ++ + brk(1,1) ++ pc ++ spc () ++ str"of type" ++ spc () ++ pt ++ spc () ++ + str "because this term is not a type." + +let explain_reference_variables c = + let pc = prterm c in + str "the constant" ++ spc () ++ pc ++ spc () ++ + str "refers to variables which are not in the context" + +let explain_elim_arity ctx ind aritylst c pj okinds = + let ctx = make_all_name_different ctx in + let pi = pr_inductive ctx ind in + let ppar = prlist_with_sep pr_coma (prterm_env ctx) aritylst in + let pc = prterm_env ctx c in + let pp = prterm_env ctx pj.uj_val in + let ppt = prterm_env ctx pj.uj_type in + let msg = match okinds with + | Some(kp,ki,explanation) -> + let pki = prterm_env ctx ki in + let pkp = prterm_env ctx kp in + let explanation = match explanation with + | NonInformativeToInformative -> + "non-informative objects may not construct informative ones." + | StrongEliminationOnNonSmallType -> + "strong elimination on non-small inductive types leads to paradoxes." + | WrongArity -> + "wrong arity" in + (hov 0 + (fnl () ++ str "Elimination of an inductive object of sort : " ++ + pki ++ brk(1,0) ++ + str "is not allowed on a predicate in sort : " ++ pkp ++fnl () ++ + str "because" ++ spc () ++ str explanation)) + | None -> + mt () + in + str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++ + str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++ + str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++ + str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++ + str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++ + msg + +let explain_case_not_inductive ctx cj = + let ctx = make_all_name_different ctx in + let pc = prterm_env ctx cj.uj_val in + let pct = prterm_env ctx cj.uj_type in + match kind_of_term cj.uj_type with + | Evar _ -> + str "Cannot infer a type for this expression" + | _ -> + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not a (co-)inductive type" + +let explain_number_branches ctx cj expn = + let ctx = make_all_name_different ctx in + let pc = prterm_env ctx cj.uj_val in + let pct = prterm_env ctx cj.uj_type in + str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++ + str "of type" ++ brk(1,1) ++ pct ++ spc () ++ + str "expects " ++ int expn ++ str " branches" + +let explain_ill_formed_branch ctx c i actty expty = + let ctx = make_all_name_different ctx in + let pc = prterm_env ctx c in + let pa = prterm_env ctx actty in + let pe = prterm_env ctx expty in + str "In pattern-matching on term" ++ brk(1,1) ++ pc ++ + spc () ++ str "the branch " ++ int (i+1) ++ + str " has type" ++ brk(1,1) ++ pa ++ spc () ++ + str "which should be" ++ brk(1,1) ++ pe + +let explain_generalization ctx (name,var) j = + let pe = pr_ne_context_of (str "In environment") ctx in + let pv = prtype_env ctx var in + let (pc,pt) = prjudge_env (push_rel_assum (name,var) ctx) j in + str"Illegal generalization: " ++ pe ++ + str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ + str"over" ++ brk(1,1) ++ pc ++ str"," ++ spc () ++ + str"it has type" ++ spc () ++ pt ++ + spc () ++ str"which should be Set, Prop or Type." + +let explain_actual_type ctx j pt = + let pe = pr_ne_context_of (str "In environment") ctx in + let (pc,pct) = prjudge_env ctx j in + let pt = prterm_env ctx pt in + pe ++ + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++ + str "while it is expected to have type" ++ brk(1,1) ++ pt + +let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl = + let randl = Array.to_list randl in +(* let pe = pr_ne_context_of (str"in environment") ctx in*) + let pr,prt = prjudge_env ctx rator in + let term_string1,term_string2 = + if List.length randl > 1 then + str "terms", (str"The "++nth n++str" term") + else + str "term", str "This term" in + let appl = prlist_with_sep pr_fnl + (fun c -> + let pc,pct = prjudge_env ctx c in + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl + in + str"Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++ + str"The term" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str"cannot be applied to the " ++ term_string1 ++ fnl () ++ + str" " ++ v 0 appl ++ fnl () ++ term_string2 ++ str" has type" ++ + brk(1,1) ++ prterm_env ctx actualtyp ++ spc () ++ + str"which should be coercible to" ++ brk(1,1) ++ prterm_env ctx exptyp + +let explain_cant_apply_not_functional ctx rator randl = + let randl = Array.to_list randl in +(* let pe = pr_ne_context_of (str"in environment") ctx in*) + let pr = prterm_env ctx rator.uj_val in + let prt = prterm_env ctx rator.uj_type in + let term_string = if List.length randl > 1 then "terms" else "term" in + let appl = prlist_with_sep pr_fnl + (fun c -> + let pc = prterm_env ctx c.uj_val in + let pct = prterm_env ctx c.uj_type in + hov 2 (pc ++ spc () ++ str": " ++ pct)) randl + in + str"Illegal application (Non-functional construction): " ++ + (* pe ++ *) fnl () ++ + str"The expression" ++ brk(1,1) ++ pr ++ spc () ++ + str"of type" ++ brk(1,1) ++ prt ++ spc () ++ + str("cannot be applied to the "^term_string) ++ fnl () ++ + str" " ++ v 0 appl + +let explain_unexpected_type ctx actual_type expected_type = + let pract = prterm_env ctx actual_type in + let prexp = prterm_env ctx expected_type in + str"This type is" ++ spc () ++ pract ++ spc () ++ + str "but is expected to be" ++ + spc () ++ prexp + +let explain_not_product ctx c = + let pr = prterm_env ctx c in + str"The type of this term is a product," ++ spc () ++ + str"but it is casted with type" ++ + brk(1,1) ++ pr + +(* TODO: use the names *) +(* (co)fixpoints *) +let explain_ill_formed_rec_body ctx err names i = + let prt_name i = + match names.(i) with + Name id -> str "Recursive definition of " ++ pr_id id + | Anonymous -> str"The " ++ nth i ++ str" definition" in + + let st = match err with + + (* Fixpoint guard errors *) + | NotEnoughAbstractionInFixBody -> + str "Not enough abstractions in the definition" + | RecursionNotOnInductiveType -> + str "Recursive definition on a non inductive type" + | RecursionOnIllegalTerm(j,arg,le,lt) -> + let called = + match names.(j) with + Name id -> pr_id id + | Anonymous -> str"the " ++ nth i ++ str" definition" in + let vars = + match (lt,le) with + ([],[]) -> mt() + | ([],[x]) -> + str "a subterm of " ++ pr_db ctx x + | ([],_) -> + str "a subterm of the following variables: " ++ + prlist_with_sep pr_spc (pr_db ctx) le + | ([x],_) -> pr_db ctx x + | _ -> + str "one of the following variables: " ++ + prlist_with_sep pr_spc (pr_db ctx) lt in + str "Recursive call to " ++ called ++ spc() ++ + str "has principal argument equal to" ++ spc() ++ + prterm_env ctx arg ++ fnl() ++ str "instead of " ++ vars + + | NotEnoughArgumentsForFixCall j -> + let called = + match names.(j) with + Name id -> pr_id id + | Anonymous -> str"the " ++ nth i ++ str" definition" in + str "Recursive call to " ++ called ++ str " had not enough arguments" + + (* CoFixpoint guard errors *) + | CodomainNotInductiveType c -> + str "the codomain is" ++ spc () ++ prterm_env ctx c ++ spc () ++ + str "which should be a coinductive type" + | NestedRecursiveOccurrences -> + str "nested recursive occurrences" + | UnguardedRecursiveCall c -> + str "unguarded recursive call in" ++ spc() ++ prterm_env ctx c + | RecCallInTypeOfAbstraction c -> + str "recursive call forbidden in the domain of an abstraction:" ++ + spc() ++ prterm_env ctx c + | RecCallInNonRecArgOfConstructor c -> + str "recursive call on a non-recursive argument of constructor" ++ + spc() ++ prterm_env ctx c + | RecCallInTypeOfDef c -> + str "recursive call forbidden in the type of a recursive definition" ++ + spc() ++ prterm_env ctx c + | RecCallInCaseFun c -> + str "recursive call in a branch of" ++ spc() ++ prterm_env ctx c + | RecCallInCaseArg c -> + str "recursive call in the argument of cases in" ++ spc() ++ + prterm_env ctx c + | RecCallInCasePred c -> + str "recursive call in the type of cases in" ++ spc() ++ + prterm_env ctx c + | NotGuardedForm c -> + str "sub-expression " ++ prterm_env ctx c ++ spc() ++ + str "not in guarded form" ++ spc()++ + str"(should be a constructor, an abstraction, a match, a cofix or a recursive call)" + in + prt_name i ++ str" is ill-formed." ++ fnl() ++ + pr_ne_context_of (str "In environment") ctx ++ + st + +let explain_ill_typed_rec_body ctx i names vdefj vargs = + let ctx = make_all_name_different ctx in + let pvd,pvdt = prjudge_env ctx (vdefj.(i)) in + let pv = prterm_env ctx vargs.(i) in + str"The " ++ + (if Array.length vdefj = 1 then mt () else int (i+1) ++ str "-th") ++ + str"recursive definition" ++ spc () ++ pvd ++ spc () ++ + str "has type" ++ spc () ++ pvdt ++spc () ++ + str "it should be" ++ spc () ++ pv +(* +let explain_not_inductive ctx c = + let ctx = make_all_name_different ctx in + let pc = prterm_env ctx c in + str"The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "is not an inductive definition" +*) +let explain_cant_find_case_type ctx c = + let ctx = make_all_name_different ctx in + let pe = prterm_env ctx c in + hov 3 (str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe) + +let explain_occur_check ctx ev rhs = + let ctx = make_all_name_different ctx in + let id = Evd.string_of_existential ev in + let pt = prterm_env ctx rhs in + str"Occur check failed: tried to define " ++ str id ++ + str" with term" ++ brk(1,1) ++ pt + +let explain_hole_kind env = function + | QuestionMark -> str "a term for this placeholder" + | CasesType -> + str "the type of this pattern-matching problem" + | BinderType (Name id) -> + str "a type for " ++ Nameops.pr_id id + | BinderType Anonymous -> + str "a type for this anonymous binder" + | ImplicitArg (c,n) -> + if !Options.v7 then + str "the " ++ pr_ord n ++ + str " implicit argument of " ++ Nametab.pr_global_env Idset.empty c + else + let imps = Impargs.implicits_of_global c in + let id = Impargs.name_of_implicit (List.nth imps (n-1)) in + str "an instance for the implicit parameter " ++ + pr_id id ++ spc () ++ str "of" ++ + spc () ++ Nametab.pr_global_env Idset.empty c + | InternalHole -> + str "a term for an internal placeholder" + | TomatchTypeParameter (tyi,n) -> + str "the " ++ pr_ord n ++ + str " argument of the inductive type (" ++ pr_inductive env tyi ++ + str ") of this term" + +let explain_not_clean ctx ev t k = + let ctx = make_all_name_different ctx in + let c = mkRel (Intset.choose (free_rels t)) in + let id = Evd.string_of_existential ev in + let var = prterm_env ctx c in + str"Tried to define " ++ explain_hole_kind ctx k ++ + str" (" ++ str id ++ str ")" ++ spc() ++ + str"with a term using variable " ++ var ++ spc () ++ + str"which is not in its scope." + +let explain_unsolvable_implicit env k = + str "Cannot infer " ++ explain_hole_kind env k + + +let explain_var_not_found ctx id = + str "The variable" ++ spc () ++ str (string_of_id id) ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment" + +let explain_wrong_case_info ctx ind ci = + let ctx = make_all_name_different ctx in + let pi = prterm (mkInd ind) in + if ci.ci_ind = ind then + str"Pattern-matching expression on an object of inductive" ++ spc () ++ pi ++ + spc () ++ str"has invalid information" + else + let pc = prterm (mkInd ci.ci_ind) in + str"A term of inductive type" ++ spc () ++ pi ++ spc () ++ + str"was given to a pattern-matching expression on the inductive type" ++ + spc () ++ pc + + +let explain_type_error ctx err = + let ctx = make_all_name_different ctx in + match err with + | UnboundRel n -> + explain_unbound_rel ctx n + | UnboundVar v -> + explain_unbound_var ctx v + | NotAType j -> + explain_not_type ctx j + | BadAssumption c -> + explain_bad_assumption ctx c + | ReferenceVariables id -> + explain_reference_variables id + | ElimArity (ind, aritylst, c, pj, okinds) -> + explain_elim_arity ctx ind aritylst c pj okinds + | CaseNotInductive cj -> + explain_case_not_inductive ctx cj + | NumberBranches (cj, n) -> + explain_number_branches ctx cj n + | IllFormedBranch (c, i, actty, expty) -> + explain_ill_formed_branch ctx c i actty expty + | Generalization (nvar, c) -> + explain_generalization ctx nvar c + | ActualType (j, pt) -> + explain_actual_type ctx j pt + | CantApplyBadType (t, rator, randl) -> + explain_cant_apply_bad_type ctx t rator randl + | CantApplyNonFunctional (rator, randl) -> + explain_cant_apply_not_functional ctx rator randl + | IllFormedRecBody (err, lna, i) -> + explain_ill_formed_rec_body ctx err lna i + | IllTypedRecBody (i, lna, vdefj, vargs) -> + explain_ill_typed_rec_body ctx i lna vdefj vargs + | WrongCaseInfo (ind,ci) -> + explain_wrong_case_info ctx ind ci +(* + | NotInductive c -> + explain_not_inductive ctx c +*) +let explain_pretype_error ctx err = + let ctx = make_all_name_different ctx in + match err with + | CantFindCaseType c -> + explain_cant_find_case_type ctx c + | OccurCheck (n,c) -> + explain_occur_check ctx n c + | NotClean (n,c,k) -> + explain_not_clean ctx n c k + | UnsolvableImplicit k -> + explain_unsolvable_implicit ctx k + | VarNotFound id -> + explain_var_not_found ctx id + | UnexpectedType (actual,expected) -> + explain_unexpected_type ctx actual expected + | NotProduct c -> + explain_not_product ctx c + +(* Refiner errors *) + +let explain_refiner_bad_type arg ty conclty = + str"refiner was given an argument" ++ brk(1,1) ++ + prterm arg ++ spc () ++ + str"of type" ++ brk(1,1) ++ prterm ty ++ spc () ++ + str"instead of" ++ brk(1,1) ++ prterm conclty + +let explain_refiner_occur_meta t = + str"cannot refine with term" ++ brk(1,1) ++ prterm t ++ + spc () ++ str"because there are metavariables, and it is" ++ + spc () ++ str"neither an application nor a Case" + +let explain_refiner_occur_meta_goal t = + str"generated subgoal" ++ brk(1,1) ++ prterm t ++ + spc () ++ str"has metavariables in it" + +let explain_refiner_cannot_applt t harg = + str"in refiner, a term of type " ++ brk(1,1) ++ + prterm t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++ + prterm harg + +let explain_cannot_unify m n = + let pm = prterm m in + let pn = prterm n in + str"Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ + str"with" ++ brk(1,1) ++ pn + +let explain_cannot_unify_binding_type m n = + let pm = prterm m in + let pn = prterm n in + str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ + str "which should be unifiable with" ++ brk(1,1) ++ pn + +let explain_refiner_cannot_generalize ty = + str "Cannot find a well-typed generalisation of the goal with type : " ++ + prterm ty + +let explain_refiner_not_well_typed c = + str"The term " ++ prterm c ++ str" is not well-typed" + +let explain_intro_needs_product () = + str "Introduction tactics needs products" + +let explain_does_not_occur_in c hyp = + str "The term" ++ spc () ++ prterm c ++ spc () ++ str "does not occur in" ++ + spc () ++ pr_id hyp + +let explain_non_linear_proof c = + str "cannot refine with term" ++ brk(1,1) ++ prterm c ++ + spc () ++ str"because a metavariable has several occurrences" + +let explain_no_occurrence_found c = + str "Found no subterm matching " ++ prterm c ++ str " in the current goal" + +let explain_refiner_error = function + | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty + | OccurMeta t -> explain_refiner_occur_meta t + | OccurMetaGoal t -> explain_refiner_occur_meta_goal t + | CannotApply (t,harg) -> explain_refiner_cannot_applt t harg + | CannotUnify (m,n) -> explain_cannot_unify m n + | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type m n + | CannotGeneralize ty -> explain_refiner_cannot_generalize ty + | NotWellTyped c -> explain_refiner_not_well_typed c + | IntroNeedsProduct -> explain_intro_needs_product () + | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp + | NonLinearProof c -> explain_non_linear_proof c + | NoOccurrenceFound c -> explain_no_occurrence_found c + +(* Inductive errors *) + +let error_non_strictly_positive env c v = + let pc = prterm_env env c in + let pv = prterm_env env v in + str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ + brk(1,1) ++ pc + +let error_ill_formed_inductive env c v = + let pc = prterm_env env c in + let pv = prterm_env env v in + str "Not enough arguments applied to the " ++ pv ++ + str " in" ++ brk(1,1) ++ pc + +let error_ill_formed_constructor env c v = + let pc = prterm_env env c in + let pv = prterm_env env v in + str "The conclusion of" ++ brk(1,1) ++ pc ++ brk(1,1) ++ + str "is not valid;" ++ brk(1,1) ++ str "it must be built from " ++ pv + +let str_of_nth n = + (string_of_int n)^ + (match n mod 10 with + | 1 -> "st" + | 2 -> "nd" + | 3 -> "rd" + | _ -> "th") + +let error_bad_ind_parameters env c n v1 v2 = + let pc = prterm_env_at_top env c in + let pv1 = prterm_env env v1 in + let pv2 = prterm_env env v2 in + str ("The "^(str_of_nth n)^" argument of ") ++ pv2 ++ brk(1,1) ++ + str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc + +let error_same_names_types id = + str "The name" ++ spc () ++ pr_id id ++ spc () ++ + str "is used twice is the inductive types definition." + +let error_same_names_constructors id cid = + str "The constructor name" ++ spc () ++ pr_id cid ++ spc () ++ + str "is used twice is the definition of type" ++ spc () ++ + pr_id id + +let error_same_names_overlap idl = + str "The following names" ++ spc () ++ + str "are used both as type names and constructor names:" ++ spc () ++ + prlist_with_sep pr_coma pr_id idl + +let error_not_an_arity id = + str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity." + +let error_bad_entry () = + str "Bad inductive definition." + +let error_not_allowed_case_analysis dep kind i = + str (if dep then "Dependent" else "Non Dependent") ++ + str " case analysis on sort: " ++ print_sort kind ++ fnl () ++ + str "is not allowed for inductive definition: " ++ + pr_inductive (Global.env()) i + +let error_bad_induction dep indid kind = + str (if dep then "Dependent" else "Non dependent") ++ + str " induction for type " ++ pr_id indid ++ + str " and sort " ++ print_sort kind ++ spc () ++ + str "is not allowed" + +let error_not_mutual_in_scheme () = + str "Induction schemes is concerned only with mutually inductive types" + +let explain_inductive_error = function + (* These are errors related to inductive constructions *) + | NonPos (env,c,v) -> error_non_strictly_positive env c v + | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v + | NotConstructor (env,c,v) -> error_ill_formed_constructor env c v + | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2 + | SameNamesTypes id -> error_same_names_types id + | SameNamesConstructors (id,cid) -> error_same_names_constructors id cid + | SameNamesOverlap idl -> error_same_names_overlap idl + | NotAnArity id -> error_not_an_arity id + | BadEntry -> error_bad_entry () + (* These are errors related to recursors *) + | NotAllowedCaseAnalysis (dep,k,i) -> + error_not_allowed_case_analysis dep k i + | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind + | NotMutualInScheme -> error_not_mutual_in_scheme () + +(* Pattern-matching errors *) + +let explain_bad_pattern ctx cstr ty = + let ctx = make_all_name_different ctx in + let pt = prterm_env ctx ty in + let pc = pr_constructor ctx cstr in + str "Found the constructor " ++ pc ++ brk(1,1) ++ + str "while matching a term of type " ++ pt ++ brk(1,1) ++ + str "which is not an inductive type" + +let explain_bad_constructor ctx cstr ind = + let pi = pr_inductive ctx ind in +(* let pc = pr_constructor ctx cstr in*) + let pt = pr_inductive ctx (inductive_of_constructor cstr) in + str "Found a constructor of inductive type " ++ pt ++ brk(1,1) ++ + str "while a constructor of " ++ pi ++ brk(1,1) ++ + str "is expected" + +let explain_wrong_numarg_of_constructor ctx cstr n = + let pc = pr_constructor ctx cstr in + str "The constructor " ++ pc ++ str " expects " ++ + (if n = 0 then str "no argument." else if n = 1 then str "1 argument." + else (int n ++ str " arguments.")) + +let explain_wrong_predicate_arity ctx pred nondep_arity dep_arity= + let ctx = make_all_name_different ctx in + let pp = prterm_env ctx pred in + str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++ + str "should be of arity" ++ spc () ++ + prterm_env ctx nondep_arity ++ spc () ++ + str "(for non dependent case) or" ++ + spc () ++ prterm_env ctx dep_arity ++ spc () ++ str "(for dependent case)." + +let explain_needs_inversion ctx x t = + let ctx = make_all_name_different ctx in + let px = prterm_env ctx x in + let pt = prterm_env ctx t in + str "Sorry, I need inversion to compile pattern matching of term " ++ + px ++ str " of type: " ++ pt + +let explain_unused_clause env pats = + let s = if List.length pats > 1 then "s" else "" in +(* Without localisation + (str ("Unused clause with pattern"^s) ++ spc () ++ + hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")") +*) + str "This clause is redundant" + +let explain_non_exhaustive env pats = + let s = if List.length pats > 1 then "s" else "" in + str ("Non exhaustive pattern-matching: no clause found for pattern"^s) ++ + spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) + +let explain_cannot_infer_predicate ctx typs = + let ctx = make_all_name_different ctx in + let pr_branch (cstr,typ) = + let cstr,_ = decompose_app cstr in + str "For " ++ prterm_env ctx cstr ++ str " : " ++ prterm_env ctx typ + in + str "Unable to unify the types found in the branches:" ++ + spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs)) + +let explain_pattern_matching_error env = function + | BadPattern (c,t) -> + explain_bad_pattern env c t + | BadConstructor (c,ind) -> + explain_bad_constructor env c ind + | WrongNumargConstructor (c,n) -> + explain_wrong_numarg_of_constructor env c n + | WrongPredicateArity (pred,n,dep) -> + explain_wrong_predicate_arity env pred n dep + | NeedsInversion (x,t) -> + explain_needs_inversion env x t + | UnusedClause tms -> + explain_unused_clause env tms + | NonExhaustive tms -> + explain_non_exhaustive env tms + | CannotInferPredicate typs -> + explain_cannot_infer_predicate env typs diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli new file mode 100644 index 00000000..3e7ba575 --- /dev/null +++ b/toplevel/himsg.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: himsg.mli,v 1.13.14.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +(*i*) +open Pp +open Names +open Indtypes +open Environ +open Type_errors +open Pretype_errors +open Cases +open Logic +(*i*) + +(* This module provides functions to explain the type errors. *) + +val explain_type_error : env -> type_error -> std_ppcmds + +val explain_pretype_error : env -> pretype_error -> std_ppcmds + +val explain_inductive_error : inductive_error -> std_ppcmds + +val explain_refiner_error : refiner_error -> std_ppcmds + +val explain_pattern_matching_error : + env -> pattern_matching_error -> std_ppcmds diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml new file mode 100644 index 00000000..81221196 --- /dev/null +++ b/toplevel/line_oriented_parser.ml @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: line_oriented_parser.ml,v 1.2.16.1 2004/07/16 19:31:49 herbelin Exp $ *) + +let line_oriented_channel_to_option stop_string input_channel = + let count = ref 0 in + let buff = ref "" in + let current_length = ref 0 in + fun i -> + if (i - !count) >= !current_length then begin + count := !count + !current_length + 1; + buff := input_line input_channel; + if !buff = stop_string then + None + else begin + current_length := String.length !buff; + Some '\n' + end + end else + Some (String.get !buff (i - !count)) + +let flush_until_end_of_stream char_stream = + Stream.iter (function _ -> ()) char_stream diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli new file mode 100644 index 00000000..13af0e06 --- /dev/null +++ b/toplevel/line_oriented_parser.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: line_oriented_parser.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +val line_oriented_channel_to_option: string -> in_channel -> int -> char option + +val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml new file mode 100644 index 00000000..84bda0af --- /dev/null +++ b/toplevel/metasyntax.ml @@ -0,0 +1,1428 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: metasyntax.ml,v 1.105.2.2 2004/07/16 19:31:49 herbelin Exp $ *) + +open Pp +open Util +open Names +open Topconstr +open Coqast +open Ast +open Ppextend +open Extend +open Esyntax +open Libobject +open Library +open Summary +open Constrintern +open Vernacexpr +open Pcoq +open Rawterm +open Libnames + +let interp_global_rawconstr_with_vars vars c = + interp_rawconstr_gen false Evd.empty (Global.env()) false (vars,[]) c + +(**********************************************************************) +(* Parsing via ast (used in Zsyntax) *) + +(* This updates default parsers for Grammar actions and Syntax *) +(* patterns by inserting globalization *) +(* Done here to get parsing/g_*.ml4 non dependent from kernel *) +let constr_to_ast a = + Termast.ast_of_rawconstr (interp_rawconstr Evd.empty (Global.env()) a) + +(* This installs default quotations parsers to escape the ast parser *) +(* "constr" is used by default in quotations found in the ast parser *) +let constr_parser_with_glob = Pcoq.map_entry constr_to_ast Constr.constr + +let _ = define_ast_quotation true "constr" constr_parser_with_glob + +(**********************************************************************) +(* Globalisation for constr_expr *) + +let globalize_ref vars ref = + match Constrintern.interp_reference (vars,[]) ref with + | RRef (loc,VarRef a) -> Ident (loc,a) + | RRef (loc,a) -> Qualid (loc,qualid_of_sp (Nametab.sp_of_global a)) + | RVar (loc,x) -> Ident (loc,x) + | _ -> anomaly "globalize_ref: not a reference" + +let globalize_ref_term vars ref = + match Constrintern.interp_reference (vars,[]) ref with + | RRef (loc,VarRef a) -> CRef (Ident (loc,a)) + | RRef (loc,a) -> CRef (Qualid (loc,qualid_of_sp (Nametab.sp_of_global a))) + | RVar (loc,x) -> CRef (Ident (loc,x)) + | c -> Constrextern.extern_rawconstr Idset.empty c + +let rec globalize_constr_expr vars = function + | CRef ref -> globalize_ref_term vars ref + | CAppExpl (_,(p,ref),l) -> + let f = + map_constr_expr_with_binders globalize_constr_expr + (fun x e -> e) vars + in + CAppExpl (dummy_loc,(p,globalize_ref vars ref), List.map f l) + | c -> + map_constr_expr_with_binders globalize_constr_expr (fun id e -> id::e) + vars c + +let without_translation f x = + let old = Options.do_translate () in + let oldv7 = !Options.v7 in + Options.make_translate false; + try let r = f x in Options.make_translate old; Options.v7:=oldv7; r + with e -> Options.make_translate old; Options.v7:=oldv7; raise e + +let _ = set_constr_globalizer + (fun vars e -> for_grammar (without_translation (globalize_constr_expr vars)) e) + +(**********************************************************************) +(** For old ast printer *) + +(* Pretty-printer state summary *) +let _ = + declare_summary "syntax" + { freeze_function = Esyntax.freeze; + unfreeze_function = Esyntax.unfreeze; + init_function = Esyntax.init; + survive_module = false; + survive_section = false } + +(* Pretty-printing objects = syntax_entry *) +let cache_syntax (_,ppobj) = Esyntax.add_ppobject ppobj + +let subst_syntax (_,subst,ppobj) = + Extend.subst_syntax_command Ast.subst_astpat subst ppobj + +let (inPPSyntax,outPPSyntax) = + declare_object {(default_object "PPSYNTAX") with + open_function = (fun i o -> if i=1 then cache_syntax o); + cache_function = cache_syntax; + subst_function = subst_syntax; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x) } + +(* Syntax extension functions (registered in the environnement) *) + +(* Checking the pretty-printing rules against free meta-variables. + * Note that object are checked before they are added in the environment. + * Syntax objects in compiled modules are not re-checked. *) + +let add_syntax_obj whatfor sel = +(* if not !Options.v7_only then*) + Lib.add_anonymous_leaf (inPPSyntax (interp_syntax_entry whatfor sel)) + +(* Tokens *) + +let cache_token (_,s) = Pcoq.lexer.Token.using ("", s) + +let (inToken, outToken) = + declare_object {(default_object "TOKEN") with + open_function = (fun i o -> if i=1 then cache_token o); + cache_function = cache_token; + subst_function = Libobject.ident_subst_function; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x)} + +let add_token_obj s = Lib.add_anonymous_leaf (inToken s) + +(**********************************************************************) +(* Grammars (especially Tactic Notation) *) + +let make_terminal_status = function + | VTerm s -> Some s + | VNonTerm _ -> None + +let qualified_nterm current_univ = function + | NtQual (univ, en) -> (univ, en) + | NtShort en -> (current_univ, en) + +let rec make_tags = function + | VTerm s :: l -> make_tags l + | VNonTerm (loc, nt, po) :: l -> + let (u,nt) = qualified_nterm "tactic" nt in + let (etyp, _) = Egrammar.interp_entry_name u nt in + etyp :: make_tags l + | [] -> [] + +let declare_pprule = function + (* Pretty-printing rules only for Grammar (Tactic Notation) *) + | Egrammar.TacticGrammar gl -> + let f (s,(s',l),tac) = + let pp = (make_tags l, (s',List.map make_terminal_status l)) in + Pptactic.declare_extra_tactic_pprule true s pp; + Pptactic.declare_extra_tactic_pprule false s pp in + List.iter f gl + | _ -> () + +let cache_grammar (_,a) = + Egrammar.extend_grammar a; + declare_pprule a + +let subst_grammar (_,subst,a) = + Egrammar.subst_all_grammar_command subst a + +let (inGrammar, outGrammar) = + declare_object {(default_object "GRAMMAR") with + open_function = (fun i o -> if i=1 then cache_grammar o); + cache_function = cache_grammar; + subst_function = subst_grammar; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x)} + +(**********************************************************************) +(* V7 Grammar *) + +open Genarg + +let check_entry_type (u,n) = + if u = "tactic" or u = "vernac" then error "tactic and vernac not supported"; + match entry_type (get_univ u) n with + | None -> Pcoq.create_entry_if_new (get_univ u) n ConstrArgType + | Some (ConstrArgType | IdentArgType | RefArgType) -> () + | _ -> error "Cannot arbitrarily extend non constr/ident/ref entries" + +let add_grammar_obj univ entryl = + let u = create_univ_if_new univ in + let g = interp_grammar_command univ check_entry_type entryl in + Lib.add_anonymous_leaf (inGrammar (Egrammar.Grammar g)) + +(**********************************************************************) +(* V8 Grammar *) + +(* Tactic notations *) + +let locate_tactic_body dir (s,p,e) = (s,p,(dir,e)) + +let add_tactic_grammar g = + let dir = Lib.cwd () in + let g = List.map (locate_tactic_body dir) g in + Lib.add_anonymous_leaf (inGrammar (Egrammar.TacticGrammar g)) + +(* Printing grammar entries *) + +let print_grammar univ entry = + if !Options.v7 then + let u = get_univ univ in + let typ = explicitize_entry (fst u) entry in + let te,_,_ = get_constr_entry false typ in + Gram.Entry.print te + else + match entry with + | "constr" | "operconstr" | "binder_constr" -> + msgnl (str "Entry constr is"); + Gram.Entry.print Pcoq.Constr.constr; + msgnl (str "and lconstr is"); + Gram.Entry.print Pcoq.Constr.lconstr; + msgnl (str "where binder_constr is"); + Gram.Entry.print Pcoq.Constr.binder_constr; + msgnl (str "and operconstr is"); + Gram.Entry.print Pcoq.Constr.operconstr; + | "pattern" -> + Gram.Entry.print Pcoq.Constr.pattern + | "tactic" -> + Gram.Entry.print Pcoq.Tactic.simple_tactic + | _ -> error "Unknown or unprintable grammar entry" + +(* Parse a format (every terminal starting with a letter or a single + quote (except a single quote alone) must be quoted) *) + +let parse_format (loc,str) = + let str = " "^str in + let l = String.length str in + let push_token a = function + | cur::l -> (a::cur)::l + | [] -> [[a]] in + let push_white n l = + if n = 0 then l else push_token (UnpTerminal (String.make n ' ')) l in + let close_box i b = function + | a::(_::_ as l) -> push_token (UnpBox (b,a)) l + | _ -> error "Non terminated box in format" in + let close_quotation i = + if i < String.length str & str.[i] = '\'' & (i+1 = l or str.[i+1] = ' ') + then i+1 + else error "Incorrectly terminated quoted expression" in + let rec spaces n i = + if i < String.length str & str.[i] = ' ' then spaces (n+1) (i+1) + else n in + let rec nonspaces quoted n i = + if i < String.length str & str.[i] <> ' ' then + if str.[i] = '\'' & quoted & + (i+1 >= String.length str or str.[i+1] = ' ') + then if n=0 then error "Empty quoted token" else n + else nonspaces quoted (n+1) (i+1) + else + if quoted then error "Spaces are not allowed in (quoted) symbols" + else n in + let rec parse_non_format i = + let n = nonspaces false 0 i in + push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) + and parse_quoted n i = + if i < String.length str then match str.[i] with + (* Parse " // " *) + | '/' when i <= String.length str & str.[i+1] = '/' -> + (* We forget the useless n spaces... *) + push_token (UnpCut PpFnl) + (parse_token (close_quotation (i+2))) + (* Parse " .. / .. " *) + | '/' when i <= String.length str -> + let p = spaces 0 (i+1) in + push_token (UnpCut (PpBrk (n,p))) + (parse_token (close_quotation (i+p+1))) + | c -> + (* The spaces are real spaces *) + push_white n (match c with + | '[' -> + if i <= String.length str then match str.[i+1] with + (* Parse " [h .. ", *) + | 'h' when i+1 <= String.length str & str.[i+2] = 'v' -> + (parse_box (fun n -> PpHVB n) (i+3)) + (* Parse " [v .. ", *) + | 'v' -> + parse_box (fun n -> PpVB n) (i+2) + (* Parse " [ .. ", *) + | ' ' | '\'' -> + parse_box (fun n -> PpHOVB n) (i+1) + | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format" + else error "\"v\", \"hv\" or \" \" expected after \"[\" in format" + (* Parse "]" *) + | ']' -> + ([] :: parse_token (close_quotation (i+1))) + (* Parse a non formatting token *) + | c -> + let n = nonspaces true 0 i in + push_token (UnpTerminal (String.sub str (i-1) (n+2))) + (parse_token (close_quotation (i+n)))) + else + if n = 0 then [] + else error "Ending spaces non part of a format annotation" + and parse_box box i = + let n = spaces 0 i in + close_box i (box n) (parse_token (close_quotation (i+n))) + and parse_token i = + let n = spaces 0 i in + let i = i+n in + if i < l then match str.[i] with + (* Parse a ' *) + | '\'' when i+1 >= String.length str or str.[i+1] = ' ' -> + push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) + (* Parse the beginning of a quoted expression *) + | '\'' -> + parse_quoted (n-1) (i+1) + (* Otherwise *) + | _ -> + push_white (n-1) (parse_non_format i) + else push_white n [[]] + in + try + if str <> "" then match parse_token 0 with + | [l] -> l + | _ -> error "Box closed without being opened in format" + else + error "Empty format" + with e -> + Stdpp.raise_with_loc loc e + +(***********************) +(* Analysing notations *) + +open Symbols + +type symbol_token = WhiteSpace of int | String of string + +let split_notation_string str = + let push_token beg i l = + if beg = i then l else + let s = String.sub str beg (i - beg) in + String s :: l + in + let push_whitespace beg i l = + if beg = i then l else WhiteSpace (i-beg) :: l + in + let rec loop beg i = + if i < String.length str then + if str.[i] = ' ' then + push_token beg i (loop_on_whitespace (i+1) (i+1)) + else + loop beg (i+1) + else + push_token beg i [] + and loop_on_whitespace beg i = + if i < String.length str then + if str.[i] <> ' ' then + push_whitespace beg i (loop i (i+1)) + else + loop_on_whitespace beg (i+1) + else + push_whitespace beg i [] + in + loop 0 0 + +let unquote_notation_token s = + let n = String.length s in + if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s + +let is_normal_token str = + try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false + +(* To protect alphabetic tokens and quotes from being seen as variables *) +let quote_notation_token x = + let n = String.length x in + let norm = is_normal_token x in + if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'" + else x + +let rec raw_analyse_notation_tokens = function + | [] -> [], [] + | String ".." :: sl -> + let (vars,l) = raw_analyse_notation_tokens sl in + (list_add_set ldots_var vars, NonTerminal ldots_var :: l) + | String x :: sl when is_normal_token x -> + Lexer.check_ident x; + let id = Names.id_of_string x in + let (vars,l) = raw_analyse_notation_tokens sl in + if List.mem id vars then + error ("Variable "^x^" occurs more than once"); + (id::vars, NonTerminal id :: l) + | String s :: sl -> + Lexer.check_keyword s; + let (vars,l) = raw_analyse_notation_tokens sl in + (vars, Terminal (unquote_notation_token s) :: l) + | WhiteSpace n :: sl -> + let (vars,l) = raw_analyse_notation_tokens sl in + (vars, Break n :: l) + +let rec find_pattern xl = function + | Break n as x :: l, Break n' :: l' when n=n' -> + find_pattern (x::xl) (l,l') + | Terminal s as x :: l, Terminal s' :: l' when s = s' -> + find_pattern (x::xl) (l,l') + | [NonTerminal x], NonTerminal x' :: l' -> + (x,x',xl),l' + | [NonTerminal _], Terminal s :: _ | Terminal s :: _, _ -> + error ("The token "^s^" occurs on one side of \"..\" but not on the other side") + | [NonTerminal _], Break s :: _ | Break s :: _, _ -> + error ("A break occurs on one side of \"..\" but not on the other side") + | ((SProdList _ | NonTerminal _) :: _ | []), _ -> + error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\"") + +let rec interp_list_parser hd = function + | [] -> [], List.rev hd + | NonTerminal id :: tl when id = ldots_var -> + let ((x,y,sl),tl') = find_pattern [] (hd,tl) in + let yl,tl'' = interp_list_parser [] tl' in + (* We remember the second copy of each recursive part variable to *) + (* remove it afterwards *) + y::yl, SProdList (x,sl) :: tl'' + | (Terminal _ | Break _) as s :: tl -> + if hd = [] then + let yl,tl' = interp_list_parser [] tl in + yl, s :: tl' + else + interp_list_parser (s::hd) tl + | NonTerminal _ as x :: tl -> + let yl,tl' = interp_list_parser [x] tl in + yl, List.rev_append hd tl' + | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser" + +let analyse_notation_tokens l = + let vars,l = raw_analyse_notation_tokens l in + let recvars,l = interp_list_parser [] l in + ((if recvars = [] then [] else ldots_var::recvars), vars, l) + +let remove_vars = List.fold_right List.remove_assoc + +(* Build the syntax and grammar rules *) + +type printing_precedence = int * parenRelation +type parsing_precedence = int option + +let prec_assoc = function + | Gramext.RightA -> (L,E) + | Gramext.LeftA -> (E,L) + | Gramext.NonA -> (L,L) + +(* For old ast printer *) +let meta_pattern m = Pmeta(m,Tany) + +type white_status = Juxtapose | Separate of int | NextIsTerminal + +let precedence_of_entry_type from = function + | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n + | ETConstr (NumLevel n,BorderProd (left,Some a)) -> + n, let (lp,rp) = prec_assoc a in if left then lp else rp + | ETConstr (NumLevel n,InternalProd) -> n, Prec n + | ETConstr (NextLevel,_) -> from, L + | ETOther ("constr","annot") -> 10, Prec 10 + | _ -> 0, E (* ?? *) + +(* Some breaking examples *) +(* "x = y" : "x /1 = y" (breaks before any symbol) *) +(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*) +(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *) +(* "x y" : "x spc y" *) +(* "{ x } + { y }" : "{ x } / + { y }" *) +(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *) + +let is_left_bracket s = + let l = String.length s in l <> 0 & + (s.[0] = '{' or s.[0] = '[' or s.[0] = '(') + +let is_right_bracket s = + let l = String.length s in l <> 0 & + (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')') + +let is_left_bracket_on_left s = + let l = String.length s in l <> 0 & s.[l-1] = '>' + +let is_right_bracket_on_right s = + let l = String.length s in l <> 0 & s.[0] = '<' + +let is_comma s = + let l = String.length s in l <> 0 & + (s.[0] = ',' or s.[0] = ';') + +let is_operator s = + let l = String.length s in l <> 0 & + (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or + s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or + s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~') + +type previous_prod_status = NoBreak | CanBreak + +let rec is_non_terminal = function + | NonTerminal _ | SProdList _ -> true + | _ -> false + +let add_break n l = UNP_BRK (n,1) :: l + +(* For old ast printer *) +let make_hunks_ast symbols etyps from = + let rec make ws = function + | NonTerminal m :: prods -> + let _,lp = precedence_of_entry_type from (List.assoc m etyps) in + let u = PH (meta_pattern (string_of_id m), None, lp) in + if prods <> [] && is_non_terminal (List.hd prods) then + u :: add_break 1 (make CanBreak prods) + else + u :: make CanBreak prods + + | Terminal s :: prods when List.exists is_non_terminal prods -> + let protect = + is_letter s.[0] || + (is_non_terminal (List.hd prods) && + (is_letter (s.[String.length s -1])) || + (is_digit (s.[String.length s -1]))) in + if is_comma s || is_right_bracket s then + RO s :: add_break 0 (make NoBreak prods) + else if (is_operator s || is_left_bracket s) && ws = CanBreak then + add_break (if protect then 1 else 0) + (RO (if protect then s^" " else s) :: make CanBreak prods) + else + if protect then + (if ws = CanBreak then add_break 1 else (fun x -> x)) + (RO (s^" ") :: make CanBreak prods) + else + RO s :: make CanBreak prods + + | Terminal s :: prods -> + RO s :: make NoBreak prods + + | Break n :: prods -> + add_break n (make NoBreak prods) + + | SProdList _ :: _ -> + anomaly "Recursive notations not supported in old syntax" + + | [] -> [] + + in make NoBreak symbols + +let add_break n l = UnpCut (PpBrk(n,0)) :: l + +let make_hunks etyps symbols from = + let vars,typs = List.split etyps in + let rec make ws = function + | NonTerminal m :: prods -> + let i = list_index m vars in + let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let u = UnpMetaVar (i ,prec) in + if prods <> [] && is_non_terminal (List.hd prods) then + u :: add_break 1 (make CanBreak prods) + else + u :: make CanBreak prods + + | Terminal s :: prods when List.exists is_non_terminal prods -> + if is_comma s then + UnpTerminal s :: add_break 1 (make NoBreak prods) + else if is_right_bracket s then + UnpTerminal s :: add_break 0 (make NoBreak prods) + else if is_left_bracket s then + if ws = CanBreak then + add_break 1 (UnpTerminal s :: make CanBreak prods) + else + UnpTerminal s :: make CanBreak prods + else if is_operator s then + if ws = CanBreak then + UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods) + else + UnpTerminal s :: add_break 1 (make NoBreak prods) + else if is_ident_tail s.[String.length s - 1] then + if ws = CanBreak then + add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods) + else + UnpTerminal (s^" ") :: make CanBreak prods + else if ws = CanBreak then + add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods) + else + UnpTerminal s :: make CanBreak prods + + | Terminal s :: prods -> + if is_right_bracket s then + UnpTerminal s ::make NoBreak prods + else if ws = CanBreak then + add_break 1 (UnpTerminal s :: make NoBreak prods) + else + UnpTerminal s :: make NoBreak prods + + | Break n :: prods -> + add_break n (make NoBreak prods) + + | SProdList (m,sl) :: prods -> + let i = list_index m vars in + let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + (* We add NonTerminal for simulation but remove it afterwards *) + let _,sl' = list_sep_last (make NoBreak (sl@[NonTerminal m])) in + UnpListMetaVar (i,prec,sl') :: make CanBreak prods + + | [] -> [] + + in make NoBreak symbols + +let hunks_of_format (from,(vars,typs) as vt) symfmt = + let rec aux = function + | symbs, (UnpTerminal s' as u) :: fmt + when s' = String.make (String.length s') ' ' -> + let symbs, l = aux (symbs,fmt) in symbs, u :: l + | Terminal s :: symbs, (UnpTerminal s' as u) :: fmt + when s = unquote_notation_token s' -> + let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l + | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' -> + let i = list_index s vars in + let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in + let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l + | symbs, UnpBox (a,b) :: fmt -> + let symbs', b' = aux (symbs,b) in + let symbs', l = aux (symbs',fmt) in + symbs', UnpBox (a,b') :: l + | symbs, (UnpCut _ as u) :: fmt -> + let symbs, l = aux (symbs,fmt) in symbs, u :: l + | symbs, [] -> symbs, [] + | _, _ -> error "The format does not match the notation" + in + match aux symfmt with + | [], l -> l + | _ -> error "The format does not match the notation" + +let string_of_prec (n,p) = + (string_of_int n)^(match p with E -> "E" | L -> "L" | _ -> "") + +let assoc_of_type n (_,typ) = precedence_of_entry_type n typ + +let string_of_assoc = function + | Some(Gramext.RightA) -> "RIGHTA" + | Some(Gramext.LeftA) | None -> "LEFTA" + | Some(Gramext.NonA) -> "NONA" + +let is_not_small_constr = function + ETConstr _ -> true + | ETOther("constr","binder_constr") -> true + | _ -> false + +let rec define_keywords = function + NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l + when not !Options.v7 && is_not_small_constr e -> + prerr_endline ("Defining '"^k^"' as keyword"); + Lexer.add_token("",k); + n1 :: Term("",k) :: define_keywords l + | n :: l -> n :: define_keywords l + | [] -> [] + +let define_keywords = function + Term("IDENT",k)::l when not !Options.v7 -> + prerr_endline ("Defining '"^k^"' as keyword"); + Lexer.add_token("",k); + Term("",k) :: define_keywords l + | l -> define_keywords l + +let make_production etyps symbols = + let prod = + List.fold_right + (fun t l -> match t with + | NonTerminal m -> + let typ = List.assoc m etyps in + NonTerm (typ, Some (m,typ)) :: l + | Terminal s -> + Term (Extend.terminal s) :: l + | Break _ -> + l + | SProdList (x,sl) -> + let sl = List.flatten + (List.map (function Terminal s -> [Extend.terminal s] + | Break _ -> [] + | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in + let y = match List.assoc x etyps with + | ETConstr x -> x + | _ -> + error "Component of recursive patterns in notation must be constr" in + let typ = ETConstrList (y,sl) in + NonTerm (typ, Some (x,typ)) :: l) + symbols [] in + define_keywords prod + +let rec find_symbols c_current c_next c_last = function + | [] -> [] + | NonTerminal id :: sl -> + let prec = if sl <> [] then c_current else c_last in + (id, prec) :: (find_symbols c_next c_next c_last sl) + | Terminal s :: sl -> find_symbols c_next c_next c_last sl + | Break n :: sl -> find_symbols c_current c_next c_last sl + | SProdList (x,_) :: sl' -> + (x,c_next)::(find_symbols c_next c_next c_last sl') + +let border = function + | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a + | _ -> None + +let recompute_assoc typs = + match border typs, border (List.rev typs) with + | Some Gramext.LeftA, Some Gramext.RightA -> assert false + | Some Gramext.LeftA, _ -> Some Gramext.LeftA + | _, Some Gramext.RightA -> Some Gramext.RightA + | _ -> None + +let rec expand_squash = function + | Term ("","{") :: NonTerm (ETConstr _, n) :: Term ("","}") :: l -> + NonTerm (ETConstr (NextLevel,InternalProd),n) + :: expand_squash l + | a :: l -> a :: expand_squash l + | [] -> [] + +let make_grammar_rule n typs symbols ntn perm = + let assoc = recompute_assoc typs in + let prod = make_production typs symbols in + (n,assoc,ntn,prod, perm) + +(* For old ast printer *) +let metas_of sl = + List.fold_right + (fun it metatl -> match it with + | NonTerminal m -> m::metatl + | _ -> metatl) + sl [] + +(* For old ast printer *) +let make_pattern symbols ast = + let env = List.map (fun m -> (string_of_id m,ETast)) (metas_of symbols) in + fst (to_pat env ast) + +(* For old ast printer *) +let make_syntax_rule n name symbols typs ast ntn sc = + [{syn_id = name; + syn_prec = n; + syn_astpat = make_pattern symbols ast; + syn_hunks = + [UNP_SYMBOLIC(sc,ntn,UNP_BOX (PpHOVB 1,make_hunks_ast symbols typs n))]}] + +let make_pp_rule (n,typs,symbols,fmt) = + match fmt with + | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)] + | Some fmt -> + [UnpBox (PpHOVB 0, + hunks_of_format (n,List.split typs) (symbols,parse_format fmt))] + +(**************************************************************************) +(* Syntax extenstion: common parsing/printing rules and no interpretation *) + +(* v7 and translator : prec is for v7 (None if V8Notation), prec8 is for v8 *) +(* v8 : prec is for v8, prec8 is the same *) + +let pr_arg_level from = function + | (n,L) when n=from -> str "at next level" + | (n,E) -> str "at level " ++ int n + | (n,L) -> str "at level below " ++ int n + | (n,Prec m) when m=n -> str "at level " ++ int n + | (n,_) -> str "Unknown level" + +let pr_level ntn (from,args) = + let lopen = ntn.[0] = '_' and ropen = ntn.[String.length ntn - 1] = '_' in +(* + let ppassoc, args = match args with + | [] -> mt (), [] + | (nl,lpr)::l when nl=from & fst (list_last l)=from -> + let (_,rpr),l = list_sep_last l in + match lpr, snd (list_last l) with + | L,E -> Gramext.RightA, l + | E,L -> Gramext.LeftA, l + | L,L -> Gramext.NoneA, l + | _ -> args +*) + str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ + prlist_with_sep pr_coma (pr_arg_level from) args + +let cache_syntax_extension (_,(_,(prec,prec8),ntn,gr,se)) = + try + let oldprec, oldprec8 = Symbols.level_of_notation ntn in + if prec8 <> oldprec8 & (Options.do_translate () or not !Options.v7) then + errorlabstrm "" + (str ((if Options.do_translate () then "For new syntax, notation " + else "Notation ") + ^ntn^" is already defined") ++ spc() ++ pr_level ntn oldprec8 ++ + spc() ++ str "while it is now required to be" ++ spc() ++ + pr_level ntn prec8) + else + (* Inconsistent v8 notations but not while translating; forget... *) + (); + (* V8 notations are consistent (from both translator or v8) *) + if prec <> None & !Options.v7 then begin + (* Update the V7 parsing rule *) + if oldprec <> None & out_some oldprec <> out_some prec then + (* None of them is V8Notation and they are different: warn *) + Options.if_verbose + warning ("Notation "^ntn^ + " was already assigned a different level or sublevels"); + if oldprec = None or out_some oldprec <> out_some prec then + Egrammar.extend_grammar (Egrammar.Notation (out_some gr)) + end + with Not_found -> + (* Reserve the notation level *) + Symbols.declare_notation_level ntn (prec,prec8); + (* Declare the parsing rule *) + option_iter (fun gr -> Egrammar.extend_grammar (Egrammar.Notation gr)) gr; + (* Declare the printing rule *) + Symbols.declare_notation_printing_rule ntn (se,fst prec8) + +let subst_notation_grammar subst x = x + +let subst_printing_rule subst x = x + +let subst_syntax_extension (_,subst,(local,prec,ntn,gr,se)) = + (local,prec,ntn, + option_app (subst_notation_grammar subst) gr, + subst_printing_rule subst se) + +let classify_syntax_definition (_,(local,_,_,_,_ as o)) = + if local then Dispose else Substitute o + +let export_syntax_definition (local,_,_,_,_ as o) = + if local then None else Some o + +let (inSyntaxExtension, outSyntaxExtension) = + declare_object {(default_object "SYNTAX-EXTENSION") with + open_function = (fun i o -> if i=1 then cache_syntax_extension o); + cache_function = cache_syntax_extension; + subst_function = subst_syntax_extension; + classify_function = classify_syntax_definition; + export_function = export_syntax_definition} + +let interp_modifiers = + let onlyparsing = ref false in + let rec interp assoc level etyps format = function + | [] -> + (assoc,level,etyps,!onlyparsing,format) + | SetEntryType (s,typ) :: l -> + let id = id_of_string s in + if List.mem_assoc id etyps then + error (s^" is already assigned to an entry or constr level") + else interp assoc level ((id,typ)::etyps) format l + | SetItemLevel ([],n) :: l -> + interp assoc level etyps format l + | SetItemLevel (s::idl,n) :: l -> + let id = id_of_string s in + if List.mem_assoc id etyps then + error (s^" is already assigned to an entry or constr level") + else + let typ = ETConstr (n,()) in + interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l) + | SetLevel n :: l -> + if level <> None then error "A level is given more than once" + else interp assoc (Some n) etyps format l + | SetAssoc a :: l -> + if assoc <> None then error "An associativity is given more than once" + else interp (Some a) level etyps format l + | SetOnlyParsing :: l -> + onlyparsing := true; + interp assoc level etyps format l + | SetFormat s :: l -> + if format <> None then error "A format is given more than once" + onlyparsing := true; + interp assoc level etyps (Some s) l + in interp None None [] None + +let merge_modifiers a n l = + (match a with None -> [] | Some a -> [SetAssoc a]) @ + (match n with None -> [] | Some n -> [SetLevel n]) @ l + +let interp_infix_modifiers modl = + let (assoc,level,t,b,fmt) = interp_modifiers modl in + if t <> [] then + error "explicit entry level or type unexpected in infix notation"; + (assoc,level,b,fmt) + +(* 2nd list of types has priority *) +let rec merge_entry_types etyps' = function + | [] -> etyps' + | (x,_ as e)::etyps -> + e :: merge_entry_types (List.remove_assoc x etyps') etyps + +let set_entry_type etyps (x,typ) = + let typ = try + match List.assoc x etyps, typ with + | ETConstr (n,()), (_,BorderProd (left,_)) -> + ETConstr (n,BorderProd (left,None)) + | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd) + | (ETPattern | ETIdent | ETBigint | ETOther _ | ETReference as t), _ -> t + | (ETConstrList _, _) -> assert false + with Not_found -> ETConstr typ + in (x,typ) + +let check_rule_reversibility l = + if List.for_all (function NonTerminal _ -> true | _ -> false) l then + error "A notation must include at least one symbol" + +let find_precedence_v7 lev etyps symbols = + (match symbols with + | NonTerminal x :: _ -> + (try match List.assoc x etyps with + | ETConstr _ -> + error "The level of the leftmost non-terminal cannot be changed" + | _ -> () + with Not_found -> ()) + | _ -> ()); + if lev = None then 1 else out_some lev + +let find_precedence lev etyps symbols = + match symbols with + | NonTerminal x :: _ -> + (try match List.assoc x etyps with + | ETConstr _ -> + error "The level of the leftmost non-terminal cannot be changed" + | ETIdent | ETBigint | ETReference -> + if lev = None then + Options.if_verbose msgnl (str "Setting notation at level 0") + else + if lev <> Some 0 then + error "A notation starting with an atomic expression must be at level 0"; + 0 + | ETPattern | ETOther _ -> (* Give a default ? *) + if lev = None then + error "Need an explicit level" + else out_some lev + | ETConstrList _ -> assert false (* internally used in grammar only *) + with Not_found -> + if lev = None then + error "A left-recursive notation must have an explicit level" + else out_some lev) + | Terminal _ ::l when + (match list_last symbols with Terminal _ -> true |_ -> false) + -> + if lev = None then + (Options.if_verbose msgnl (str "Setting notation at level 0"); 0) + else out_some lev + | _ -> + if lev = None then error "Cannot determine the level"; + out_some lev + +let check_curly_brackets_notation_exists () = + try let _ = Symbols.level_of_notation "{ _ }" in () + with Not_found -> + error "Notations involving patterns of the form \"{ _ }\" are treated \n\ +specially and require that the notation \"{ _ }\" is already reserved" + +(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) +let remove_curly_brackets l = + let rec next = function + | Break _ :: l -> next l + | l -> l in + let rec aux deb = function + | [] -> [] + | Terminal "{" as t1 :: l -> + (match next l with + | NonTerminal _ as x :: l' as l0 -> + (match next l' with + | Terminal "}" as t2 :: l'' as l1 -> + if l <> l0 or l' <> l1 then + warning "Skipping spaces inside curly brackets"; + if deb & l'' = [] then [t1;x;t2] else begin + check_curly_brackets_notation_exists (); + x :: aux false l'' + end + | l1 -> t1 :: x :: aux false l1) + | l0 -> t1 :: aux false l0) + | x :: l -> x :: aux false l + in aux true l + +let compute_syntax_data forv7 (df,modifiers) = + let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in + (* Notation defaults to NONA *) + let assoc = match assoc with None -> Some Gramext.NonA | a -> a in + let toks = split_notation_string df in + let (recvars,vars,symbols) = analyse_notation_tokens toks in + let ntn_for_interp = make_notation_key symbols in + let symbols = remove_curly_brackets symbols in + let notation = make_notation_key symbols in + check_rule_reversibility symbols; + let n = + if !Options.v7 then find_precedence_v7 n etyps symbols + else find_precedence n etyps symbols in + let innerlevel = NumLevel (if forv7 then 10 else 200) in + let typs = + find_symbols + (NumLevel n,BorderProd(true,assoc)) + (innerlevel,InternalProd) + (NumLevel n,BorderProd(false,assoc)) + symbols in + (* To globalize... *) + let typs = List.map (set_entry_type etyps) typs in + let ppdata = (n,typs,symbols,fmt) in + let prec = (n,List.map (assoc_of_type n) typs) in + ((onlyparse,recvars,vars, + ntn_for_interp,notation),prec,ppdata,(Lib.library_dp(),df)) + +let add_syntax_extension local mv mv8 = + let data8 = option_app (compute_syntax_data false) mv8 in + let data = option_app (compute_syntax_data !Options.v7) mv in + let prec,gram_rule = match data with + | None -> None, None + | Some ((_,_,_,_,notation),prec,(n,typs,symbols,_),_) -> + Some prec, Some (make_grammar_rule n typs symbols notation None) in + match data, data8 with + | None, None -> (* Nothing to do: V8Notation while not translating *) () + | _, Some d | Some d, None -> + let ((_,_,_,_,ntn),ppprec,ppdata,_) = d in + let ntn' = match data with Some ((_,_,_,_,ntn),_,_,_) -> ntn | _ -> ntn in + let pp_rule = make_pp_rule ppdata in + Lib.add_anonymous_leaf + (inSyntaxExtension (local,(prec,ppprec),ntn',gram_rule,pp_rule)) + +(**********************************************************************) +(* Distfix, Infix, Symbols *) + +(* A notation comes with a grammar rule, a pretty-printing rule, an + identifiying pattern called notation and an associated scope *) +let load_notation _ (_,(_,_,ntn,scope,pat,onlyparse,_,_)) = + option_iter Symbols.declare_scope scope + +let open_notation i (_,(_,oldse,ntn,scope,pat,onlyparse,pp8only,df)) = + if i=1 then begin + let b,oldpp8only = Symbols.exists_notation_in_scope scope ntn pat in + (* Declare the old printer rule and its interpretation *) + if (not b or oldpp8only) & oldse <> None then + Esyntax.add_ppobject {sc_univ="constr";sc_entries=out_some oldse}; + (* Declare the interpretation *) + if not b then + Symbols.declare_notation_interpretation ntn scope pat df pp8only; + if oldpp8only & not pp8only then + Options.silently + (Symbols.declare_notation_interpretation ntn scope pat df) pp8only; + if not b & not onlyparse then + Symbols.declare_uninterpretation (NotationRule (scope,ntn)) pat + end + +let cache_notation o = + load_notation 1 o; + open_notation 1 o + +let subst_notation (_,subst,(lc,oldse,ntn,scope,(metas,pat),b,b',df)) = + (lc,option_app + (list_smartmap (Extend.subst_syntax_entry Ast.subst_astpat subst)) oldse, + ntn,scope, + (metas,subst_aconstr subst pat), b, b', df) + +let classify_notation (_,(local,_,_,_,_,_,_,_ as o)) = + if local then Dispose else Substitute o + +let export_notation (local,_,_,_,_,_,_,_ as o) = + if local then None else Some o + +let (inNotation, outNotation) = + declare_object {(default_object "NOTATION") with + open_function = open_notation; + cache_function = cache_notation; + subst_function = subst_notation; + load_function = load_notation; + classify_function = classify_notation; + export_function = export_notation} + +(* For old ast printer *) +let rec reify_meta_ast vars = function + | Smetalam (loc,s,body) -> Smetalam (loc,s,reify_meta_ast vars body) +(* | Node(loc,"META",[Num (_,n)]) -> Nmeta (loc,create_meta n)*) + | Node(loc,"ISEVAR",[]) -> Nmeta (loc,"$_") + | Node(loc,op,args) -> Node (loc,op, List.map (reify_meta_ast vars) args) + | Slam(loc,Some id,body) when List.mem id vars -> + Smetalam (loc,string_of_id id,reify_meta_ast vars body) + | Slam(loc,na,body) -> Slam(loc,na,reify_meta_ast vars body) + | Nvar (loc,id) when List.mem id vars -> Nmeta (loc,string_of_id id) + | Nmeta _ | Id _ | Nvar _ | Str _ | Num _ | Path _ as a -> a + | Dynamic _ as a -> (* Hum... what to do here *) a + +(* For old ast syntax *) +let make_old_pp_rule n symbols typs r ntn scope vars = + let ast = Termast.ast_of_rawconstr r in + let ast = reify_meta_ast vars ast in + let scope_name = match scope with Some s -> s | None -> "core_scope" in + let rule_name = ntn^"_"^scope_name^"_notation" in + make_syntax_rule n rule_name symbols typs ast ntn scope + +(* maps positions in v8-notation into positions in v7-notation (used + for parsing). + For instance Notation "x < y < z" := .. V8only "y < z < x" + yields [1; 2; 0] (y is the second arg in v7; z is 3rd; x is fst) *) +let mk_permut vars7 vars8 = + if vars7=vars8 then None else + Some + (List.fold_right + (fun v8 subs -> list_index v8 vars7 - 1 :: subs) + vars8 []) + +let contract_notation ntn = + if ntn = "{ _ }" then ntn else + let rec aux ntn i = + if i <= String.length ntn - 5 then + let ntn' = + if String.sub ntn i 5 = "{ _ }" then + String.sub ntn 0 i ^ "_" ^ + String.sub ntn (i+5) (String.length ntn -i-5) + else ntn in + aux ntn' (i+1) + else ntn in + aux ntn 0 + +let add_notation_in_scope local df c mods omodv8 scope toks = + let ((onlyparse,recs,vars,intnot,notation),prec,(n,typs,symbols,_ as ppdata),df')= + compute_syntax_data !Options.v7 (df,mods) in + (* Declare the parsing and printing rules if not already done *) + (* For both v7 and translate: parsing is as described for v7 in v7 file *) + (* For v8: parsing is as described in v8 file *) + (* For v7: printing is by the old printer - see below *) + (* For translate: printing is as described for v8 in v7 file *) + (* For v8: printing is as described in v8 file *) + (* In short: parsing does not depend on omodv8 *) + (* Printing depends on mv8 if defined, otherwise of mods (scaled by 10) *) + (* if in v7, or of mods without scaling if in v8 *) + let intnot,ntn,pprecvars,ppvars,ppprec,pp_rule = + match omodv8 with + | Some mv8 -> + let (_,recs8,vars8,intnot8,ntn8),p,d,_ = compute_syntax_data false mv8 in + intnot8,ntn8,recs8,vars8,p,make_pp_rule d + | None when not !Options.v7 -> + intnot,notation,recs,vars,prec,make_pp_rule ppdata + | None -> + (* means the rule already exists: recover it *) + (* occurs only with V8only flag alone *) + try + let ntn = contract_notation notation in + let _, oldprec8 = Symbols.level_of_notation ntn in + let rule,_ = Symbols.find_notation_printing_rule ntn in + notation,ntn,recs,vars,oldprec8,rule + with Not_found -> error "No known parsing rule for this notation in V8" + in + let permut = mk_permut vars ppvars in + let gram_rule = make_grammar_rule n typs symbols ntn permut in + Lib.add_anonymous_leaf + (inSyntaxExtension + (local,(Some prec,ppprec),ntn,Some gram_rule,pp_rule)); + + (* Declare interpretation *) + let (acvars,ac) = interp_aconstr [] ppvars c in + let a = (remove_vars pprecvars acvars,ac) (* For recursive parts *) in + let old_pp_rule = + (* Used only by v7; disable if contains a recursive pattern *) + if onlyparse or pprecvars <> [] then None + else + let r = interp_global_rawconstr_with_vars vars c in + Some (make_old_pp_rule n symbols typs r intnot scope vars) in + let onlyparse = onlyparse or !Options.v7_only in + Lib.add_anonymous_leaf + (inNotation(local,old_pp_rule,intnot,scope,a,onlyparse,false,df')) + +let level_rule (n,p) = if p = E then n else max (n-1) 0 + +let check_notation_existence notation = + try + let a,_ = Symbols.level_of_notation (contract_notation notation) in + if a = None then raise Not_found + with Not_found -> + error "Parsing rule for this notation has to be previously declared" + +let exists_notation_syntax ntn = + try fst (Symbols.level_of_notation (contract_notation ntn)) <> None + with Not_found -> false + +let set_data_for_v7_pp recs a vars = + if not !Options.v7 then None else + if recs=[] then Some (a,vars) + else (warning "No recursive notation in v7 syntax";None) + +let build_old_pp_rule notation scope symbs (r,vars) = + let prec = + try + let a,_ = Symbols.level_of_notation (contract_notation notation) in + if a = None then raise Not_found else out_some a + with Not_found -> + error "Parsing rule for this notation has to be previously declared" in + let typs = List.map2 + (fun id n -> + id,ETConstr (NumLevel (level_rule n),InternalProd)) vars (snd prec) in + make_old_pp_rule (fst prec) symbs typs r notation scope vars + +let add_notation_interpretation_core local symbs for_old df a scope onlyparse + onlypp = + let notation = make_notation_key symbs in + let old_pp_rule = + if !Options.v7 then + option_app (build_old_pp_rule notation scope symbs) for_old + else None in + Lib.add_anonymous_leaf + (inNotation(local,old_pp_rule,notation,scope,a,onlyparse,onlypp, + (Lib.library_dp(),df))) + +let add_notation_interpretation df names c sc = + let (recs,vars,symbs) = analyse_notation_tokens (split_notation_string df) in + check_notation_existence (make_notation_key symbs); + let (acvars,ac) = interp_aconstr names vars c in + let a = (remove_vars recs acvars,ac) (* For recursive parts *) in + let a_for_old = interp_rawconstr_with_implicits Evd.empty (Global.env()) vars names c in + let for_oldpp = set_data_for_v7_pp recs a_for_old vars in + add_notation_interpretation_core false symbs for_oldpp df a sc false false + +let add_notation_in_scope_v8only local df c mv8 scope toks = + let (_,recs,vars,intnot,notation),prec,ppdata,df' = compute_syntax_data false (df,mv8) in + let pp_rule = make_pp_rule ppdata in + Lib.add_anonymous_leaf + (inSyntaxExtension(local,(None,prec),notation,None,pp_rule)); + (* Declare the interpretation *) + let onlyparse = false in + let (acvars,ac) = interp_aconstr [] vars c in + let a = (remove_vars recs acvars,ac) (* For recursive parts *) in + Lib.add_anonymous_leaf + (inNotation(local,None,intnot,scope,a,onlyparse,true,df')) + +let add_notation_v8only local c (df,modifiers) sc = + let toks = split_notation_string df in + match toks with + | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) -> + (* This is a ident to be declared as a rule *) + add_notation_in_scope_v8only local df c (SetLevel 0::modifiers) sc toks + | _ -> + let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers in + match lev with + | None-> + if modifiers <> [] & modifiers <> [SetOnlyParsing] then + error "Parsing rule for this notation includes no level" + else + (* Declare only interpretation *) + let (recs,vars,symbs) = analyse_notation_tokens toks in + let onlyparse = modifiers = [SetOnlyParsing] in + let (acvars,ac) = interp_aconstr [] vars c in + let a = (remove_vars recs acvars,ac) in + add_notation_interpretation_core local symbs None df a sc + onlyparse true + | Some n -> + (* Declare both syntax and interpretation *) + let mods = + if List.for_all (function SetAssoc _ -> false | _ -> true) + modifiers + then SetAssoc Gramext.NonA :: modifiers else modifiers in + add_notation_in_scope_v8only local df c mods sc toks + +let is_quoted_ident x = + let x' = unquote_notation_token x in + x <> x' & try Lexer.check_ident x'; true with _ -> false + +let add_notation local c dfmod mv8 sc = + match dfmod with + | None -> add_notation_v8only local c (out_some mv8) sc + | Some (df,modifiers) -> + let toks = split_notation_string df in + match toks with + | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) -> + (* This is a ident to be declared as a rule *) + add_notation_in_scope local df c (SetLevel 0::modifiers) mv8 sc toks + | _ -> + let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers in + match lev with + | None-> + if modifiers <> [] & modifiers <> [SetOnlyParsing] then + error "Parsing rule for this notation includes no level" + else + (* Declare only interpretation *) + let (recs,vars,symbs) = analyse_notation_tokens toks in + if exists_notation_syntax (make_notation_key symbs) then + let onlyparse = modifiers = [SetOnlyParsing] in + let (acvars,ac) = interp_aconstr [] vars c in + let a = (remove_vars recs acvars,ac) in + let a_for_old = interp_global_rawconstr_with_vars vars c in + let for_old = set_data_for_v7_pp recs a_for_old vars in + add_notation_interpretation_core local symbs for_old df a + sc onlyparse false + else + add_notation_in_scope local df c modifiers mv8 sc toks + | Some n -> + (* Declare both syntax and interpretation *) + let assoc = match assoc with None -> Some Gramext.NonA | a -> a in + add_notation_in_scope local df c modifiers mv8 sc toks + +(* TODO add boxes information in the expression *) + +let inject_var x = CRef (Ident (dummy_loc, id_of_string x)) + +let rec rename x vars n = function + | [] -> + (vars,[]) + | String "_"::l -> + let (vars,l) = rename x vars (n+1) l in + let xn = x^(string_of_int n) in + ((inject_var xn)::vars,xn::l) + | String y::l -> + let (vars,l) = rename x vars n l in (vars,(quote_notation_token y)::l) + | WhiteSpace _::l -> + rename x vars n l + +let translate_distfix assoc df r = + let (vars,l) = rename "x" [] 1 (split_notation_string df) in + let df = String.concat " " l in + let a = mkAppC (mkRefC r, vars) in + let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in + (assoc,df,a) + +let add_distfix local assoc n df r sc = + (* "x" cannot clash since r is globalized (included section vars) *) + let (vars,l) = rename "x" [] 1 (split_notation_string df) in + let df = String.concat " " l in + let a = mkAppC (mkRefC r, vars) in + let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in + add_notation_in_scope local df a [SetAssoc assoc;SetLevel n] None sc + (split_notation_string df) + +let make_infix_data n assoc modl mv8 = + (* Infix defaults to LEFTA in V7 (cf doc) *) + let mv = match n with None when !Options.v7 -> SetLevel 1 :: modl | _ -> modl in + let mv = match assoc with None when !Options.v7 -> SetAssoc Gramext.LeftA :: mv | _ -> mv in + let mv8 = match mv8 with + None -> None + | Some(s8,mv8) -> + if List.for_all (function SetLevel _ -> false | _ -> true) mv8 then + error "Needs a level" + else Some (("x "^quote_notation_token s8^" y"),mv8) in + mv,mv8 + +let add_infix local (inf,modl) pr mv8 sc = + if inf="" (* Code for V8Infix only *) then + let (p8,mv8) = out_some mv8 in + let (a8,n8,onlyparse,fmt) = interp_infix_modifiers mv8 in + let metas = [inject_var "x"; inject_var "y"] in + let a = mkAppC (mkRefC pr,metas) in + let df = "x "^(quote_notation_token p8)^" y" in + let toks = split_notation_string df in + if a8=None & n8=None & fmt=None then + (* Declare only interpretation *) + let (recs,vars,symbs) = analyse_notation_tokens toks in + let (acvars,ac) = interp_aconstr [] vars a in + let a' = (remove_vars recs acvars,ac) in + let a_for_old = interp_global_rawconstr_with_vars vars a in + add_notation_interpretation_core local symbs None df a' sc + onlyparse true + else + if n8 = None then error "Needs a level" else + let mv8 = match a8 with None -> SetAssoc Gramext.NonA :: mv8 |_ -> mv8 in + add_notation_in_scope_v8only local df a mv8 sc toks + else begin + let (assoc,n,onlyparse,fmt) = interp_infix_modifiers modl in + (* check the precedence *) + if !Options.v7 & (n<> None & (out_some n < 1 or out_some n > 10)) then + errorlabstrm "Metasyntax.infix_grammar_entry" + (str"Precedence must be between 1 and 10."); + (* + if (assoc<>None) & (n<6 or n>9) then + errorlabstrm "Vernacentries.infix_grammar_entry" + (str"Associativity Precedence must be 6,7,8 or 9."); + *) + let metas = [inject_var "x"; inject_var "y"] in + let a = mkAppC (mkRefC pr,metas) in + let df = "x "^(quote_notation_token inf)^" y" in + let toks = split_notation_string df in + if not !Options.v7 & n=None & assoc=None then + (* En v8, une notation sans information de parsing signifie *) + (* de ne déclarer que l'interprétation *) + (* Declare only interpretation *) + let (recs,vars,symbs) = analyse_notation_tokens toks in + if exists_notation_syntax (make_notation_key symbs) then + let (acvars,ac) = interp_aconstr [] vars a in + let a' = (remove_vars recs acvars,ac) in + let a_for_old = interp_global_rawconstr_with_vars vars a in + let for_old = set_data_for_v7_pp recs a_for_old vars in + add_notation_interpretation_core local symbs for_old df a' sc + onlyparse false + else + let mv,mv8 = make_infix_data n assoc modl mv8 in + add_notation_in_scope local df a mv mv8 sc toks + else + let mv,mv8 = make_infix_data n assoc modl mv8 in + add_notation_in_scope local df a mv mv8 sc toks + end + +let standardise_locatable_notation ntn = + let unquote = function + | String s -> [unquote_notation_token s] + | _ -> [] in + if String.contains ntn ' ' then + String.concat " " + (List.flatten (List.map unquote (split_notation_string ntn))) + else + unquote_notation_token ntn + +(* Delimiters and classes bound to scopes *) +type scope_command = ScopeDelim of string | ScopeClasses of Classops.cl_typ + +let load_scope_command _ (_,(scope,dlm)) = + Symbols.declare_scope scope + +let open_scope_command i (_,(scope,o)) = + if i=1 then + match o with + | ScopeDelim dlm -> Symbols.declare_delimiters scope dlm + | ScopeClasses cl -> Symbols.declare_class_scope scope cl + +let cache_scope_command o = + load_scope_command 1 o; + open_scope_command 1 o + +let subst_scope_command (_,subst,(scope,o as x)) = match o with + | ScopeClasses cl -> + let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else + scope, ScopeClasses cl' + | _ -> x + +let (inScopeCommand,outScopeCommand) = + declare_object {(default_object "DELIMITERS") with + cache_function = cache_scope_command; + open_function = open_scope_command; + load_function = load_scope_command; + subst_function = subst_scope_command; + classify_function = (fun (_,obj) -> Substitute obj); + export_function = (fun x -> Some x) } + +let add_delimiters scope key = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) + +let add_class_scope scope cl = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli new file mode 100644 index 00000000..be90cd7a --- /dev/null +++ b/toplevel/metasyntax.mli @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: metasyntax.mli,v 1.26.2.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +(*i*) +open Util +open Libnames +open Ppextend +open Extend +open Tacexpr +open Vernacexpr +open Symbols +open Topconstr +(*i*) + +(* Adding grammar and pretty-printing objects in the environment *) + +val add_syntax_obj : string -> raw_syntax_entry list -> unit + +val add_grammar_obj : string -> raw_grammar_entry list -> unit +val add_token_obj : string -> unit +val add_tactic_grammar : + (string * (string * grammar_production list) * raw_tactic_expr) list -> unit + +val add_infix : locality_flag -> (string * syntax_modifier list) -> + reference -> (string * syntax_modifier list) option -> + scope_name option -> unit +val add_distfix : locality_flag -> + grammar_associativity -> precedence -> string -> reference + -> scope_name option -> unit +val translate_distfix : grammar_associativity -> string -> reference -> + Gramext.g_assoc * string * constr_expr + +val add_delimiters : scope_name -> string -> unit +val add_class_scope : scope_name -> Classops.cl_typ -> unit + +val add_notation : locality_flag -> constr_expr + -> (string * syntax_modifier list) option + -> (string * syntax_modifier list) option + -> scope_name option -> unit + +val add_notation_interpretation : string -> Constrintern.implicits_env + -> constr_expr -> scope_name option -> unit + +val add_syntax_extension : locality_flag + -> (string * syntax_modifier list) option + -> (string * syntax_modifier list) option -> unit + +val print_grammar : string -> string -> unit + +val merge_modifiers : Gramext.g_assoc option -> int option -> + syntax_modifier list -> syntax_modifier list + +val interp_infix_modifiers : syntax_modifier list -> + Gramext.g_assoc option * precedence option * bool * string located option + +val standardise_locatable_notation : string -> string diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml new file mode 100644 index 00000000..dcf3e307 --- /dev/null +++ b/toplevel/minicoq.ml @@ -0,0 +1,149 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: minicoq.ml,v 1.28.14.1 2004/07/16 19:31:49 herbelin Exp $ *) + +open Pp +open Util +open Names +open Term +open Sign +open Declarations +open Inductive +open Type_errors +open Safe_typing +open G_minicoq + +let (env : safe_environment ref) = ref empty_environment + +let locals () = + List.map (fun (id,b,t) -> (id, make_path [] id CCI)) + (named_context !env) + +let lookup_named id = + let rec look n = function + | [] -> mkVar id + | (Name id')::_ when id = id' -> mkRel n + | _::r -> look (succ n) r + in + look 1 + +let args sign = Array.of_list (instance_from_section_context sign) + +let rec globalize bv c = match kind_of_term c with + | Var id -> lookup_named id bv + | Const (sp, _) -> + let cb = lookup_constant sp !env in mkConst (sp, args cb.const_hyps) + | Ind (sp,_ as spi, _) -> + let mib = lookup_mind sp !env in mkMutInd (spi, args mib.mind_hyps) + | Construct ((sp,_),_ as spc, _) -> + let mib = lookup_mind sp !env in mkMutConstruct (spc, args mib.mind_hyps) + | _ -> map_constr_with_named_binders (fun na l -> na::l) globalize bv c + +let check c = + let c = globalize [] c in + let (j,u) = safe_infer !env c in + let ty = j_type j in + let pty = pr_term CCI (env_of_safe_env !env) ty in + mSGNL (hov 0 (str" :" ++ spc () ++ hov 0 pty ++ fnl ())) + +let definition id ty c = + let c = globalize [] c in + let ty = option_app (globalize []) ty in + let ce = { const_entry_body = c; const_entry_type = ty } in + let sp = make_path [] id CCI in + env := add_constant sp ce (locals()) !env; + mSGNL (hov 0 (pr_id id ++ spc () ++ str"is defined" ++ fnl ())) + +let parameter id t = + let t = globalize [] t in + let sp = make_path [] id CCI in + env := add_parameter sp t (locals()) !env; + mSGNL (hov 0 (str"parameter" ++ spc () ++ pr_id id ++ + spc () ++ str"is declared" ++ fnl ())) + +let variable id t = + let t = globalize [] t in + env := push_named_assum (id,t) !env; + mSGNL (hov 0 (str"variable" ++ spc () ++ pr_id id ++ + spc () ++ str"is declared" ++ fnl ())) + +let inductive par inds = + let nparams = List.length par in + let bvpar = List.rev (List.map (fun (id,_) -> Name id) par) in + let name_inds = List.map (fun (id,_,_) -> Name id) inds in + let bv = bvpar @ List.rev name_inds in + let npar = List.map (fun (id,c) -> (Name id, globalize [] c)) par in + let one_inductive (id,ar,cl) = + let cv = List.map (fun (_,c) -> prod_it (globalize bv c) npar) cl in + { mind_entry_nparams = nparams; + mind_entry_params = List.map (fun (id,c) -> (id, LocalAssum c)) par; + mind_entry_typename = id; + mind_entry_arity = prod_it (globalize bvpar ar) npar; + mind_entry_consnames = List.map fst cl; + mind_entry_lc = cv } + in + let inds = List.map one_inductive inds in + let mie = { + mind_entry_finite = true; + mind_entry_inds = inds } + in + let sp = + let mi1 = List.hd inds in + make_path [] mi1.mind_entry_typename CCI in + env := add_mind sp mie (locals()) !env; + mSGNL (hov 0 (str"inductive type(s) are declared" ++ fnl ())) + + +let execute = function + | Check c -> check c + | Definition (id, ty, c) -> definition id ty c + | Parameter (id, t) -> parameter id t + | Variable (id, t) -> variable id t + | Inductive (par,inds) -> inductive par inds + +let parse_file f = + let c = open_in f in + let cs = Stream.of_channel c in + try + while true do + let c = Grammar.Entry.parse command cs in execute c + done + with + | End_of_file | Stdpp.Exc_located (_, End_of_file) -> close_in c; exit 0 + | exn -> close_in c; raise exn + +module Explain = Fhimsg.Make(struct let pr_term = pr_term end) + +let rec explain_exn = function + | TypeError (k,ctx,te) -> + mSGNL (hov 0 (str "type error:" ++ spc () ++ + Explain.explain_type_error k ctx te ++ fnl ())) + | Stdpp.Exc_located (_,exn) -> + explain_exn exn + | exn -> + mSGNL (hov 0 (str"error: " ++ str (Printexc.to_string exn) ++ fnl ())) + +let top () = + let cs = Stream.of_channel stdin in + while true do + try + let c = Grammar.Entry.parse command cs in execute c + with + | End_of_file | Stdpp.Exc_located (_, End_of_file) -> exit 0 + | exn -> explain_exn exn + done + +let main () = + if Array.length Sys.argv = 1 then + parse_file "test" + else + if Sys.argv.(1) = "-top" then top () else parse_file (Sys.argv.(1)) + +let _ = Printexc.print main () + diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 new file mode 100644 index 00000000..4da23d42 --- /dev/null +++ b/toplevel/mltop.ml4 @@ -0,0 +1,296 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: mltop.ml4,v 1.29.2.3 2004/07/17 13:00:15 herbelin Exp $ *) + +open Util +open Pp +open Options +open System +open Libobject +open Library +open System +open Vernacinterp + +(* Code to hook Coq into the ML toplevel -- depends on having the + objective-caml compiler mostly visible. The functions implemented here are: + \begin{itemize} + \item [dir_ml_load name]: Loads the ML module fname from the current ML + path. + \item [dir_ml_use]: Directive #use of Ocaml toplevel + \item [add_ml_dir]: Directive #directory of Ocaml toplevel + \end{itemize} + + How to build an ML module interface with these functions. + The idea is that the ML directory path is like the Coq directory + path. So we can maintain the two in parallel. + In the same way, we can use the "ml_env" as a kind of ML + environment, which we freeze, unfreeze, and add things to just like + to the other environments. + Finally, we can create an object which is an ML module, and require + that the "caching" of the ML module cause the loading of the + associated ML file, if that file has not been yet loaded. Of + course, the problem is how to record dependencies between ML + modules. + (I do not know of a solution to this problem, other than to + put all the needed names into the ML Module object.) *) + +(* This path is where we look for .cmo *) +let coq_mlpath_copy = ref ["."] +let keep_copy_mlpath s = + let dir = glob s in + coq_mlpath_copy := dir :: !coq_mlpath_copy + +(* If there is a toplevel under Coq *) +type toplevel = { + load_obj : string -> unit; + use_file : string -> unit; + add_dir : string -> unit; + ml_loop : unit -> unit } + +(* Determines the behaviour of Coq with respect to ML files (compiled + or not) *) +type kind_load = + | WithTop of toplevel + | WithoutTop + | Native + +(* Must be always initialized *) +let load = ref Native + +(* Sets and initializes the kind of loading *) +let set kload = load := kload +let get () = !load + +(* Resets load *) +let remove ()= load := Native + +(* Tests if an Ocaml toplevel runs under Coq *) +let is_ocaml_top () = + match !load with + | WithTop _ -> true + |_ -> false + +(* Tests if we can load ML files *) +let enable_load () = + match !load with + | WithTop _ | WithoutTop -> true + |_ -> false + +(* Runs the toplevel loop of Ocaml *) +let ocaml_toploop () = + match !load with + | WithTop t -> Printexc.catch t.ml_loop () + | _ -> () + +(* Dynamic loading of .cmo/.cma *) +let dir_ml_load s = + match !load with + | WithTop t -> + (try t.load_obj s + with + | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u + | _ -> errorlabstrm "Mltop.load_object" [< str"Cannot link ml-object "; + str s; str" to Coq code." >]) +(* TO DO: .cma loading without toplevel *) + | WithoutTop -> + ifdef Byte then + let _,gname = where_in_path !coq_mlpath_copy s in + try + Dynlink.loadfile gname; + Dynlink.add_interfaces + [(String.capitalize (Filename.chop_suffix + (Filename.basename gname) ".cmo"))] + [Filename.dirname gname] + with | Dynlink.Error a -> + errorlabstrm "Mltop.load_object" [< str (Dynlink.error_message a) >] + else () + | Native -> + errorlabstrm "Mltop.no_load_object" + [< str"Loading of ML object file forbidden in a native Coq" >] + +(* Dynamic interpretation of .ml *) +let dir_ml_use s = + match !load with + | WithTop t -> t.use_file s + | _ -> warning "Cannot access the ML compiler" + +(* Adds a path to the ML paths *) +let add_ml_dir s = + match !load with + | WithTop t -> t.add_dir s; keep_copy_mlpath s + | WithoutTop -> keep_copy_mlpath s + | _ -> () + +(* For Rec Add ML Path *) +let add_rec_ml_dir dir = + List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir) + +(* Adding files to Coq and ML loadpath *) + +let add_path ~unix_path:dir ~coq_root:coq_dirpath = + if exists_dir dir then + begin + add_ml_dir dir; + Library.add_load_path_entry (dir,coq_dirpath) + end + else + msg_warning [< str ("Cannot open " ^ dir) >] + +let convert_string d = + try Names.id_of_string d + with _ -> + if_verbose warning + ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); + flush_all (); + failwith "caught" + +let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath = + let dirs = all_subdirs dir in + let prefix = Names.repr_dirpath coq_dirpath in + if dirs <> [] then + let convert_dirs (lp,cp) = + (lp,Names.make_dirpath + ((List.map convert_string (List.rev cp))@prefix)) in + let dirs = map_succeed convert_dirs dirs in + begin + List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; + List.iter Library.add_load_path_entry dirs + end + else + msg_warning [< str ("Cannot open " ^ dir) >] + +(* convertit un nom quelconque en nom de fichier ou de module *) +let mod_of_name name = + let base = + if Filename.check_suffix name ".cmo" then + Filename.chop_suffix name ".cmo" + else + name + in + String.capitalize base + +let file_of_name name = + let bname = String.uncapitalize name in + let fname = make_suffix bname ".cmo" in + if (is_in_path !coq_mlpath_copy fname) then fname + else let fname=make_suffix bname ".cma" in + if (is_in_path !coq_mlpath_copy fname) then fname + else + errorlabstrm "Mltop.load_object" + [< str"File not found on loadpath : "; str (bname^".cm[oa]") >] + +(* TODO: supprimer ce hack, si possible *) +(* Initialisation of ML modules that need the state (ex: tactics like + * natural, omega ...) + * Each module may add some inits (function of type unit -> unit). + * These inits are executed right after the initial state loading if the + * module is statically linked, or after the loading if it is required. *) + +let init_list = ref ([] : (unit -> unit) list) + +let add_init_with_state init_fun = + init_list := init_fun :: !init_list + +let init_with_state () = + List.iter (fun f -> f()) (List.rev !init_list); init_list := [] + + +(* [known_loaded_module] contains the names of the loaded ML modules + * (linked or loaded with load_object). It is used not to load a + * module twice. It is NOT the list of ML modules Coq knows. *) + +type ml_module_object = { mnames : string list } + +let known_loaded_modules = ref Stringset.empty + +let add_known_module mname = + known_loaded_modules := Stringset.add mname !known_loaded_modules + +let module_is_known mname = Stringset.mem mname !known_loaded_modules + +let load_object mname fname= + dir_ml_load fname; + init_with_state(); + add_known_module mname + +(* Summary of declared ML Modules *) + +(* List and not Stringset because order is important *) +let loaded_modules = ref [] +let get_loaded_modules () = !loaded_modules +let add_loaded_module md = loaded_modules := md :: !loaded_modules + +let orig_loaded_modules = ref !loaded_modules +let init_ml_modules () = loaded_modules := !orig_loaded_modules + +let unfreeze_ml_modules x = + loaded_modules := []; + List.iter + (fun name -> + let mname = mod_of_name name in + if not (module_is_known mname) then + if enable_load() then + let fname = file_of_name mname in + load_object mname fname + else + errorlabstrm "Mltop.unfreeze_ml_modules" + [< str"Loading of ML object file forbidden in a native Coq" >]; + add_loaded_module mname) + x + +let _ = + Summary.declare_summary "ML-MODULES" + { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules())); + Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x); + Summary.init_function = (fun () -> init_ml_modules ()); + Summary.survive_module = false; + Summary.survive_section = true } + +(* Same as restore_ml_modules, but verbosely *) + +let cache_ml_module_object (_,{mnames=mnames}) = + List.iter + (fun name -> + let mname = mod_of_name name in + if not (module_is_known mname) then + let fname = file_of_name mname in + begin + try + if_verbose + msg [< str"[Loading ML file "; str fname; str" ..." >]; + load_object mname fname; + if_verbose msgnl [< str"done]" >] + with e -> + if_verbose msgnl [< str"failed]" >]; + raise e + end; + add_loaded_module mname) + mnames + +let export_ml_module_object x = Some x + +let (inMLModule,outMLModule) = + declare_object {(default_object "ML-MODULE") with + load_function = (fun _ -> cache_ml_module_object); + cache_function = cache_ml_module_object; + export_function = export_ml_module_object } + +let declare_ml_modules l = + Lib.add_anonymous_leaf (inMLModule {mnames=l}) + +let print_ml_path () = + let l = !coq_mlpath_copy in + ppnl [< str"ML Load Path:"; fnl (); str" "; + hv 0 (prlist_with_sep pr_fnl pr_str l) >] + + (* Printing of loaded ML modules *) + +let print_ml_modules () = + let l = get_loaded_modules () in + pp [< str"Loaded ML Modules: " ; pr_vertical_list pr_str l >] diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli new file mode 100644 index 00000000..6ba8cd76 --- /dev/null +++ b/toplevel/mltop.mli @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: mltop.mli,v 1.8.14.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +(* If there is a toplevel under Coq, it is described by the following + record. *) +type toplevel = { + load_obj : string -> unit; + use_file : string -> unit; + add_dir : string -> unit; + ml_loop : unit -> unit } + +(* Determines the behaviour of Coq with respect to ML files (compiled + or not) *) +type kind_load= + | WithTop of toplevel + | WithoutTop + | Native + +(* Sets and initializes the kind of loading *) +val set : kind_load -> unit +val get : unit -> kind_load + +(* Resets the kind of loading *) +val remove : unit -> unit + +(* Tests if an Ocaml toplevel runs under Coq *) +val is_ocaml_top : unit -> bool + +(* Tests if we can load ML files *) +val enable_load : unit -> bool + +(* Starts the Ocaml toplevel loop *) +val ocaml_toploop : unit -> unit + +(* Dynamic loading of .cmo *) +val dir_ml_load : string -> unit + +(* Dynamic interpretation of .ml *) +val dir_ml_use : string -> unit + +(* Adds a path to the ML paths *) +val add_ml_dir : string -> unit +val add_rec_ml_dir : string -> unit + +(* Adds a path to the Coq and ML paths *) +val add_path : unix_path:string -> coq_root:Names.dir_path -> unit +val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit + +val add_init_with_state : (unit -> unit) -> unit +val init_with_state : unit -> unit + +(* List of modules linked to the toplevel *) +val add_known_module : string -> unit +val module_is_known : string -> bool +val load_object : string -> string -> unit + +(* Summary of Declared ML Modules *) +val get_loaded_modules : unit -> string list +val add_loaded_module : string -> unit +val init_ml_modules : unit -> unit +val unfreeze_ml_modules : string list -> unit + +type ml_module_object = { mnames: string list } +val inMLModule : ml_module_object -> Libobject.obj +val outMLModule : Libobject.obj -> ml_module_object + +val declare_ml_modules : string list -> unit +val print_ml_path : unit -> unit + +val print_ml_modules : unit -> unit diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml new file mode 100644 index 00000000..c748a12d --- /dev/null +++ b/toplevel/protectedtoplevel.ml @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: protectedtoplevel.ml,v 1.9.10.1 2004/07/16 19:31:49 herbelin Exp $ *) + +open Pp +open Line_oriented_parser +open Vernac + +(* The toplevel parsing loop we propose here is more robust to printing + errors. The philosophy is that all commands should be individually wrapped + in predefined markers. If there is a parsing error, everything down to + the closing marker will be discarded. Also there is always an aknowledge + message associated to a wrapped command. *) + + +(* It is also possible to have break signals sent by other programs. However, + there are some operations that should not be interrupted, especially, those + operations that are outputing data. +*) + +let break_happened = ref false + +(* Before outputing any data, output_results makes sure that no interrupt + is going to disturb the process. *) +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 _ -> raise Sys.Break)) in + () + +let check_break () = + if !break_happened then begin + break_happened := false; + raise Sys.Break + end + +(* All commands are acknowledged. *) + +let global_request_id = ref 013 + +let acknowledge_command_ref = + ref(fun request_id command_count opt_exn + -> (fnl () ++ str "acknowledge command number " ++ + int request_id ++ fnl () ++ + str "successfully executed " ++ int command_count ++ fnl () ++ + str "error message" ++ 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 set_acknowledge_command f = + acknowledge_command_ref := f + +let acknowledge_command request_id = !acknowledge_command_ref request_id + +(* The markers are chosen to be likely to be different from any existing text. *) + +let start_marker = ref "protected_loop_start_command" +let end_marker = ref "protected_loop_end_command" +let start_length = ref (String.length !start_marker) +let start_marker_buffer = ref (String.make !start_length ' ') + +let set_start_marker s = + start_marker := s; + start_length := String.length s; + start_marker_buffer := String.make !start_length ' ' + +let set_end_marker s = + end_marker := s + +exception E_with_rank of int * exn + +let rec parse_one_command_group input_channel = + let count = ref 0 in + let this_line = input_line input_channel in + if (String.length this_line) >= !start_length then begin + String.blit this_line 0 !start_marker_buffer 0 !start_length; + if !start_marker_buffer = !start_marker then + let req_id_line = input_line input_channel in + begin + (try + global_request_id := int_of_string req_id_line + with + | e -> failwith ("could not parse the request identifier |"^ + req_id_line ^ "|")) ; + let count_line = input_line input_channel in + begin + (try + count := int_of_string count_line + with + | e -> failwith("could not parse the count|" ^ count_line + ^ "|")); + let stream_tail = + Stream.from + (line_oriented_channel_to_option + !end_marker input_channel) in + begin + check_break(); + rearm_break(); + let rec execute_n_commands rank = + if rank = !count then + None + else + let first_cmd_status = + try + raw_do_vernac + (Pcoq.Gram.parsable stream_tail); + None + with e -> Some(rank,e) in + match first_cmd_status with + None -> + execute_n_commands (rank + 1) + | v -> v in + let r = execute_n_commands 0 in + (match r with + None -> + output_results_nl + (acknowledge_command + !global_request_id !count None) + | Some(rank, e) -> + (match e with + DuringCommandInterp(a,e1) -> + output_results_nl + (acknowledge_command + !global_request_id rank (Some e1)) + | e -> + output_results_nl + (acknowledge_command + !global_request_id rank (Some e)))); + rearm_break(); + flush_until_end_of_stream stream_tail + end + end + end + else + parse_one_command_group input_channel + end else + parse_one_command_group input_channel + +let protected_loop input_chan = + let rec explain_and_restart e = + begin + output_results_nl(Cerrors.explain_exn e); + rearm_break(); + looprec input_chan; + end + and looprec input_chan = + try + while true do parse_one_command_group input_chan done + with + | Vernacexpr.Drop -> raise Vernacexpr.Drop + | Vernacexpr.Quit -> exit 0 + | End_of_file -> exit 0 + | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit + | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop + | DuringCommandInterp(loc, e) -> + explain_and_restart e + | e -> explain_and_restart e in + begin + msgnl (str "Starting Centaur Specialized loop"); + looprec input_chan + end diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli new file mode 100644 index 00000000..b31afbf6 --- /dev/null +++ b/toplevel/protectedtoplevel.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: protectedtoplevel.mli,v 1.5.16.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +(*i*) +open Pp +(*i*) + +(* A protected toplevel (used in Pcoq). *) + +val break_happened : bool ref +val global_request_id : int ref +val output_results_nl : std_ppcmds -> unit +val rearm_break : unit -> unit +val check_break : unit -> unit +val set_acknowledge_command : (int -> int -> exn option -> std_ppcmds) -> unit +val set_start_marker : string -> unit +val set_end_marker : string -> unit +val parse_one_command_group : in_channel -> unit +val protected_loop : in_channel -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml new file mode 100644 index 00000000..f703c067 --- /dev/null +++ b/toplevel/record.ml @@ -0,0 +1,236 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: record.ml,v 1.52.2.1 2004/07/16 19:31:49 herbelin Exp $ *) + +open Pp +open Util +open Names +open Libnames +open Nameops +open Term +open Termops +open Environ +open Declarations +open Entries +open Declare +open Nametab +open Coqast +open Constrintern +open Command +open Inductive +open Safe_typing +open Decl_kinds +open Indtypes +open Type_errors +open Topconstr + +(********** definition d'un record (structure) **************) + +let interp_decl sigma env = function + | Vernacexpr.AssumExpr((_,id),t) -> (id,None,interp_type Evd.empty env t) + | Vernacexpr.DefExpr((_,id),c,t) -> + let c = match t with + | None -> c + | Some t -> mkCastC (c,t) + in + let j = judgment_of_rawconstr Evd.empty env c in + (id,Some j.uj_val, j.uj_type) + +let typecheck_params_and_fields ps fs = + let env0 = Global.env () in + let env1,newps = + List.fold_left + (fun (env,newps) d -> match d with + | LocalRawAssum ([_,na],(CHole _ as t)) -> + let t = interp_binder Evd.empty env na t in + let d = (na,None,t) in + (push_rel d env, d::newps) + | LocalRawAssum (nal,t) -> + let t = interp_type Evd.empty env t in + let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in + let ctx = List.rev ctx in + (push_rel_context ctx env, ctx@newps) + | LocalRawDef ((_,na),c) -> + let c = judgment_of_rawconstr Evd.empty env c in + let d = (na, Some c.uj_val, c.uj_type) in + (push_rel d env, d::newps)) + (env0,[]) ps + in + let env2,newfs = + List.fold_left + (fun (env,newfs) d -> + let decl = interp_decl Evd.empty env d in + (push_rel decl env, decl::newfs)) + (env1,[]) fs + in + newps, newfs + +let degenerate_decl (na,b,t) = + let id = match na with + | Name id -> id + | Anonymous -> anomaly "Unnamed record variable" in + match b with + | None -> (id, Entries.LocalAssum t) + | Some b -> (id, Entries.LocalDef b) + +type record_error = + | MissingProj of identifier * identifier list + | BadTypedProj of identifier * env * Type_errors.type_error + +let warning_or_error coe indsp err = + let st = match err with + | MissingProj (fi,projs) -> + let s,have = if List.length projs > 1 then "s","have" else "","has" in + (str(string_of_id fi) ++ + str" cannot be defined because the projection" ++ str s ++ spc () ++ + prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ str "n't.") + | BadTypedProj (fi,ctx,te) -> + match te with + | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> + (str (string_of_id fi) ++ + str" cannot be defined because it is informative and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + str " is not.") + | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> + (str (string_of_id fi) ++ + str" cannot be defined because it is large and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + str " is not.") + | _ -> + (str " cannot be defined because it is not typable") + in + if coe then errorlabstrm "structure" st; + Options.if_verbose ppnl (hov 0 (str"Warning: " ++ st)) + +type field_status = + | NoProjection of name + | Projection of constr + +exception NotDefinable of record_error + +(* This replaces previous projection bodies in current projection *) +(* Undefined projs are collected and, at least one undefined proj occurs *) +(* in the body of current projection then the latter can not be defined *) +(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *) +(* [[fields]] defined in ctxt [[params;x:ind]] *) +let subst_projection fid l c = + let lv = List.length l in + let bad_projs = ref [] in + let rec substrec depth c = match kind_of_term c with + | Rel k -> + (* We are in context [[params;fields;x:ind;...depth...]] *) + if k <= depth+1 then + c + else if k-depth-1 <= lv then + match List.nth l (k-depth-2) with + | Projection t -> lift depth t + | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k + | NoProjection Anonymous -> assert false + else + mkRel (k-lv) + | _ -> map_constr_with_binders succ substrec depth c + in + let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) + let c'' = substrec 0 c' in + if !bad_projs <> [] then + raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); + c'' + +(* We build projections *) +let declare_projections indsp coers fields = + let env = Global.env() in + let (mib,mip) = Global.lookup_inductive indsp in + let paramdecls = mip.mind_params_ctxt in + let r = mkInd indsp in + let rp = applist (r, extended_rel_list 0 paramdecls) in + let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) + let x = Termops.named_hd (Global.env()) r Anonymous in + let lifted_fields = lift_rel_context 1 fields in + let (_,sp_projs,_) = + List.fold_left2 + (fun (nfi,sp_projs,subst) coe (fi,optci,ti) -> + match fi with + | Anonymous -> + (nfi-1, None::sp_projs,NoProjection fi::subst) + | Name fid -> + try + let ccl = subst_projection fid subst ti in + let body = match optci with + | Some ci -> subst_projection fid subst ci + | None -> + (* [ccl] is defined in context [params;x:rp] *) + (* [ccl'] is defined in context [params;x:rp;x:rp] *) + let ccl' = liftn 1 2 ccl in + let p = mkLambda (x, lift 1 rp, ccl') in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let ci = Inductiveops.make_case_info env indsp + LetStyle [| RegularPat |] in + mkCase (ci, p, mkRel 1, [|branch|]) in + let proj = + it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + let projtyp = + it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in + let (sp,kn) = + try + let cie = { + const_entry_body = proj; + const_entry_type = Some projtyp; + const_entry_opaque = false } in + let k = (DefinitionEntry cie,IsDefinition) in + let sp = declare_internal_constant fid k in + Options.if_verbose message (string_of_id fid ^" is defined"); + sp + with Type_errors.TypeError (ctx,te) -> + raise (NotDefinable (BadTypedProj (fid,ctx,te))) in + let refi = ConstRef kn in + let constr_fi = mkConst kn in + if coe then begin + let cl = Class.class_of_ref (IndRef indsp) in + Class.try_add_new_coercion_with_source refi Global cl + end; + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + let constr_fip = applist (constr_fi,proj_args) in + (nfi-1, (Some kn)::sp_projs, Projection constr_fip::subst) + with NotDefinable why -> + warning_or_error coe indsp why; + (nfi-1, None::sp_projs,NoProjection fi::subst)) + (List.length fields,[],[]) coers (List.rev fields) + in sp_projs + +(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean + list telling if the corresponding fields must me declared as coercion *) +let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) = + let coers,fs = List.split cfs in + let nparams = local_binders_length ps in + let extract_name acc = function + Vernacexpr.AssumExpr((_,Name id),_) -> id::acc + | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc + | _ -> acc in + let allnames = idstruc::(List.fold_left extract_name [] fs) in + if not (list_distinct allnames) then error "Two objects have the same name"; + (* Now, younger decl in params and fields is on top *) + let params,fields = typecheck_params_and_fields ps fs in + let args = extended_rel_list (List.length fields) params in + let ind = applist (mkRel (1+List.length params+List.length fields), args) in + let type_constructor = it_mkProd_or_LetIn ind fields in + let mie_ind = + { mind_entry_params = List.map degenerate_decl params; + mind_entry_typename = idstruc; + mind_entry_arity = mkSort s; + mind_entry_consnames = [idbuild]; + mind_entry_lc = [type_constructor] } in + let mie = + { mind_entry_finite = true; + mind_entry_inds = [mie_ind] } in + let sp = declare_mutual_with_eliminations true mie in + let rsp = (sp,0) in (* This is ind path of idstruc *) + let sp_projs = declare_projections rsp coers fields in + let build = ConstructRef (rsp,1) in (* This is construct path of idbuild *) + if is_coe then Class.try_add_new_coercion build Global; + Recordops.add_new_struc (rsp,idbuild,nparams,List.rev sp_projs) diff --git a/toplevel/record.mli b/toplevel/record.mli new file mode 100644 index 00000000..8eff2ed5 --- /dev/null +++ b/toplevel/record.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: record.mli,v 1.16.2.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +(*i*) +open Names +open Term +open Sign +open Vernacexpr +open Topconstr +(*i*) + +(* [declare_projections ref coers params fields] declare projections of + record [ref] (if allowed), and put them as coercions accordingly to + [coers]; it returns the absolute names of projections *) + +val declare_projections : + inductive -> bool list -> rel_context -> constant option list + +val definition_structure : + lident with_coercion * local_binder list * + (local_decl_expr with_coercion) list * identifier * sorts -> unit diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml new file mode 100755 index 00000000..d2a1e36e --- /dev/null +++ b/toplevel/recordobj.ml @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: recordobj.ml,v 1.12.2.1 2004/07/16 19:31:49 herbelin Exp $ *) + +open Util +open Pp +open Names +open Libnames +open Nameops +open Term +open Instantiate +open Lib +open Declare +open Recordops +open Classops +open Nametab + +(***** object definition ******) + +let typ_lams_of t = + let rec aux acc c = match kind_of_term c with + | Lambda (x,c1,c2) -> aux (c1::acc) c2 + | Cast (c,_) -> aux acc c + | t -> acc,t + in aux [] t + +let objdef_err ref = + errorlabstrm "object_declare" + (pr_id (id_of_global ref) ++ + str" is not a structure object") + +let objdef_declare ref = + let sp = match ref with ConstRef sp -> sp | _ -> objdef_err ref in + let env = Global.env () in + let v = constr_of_reference ref in + let vc = match Environ.constant_opt_value env sp with + | Some vc -> vc + | None -> objdef_err ref in + let lt,t = decompose_lam vc in + let lt = List.rev (List.map snd lt) in + let f,args = match kind_of_term t with + | App (f,args) -> f,args + | _ -> objdef_err ref in + let { s_PARAM = p; s_PROJ = lpj } = + try (find_structure + (match kind_of_term f with + | Construct (indsp,1) -> indsp + | _ -> objdef_err ref)) + with Not_found -> objdef_err ref in + let params, projs = + try list_chop p (Array.to_list args) + with _ -> objdef_err ref in + let lps = + try List.combine lpj projs + with _ -> objdef_err ref in + let comp = + List.fold_left + (fun l (spopt,t) -> (* comp=components *) + match spopt with + | None -> l + | Some proji_sp -> + let c, args = decompose_app t in + try (ConstRef proji_sp, reference_of_constr c, args) :: l + with Not_found -> l) + [] lps in + add_anonymous_leaf (inObjDef1 sp); + List.iter + (fun (refi,c,argj) -> add_new_objdef ((refi,c),v,lt,params,argj)) + comp + +let add_object_hook _ = objdef_declare diff --git a/toplevel/recordobj.mli b/toplevel/recordobj.mli new file mode 100755 index 00000000..8ea39767 --- /dev/null +++ b/toplevel/recordobj.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: recordobj.mli,v 1.7.6.1 2004/07/16 19:31:49 herbelin Exp $ *) + +val objdef_declare : Libnames.global_reference -> unit +val add_object_hook : Tacexpr.declaration_hook diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli new file mode 100644 index 00000000..f1ad7d5a --- /dev/null +++ b/toplevel/searchisos.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: searchisos.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*) + +val search_in_lib : bool ref +val type_search : Term.constr -> unit +val require_module2 : bool option -> string -> string option -> bool -> unit +val upd_tbl_ind_one : unit -> unit +val seetime : bool ref +val load_leaf_entry : string -> Names.section_path * Libobject.obj -> unit diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml new file mode 100644 index 00000000..7fa80bcb --- /dev/null +++ b/toplevel/toplevel.ml @@ -0,0 +1,326 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: toplevel.ml,v 1.22.2.2 2004/07/16 20:48:17 herbelin Exp $ *) + +open Pp +open Util +open Options +open Cerrors +open Vernac +open Pcoq +open Protectedtoplevel + +(* A buffer for the character read from a channel. We store the command + * entered to be able to report errors without pretty-printing. *) + +type input_buffer = { + mutable prompt : unit -> string; + mutable str : string; (* buffer of already read characters *) + mutable len : int; (* number of chars in the buffer *) + mutable bols : int list; (* offsets in str of begining of lines *) + mutable tokens : Gram.parsable; (* stream of tokens *) + mutable start : int } (* stream count of the first char of the buffer *) + +(* Double the size of the buffer. *) + +let resize_buffer ibuf = + let nstr = String.create (2 * String.length ibuf.str + 1) in + String.blit ibuf.str 0 nstr 0 (String.length ibuf.str); + ibuf.str <- nstr + +(* Delete all irrelevent lines of the input buffer. Keep the last line + in the buffer (useful when there are several commands on the same line. *) + +let resynch_buffer ibuf = + match ibuf.bols with + | ll::_ -> + let new_len = ibuf.len - ll in + String.blit ibuf.str ll ibuf.str 0 new_len; + ibuf.len <- new_len; + ibuf.bols <- []; + ibuf.start <- ibuf.start + ll + | _ -> () + +(* Read a char in an input channel, displaying a prompt at every + beginning of line. *) + +let prompt_char ic ibuf count = + let bol = match ibuf.bols with + | ll::_ -> ibuf.len == ll + | [] -> ibuf.len == 0 + in + if bol && not !print_emacs then msgerr (str (ibuf.prompt())); + try + let c = input_char ic in + if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; + if ibuf.len == String.length ibuf.str then resize_buffer ibuf; + ibuf.str.[ibuf.len] <- c; + ibuf.len <- ibuf.len + 1; + Some c + with End_of_file -> + None + +(* Reinitialize the char stream (after a Drop) *) + +let reset_input_buffer ic ibuf = + ibuf.str <- ""; + ibuf.len <- 0; + ibuf.bols <- []; + ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf)); + ibuf.start <- 0 + +(* Functions to print underlined locations from an input buffer. *) + +(* Given a location, returns the list of locations of each line. The last + line is returned separately. It also checks the location bounds. *) + +let get_bols_of_loc ibuf (bp,ep) = + let add_line (b,e) lines = + if b < 0 or e < b then anomaly "Bad location"; + match lines with + | ([],None) -> ([], Some (b,e)) + | (fl,oe) -> ((b,e)::fl, oe) + in + let rec lines_rec ba after = function + | [] -> add_line (0,ba) after + | ll::_ when ll <= bp -> add_line (ll,ba) after + | ll::fl -> + let nafter = if ll < ep then add_line (ll,ba) after else after in + lines_rec ll nafter fl + in + let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in + (fl,out_some ll) + +let dotted_location (b,e) = + if e-b < 3 then + ("", String.make (e-b) ' ') + else + (String.make (e-b-1) '.', " ") + +let print_highlight_location ib loc = + let (bp,ep) = unloc loc in + let bp = bp - ib.start + and ep = ep - ib.start in + let highlight_lines = + match get_bols_of_loc ib (bp,ep) with + | ([],(bl,el)) -> + (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ + str"> " ++ str(String.make (bp-bl) ' ') ++ + str(String.make (ep-bp) '^')) + | ((b1,e1)::ml,(bn,en)) -> + let (d1,s1) = dotted_location (b1,bp) in + let (dn,sn) = dotted_location (ep,en) in + let l1 = (str"> " ++ str d1 ++ str s1 ++ + str(String.sub ib.str bp (e1-bp))) in + let li = + prlist (fun (bi,ei) -> + (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in + let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ + str sn ++ str dn) in + (l1 ++ li ++ ln) + in + (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ fnl () ++ + highlight_lines ++ fnl ()) + +(* Functions to report located errors in a file. *) + +let print_location_in_file s inlibrary fname (bp,ep) = + let errstrm = (str"Error while reading " ++ str s ++ str" :" ++ fnl ()) in + if (bp,ep) = dummy_loc then + (errstrm ++ str", unknown location." ++ fnl ()) + else + if inlibrary then + (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++ + str" characters " ++ Cerrors.print_loc (bp,ep) ++ fnl ()) + else + let (bp,ep) = unloc (bp,ep) in + let ic = open_in fname in + let rec line_of_pos lin bol cnt = + if cnt < bp then + if input_char ic == '\n' + then line_of_pos (lin + 1) (cnt +1) (cnt+1) + else line_of_pos lin bol (cnt+1) + else (lin, bol) + in + try + let (line, bol) = line_of_pos 1 0 0 in + close_in ic; + (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++ + str", line " ++ int line ++ + str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol)) ++ fnl ()) + with e -> (close_in ic; (errstrm ++ str", invalid location." ++ fnl ())) + +let print_command_location ib dloc = + match dloc with + | Some (bp,ep) -> + (str"Error during interpretation of command:" ++ fnl () ++ + str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ()) + | None -> (mt ()) + +let valid_loc dloc (b,e) = + (b,e) <> dummy_loc + & match dloc with + | Some (bd,ed) -> bd<=b & e<=ed + | _ -> true + +let valid_buffer_loc ib dloc (b,e) = + valid_loc dloc (b,e) & + let (b,e) = unloc (b,e) in b-ib.start >= 0 & e-ib.start < ib.len & b<=e + +(*s The Coq prompt is the name of the focused proof, if any, and "Coq" + otherwise. We trap all exceptions to prevent the error message printing + from cycling. *) +let make_prompt () = + try + (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " + with _ -> + "Coq < " + +(* A buffer to store the current command read on stdin. It is + * initialized when a vernac command is immediately followed by "\n", + * or after a Drop. *) +let top_buffer = + let pr() = (make_prompt())^(emacs_str (String.make 1 (Char.chr 249))) + in + { prompt = pr; + str = ""; + len = 0; + bols = []; + tokens = Gram.parsable (Stream.of_list []); + start = 0 } + +let set_prompt prompt = + top_buffer.prompt + <- (fun () -> (prompt ()) ^ (emacs_str (String.make 1 (Char.chr 249)))) + +(* Removes and prints the location of the error. The following exceptions + need not be located. *) +let rec is_pervasive_exn = function + | Out_of_memory | Stack_overflow | Sys.Break -> true + | Error_in_file (_,_,e) -> is_pervasive_exn e + | Stdpp.Exc_located (_,e) -> is_pervasive_exn e + | DuringCommandInterp (_,e) -> is_pervasive_exn e + | _ -> false + +(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D + May raise only the following exceptions: Drop and End_of_input, + meaning we get out of the Coq loop *) +let print_toplevel_error exc = + let (dloc,exc) = + match exc with + | DuringCommandInterp (loc,ie) -> + if loc = dummy_loc then (None,ie) else (Some loc, ie) + | _ -> (None, exc) + in + let (locstrm,exc) = + match exc with + | Stdpp.Exc_located (loc, ie) -> + if valid_buffer_loc top_buffer dloc loc then + (print_highlight_location top_buffer loc, ie) + else + ((mt ()) (* print_command_location top_buffer dloc *), ie) + | Error_in_file (s, (inlibrary, fname, loc), ie) -> + (print_location_in_file s inlibrary fname loc, ie) + | _ -> + ((mt ()) (* print_command_location top_buffer dloc *), exc) + in + match exc with + | End_of_input -> + msgerrnl (mt ()); pp_flush(); exit 0 + | Vernacexpr.Drop -> (* Last chance *) + if Mltop.is_ocaml_top() then raise Vernacexpr.Drop; + (str"Error: There is no ML toplevel." ++ fnl ()) + | Vernacexpr.ProtectedLoop -> + raise Vernacexpr.ProtectedLoop + | Vernacexpr.Quit -> + raise Vernacexpr.Quit + | _ -> + (if is_pervasive_exn exc then (mt ()) else locstrm) ++ + Cerrors.explain_exn exc + +(* Read the input stream until a dot is encountered *) +let parse_to_dot = + let rec dot st = match Stream.next st with + | ("", ".") -> () + | ("EOI", "") -> raise End_of_input + | _ -> dot st + in + Gram.Entry.of_parser "Coqtoplevel.dot" dot + +(* We assume that when a lexer error occurs, at least one char was eaten *) +let rec discard_to_dot () = + try + Gram.Entry.parse parse_to_dot top_buffer.tokens + with Stdpp.Exc_located(_,Token.Error _) -> + discard_to_dot() + + +(* If the error occured while parsing, we read the input until a dot token + * in encountered. *) + +let process_error = function + | DuringCommandInterp _ as e -> e + | e -> + if is_pervasive_exn e then + e + else + try + discard_to_dot (); e + with + | End_of_input -> End_of_input + | de -> if is_pervasive_exn de then de else e + +(* do_vernac reads and executes a toplevel phrase, and print error + messages when an exception is raised, except for the following: + Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists. + Otherwise, exit. + End_of_input: Ctrl-D was typed in, we will quit *) +let do_vernac () = + msgerrnl (mt ()); + if !print_emacs then msgerr (str (top_buffer.prompt())); + resynch_buffer top_buffer; + begin + try + raw_do_vernac top_buffer.tokens + with e -> + msgnl (print_toplevel_error (process_error e)) + end; + flush_all() + +(* coq and go read vernacular expressions until Drop is entered. + * Ctrl-C will raise the exception Break instead of aborting Coq. + * Here we catch the exceptions terminating the Coq loop, and decide + * if we really must quit. + * The boolean value is used to choose between a protected loop, which + * we think is more suited for communication with other programs, or + * plain communication. *) + +let rec coq_switch b = + Sys.catch_break true; + (* ensure we have a command separator object (DOT) so that the first + command can be reseted. *) + Lib.mark_end_of_command(); + try + if b then begin + reset_input_buffer stdin top_buffer; + while true do do_vernac() done + end else + protected_loop stdin + with + | Vernacexpr.Drop -> () + | Vernacexpr.ProtectedLoop -> + Lib.declare_initial_state(); + coq_switch false + | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 + | Vernacexpr.Quit -> exit 0 + | e -> + msgerrnl (str"Anomaly. Please report."); + coq_switch b + +let loop () = coq_switch true diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli new file mode 100644 index 00000000..1b6b48d4 --- /dev/null +++ b/toplevel/toplevel.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: toplevel.mli,v 1.6.10.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(*i*) +open Pp +open Pcoq +(*i*) + +(* The Coq toplevel loop. *) + +(* A buffer for the character read from a channel. We store the command + * entered to be able to report errors without pretty-printing. *) + +type input_buffer = { + mutable prompt : unit -> string; + mutable str : string; (* buffer of already read characters *) + mutable len : int; (* number of chars in the buffer *) + mutable bols : int list; (* offsets in str of begining of lines *) + mutable tokens : Pcoq.Gram.parsable; (* stream of tokens *) + mutable start : int } (* stream count of the first char of the buffer *) + +(* The input buffer of stdin. *) + +val top_buffer : input_buffer +val set_prompt : (unit -> string) -> unit + +(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D + May raise only the following exceptions: [Drop] and [End_of_input], + meaning we get out of the Coq loop. *) + +val print_toplevel_error : exn -> std_ppcmds + +(* Parse and execute a vernac command. *) + +val do_vernac : unit -> unit + +(* Main entry point of Coq: read and execute vernac commands. *) + +val loop : unit -> unit diff --git a/toplevel/usage.ml b/toplevel/usage.ml new file mode 100644 index 00000000..9fe8b280 --- /dev/null +++ b/toplevel/usage.ml @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: usage.ml,v 1.15.2.1 2004/07/16 19:31:50 herbelin Exp $ *) + +let version () = + Printf.printf "The Coq Proof Assistant, version %s (%s)\n" + Coq_config.version Coq_config.date; + Printf.printf "compiled on %s\n" Coq_config.compile_date; + exit 0 + +(* print the usage of coqtop (or coqc) on channel co *) + +let print_usage_channel co command = + output_string co command; + output_string co "Coq options are:\n"; + output_string co +" -I dir add directory dir in the include path + -include dir (idem) + -R dir coqdir recursively map physical dir to logical coqdir + -src add source directories in the include path + + -inputstate f read state from file f.coq + -is f (idem) + -nois start with an empty state + -outputstate f write state in file f.coq + + -load-ml-object f load ML object file f + -load-ml-source f load ML file f + -load-vernac-source f load Coq file f.v (Load f.) + -l f (idem) + -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.) + -lv f (idem) + -load-vernac-object f load Coq object file f.vo + -require f load Coq object file f.vo and import it (Require f.) + -compile f compile Coq file f.v (implies -batch) + -compile-verbose f verbosely compile Coq file f.v (implies -batch) + + -opt run the native-code version of Coq or Coq_SearchIsos + -byte run the bytecode version of Coq or Coq_SearchIsos + + -where print Coq's standard library location and exit + -v print Coq version and exit + + -q skip loading of rcfile + -init-file f set the rcfile to f + -user u use the rcfile of user u + -batch batch mode (exits just after arguments parsing) + -boot boot mode (implies -q and -batch) + -emacs tells Coq it is executed under Emacs + -dump-glob f dump globalizations in file f (to be used by coqdoc) + -impredicative-set set sort Set impredicative + -dont-load-proofs don't load opaque proofs in memory + -xml export XML files either to the hierarchy rooted in + the directory $COQ_XML_LIBRARY_ROOT (if set) or to + stdout (if unset) +" + +(* print the usage on standard error *) + +let print_usage = print_usage_channel stderr + +let print_usage_coqtop () = + print_usage "Usage: coqtop <options>\n\n" + +let print_usage_coqc () = + print_usage "Usage: coqc <options> <Coq options> file...\n +options are: + -verbose compile verbosely + -image f specify an alternative executable for Coq + -t keep temporary files\n\n" diff --git a/toplevel/usage.mli b/toplevel/usage.mli new file mode 100644 index 00000000..16929d68 --- /dev/null +++ b/toplevel/usage.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: usage.mli,v 1.5.16.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(*s Prints the version number on the standard output and exits (with 0). *) + +val version : unit -> 'a + +(*s Prints the usage on the error output, preceeded by a user-provided message. *) +val print_usage : string -> unit + +(*s Prints the usage on the error output. *) +val print_usage_coqtop : unit -> unit +val print_usage_coqc : unit -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml new file mode 100644 index 00000000..a5716619 --- /dev/null +++ b/toplevel/vernac.ml @@ -0,0 +1,301 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: vernac.ml,v 1.59.2.3 2004/07/16 20:48:17 herbelin Exp $ *) + +(* Parsing of vernacular. *) + +open Pp +open Lexer +open Util +open Options +open System +open Coqast +open Vernacexpr +open Vernacinterp +open Ppvernacnew + +(* The functions in this module may raise (unexplainable!) exceptions. + Use the module Coqtoplevel, which catches these exceptions + (the exceptions are explained only at the toplevel). *) + +exception DuringCommandInterp of Util.loc * exn + +(* Specifies which file is read. The intermediate file names are + discarded here. The Drop exception becomes an error. We forget + if the error ocurred during interpretation or not *) + +let raise_with_file file exc = + let (cmdloc,re) = + match exc with + | DuringCommandInterp(loc,e) -> (loc,e) + | e -> (dummy_loc,e) + in + let (inner,inex) = + match re with + | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc -> + ((b, f, loc), e) + | Stdpp.Exc_located (loc, e) when loc <> dummy_loc -> + ((false,file, loc), e) + | _ -> ((false,file,cmdloc), re) + in + raise (Error_in_file (file, inner, disable_drop inex)) + +let real_error = function + | Stdpp.Exc_located (_, e) -> e + | Error_in_file (_, _, e) -> e + | e -> e + +(* Opening and closing a channel. Open it twice when verbose: the first + channel is used to read the commands, and the second one to print them. + Note: we could use only one thanks to seek_in, but seeking on and on in + the file we parse seems a bit risky to me. B.B. *) + +let open_file_twice_if verbosely fname = + let _,longfname = find_file_in_path (Library.get_load_path ()) fname in + let in_chan = open_in longfname in + let verb_ch = if verbosely then Some (open_in longfname) else None in + let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in + (in_chan, longfname, (po, verb_ch)) + +let close_input in_chan (_,verb) = + try + close_in in_chan; + match verb with + | Some verb_ch -> close_in verb_ch + | _ -> () + with _ -> () + +let verbose_phrase verbch loc = + let loc = unloc loc in + match verbch with + | Some ch -> + let len = snd loc - fst loc in + let s = String.create len in + seek_in ch (fst loc); + really_input ch s 0 len; + message s; + pp_flush() + | _ -> () + +exception End_of_input + +let parse_phrase (po, verbch) = + match Pcoq.Gram.Entry.parse Pcoq.main_entry po with + | Some (loc,_ as com) -> verbose_phrase verbch loc; com + | None -> raise End_of_input + +(* vernac parses the given stream, executes interpfun on the syntax tree it + * parses, and is verbose on "primitives" commands if verbosely is true *) + +let just_parsing = ref false +let chan_translate = ref stdout +let last_char = ref '\000' + +(* postprocessor to avoid lexical icompatibilities between V7 and V8. + Ex: auto.(* comment *) or simpl.auto + *) +let set_formatter_translator() = + let ch = !chan_translate in + let out s b e = + let n = e-b in + if n > 0 then begin + (match !last_char with + '.' -> + (match s.[b] with + '('|'a'..'z'|'A'..'Z' -> output ch " " 0 1 + | _ -> ()) + | _ -> ()); + last_char := s.[e-1] + end; + output ch s b e + in + Format.set_formatter_output_functions out (fun () -> flush ch); + Format.set_max_boxes max_int + +let pre_printing = function + | VernacSolve (i,tac,deftac) when Options.do_translate () -> + (try + let (_,env) = Pfedit.get_goal_context i in + let t = Options.with_option Options.translate_syntax + (Tacinterp.glob_tactic_env [] env) tac in + let pfts = Pfedit.get_pftreestate () in + let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in + Some (env,t,Pfedit.focus(),List.length gls) + with UserError _|Stdpp.Exc_located _ -> None) + | _ -> None + +let post_printing loc (env,t,f,n) = function + | VernacSolve (i,_,deftac) -> + let loc = unloc loc in + set_formatter_translator(); + let pp = Ppvernacnew.pr_vernac_solve (i,env,t,deftac) ++ sep_end () in + (if !translate_file then begin + msg (hov 0 (comment (fst loc) ++ pp ++ comment (snd loc - 1))); + end + else + msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ pp))); + Format.set_formatter_out_channel stdout + | _ -> () + +let pr_new_syntax loc ocom = + let loc = unloc loc in + if !translate_file then set_formatter_translator(); + let fs = States.freeze () in + let com = match ocom with + | Some (VernacV7only _) -> + Options.v7_only := true; + mt() + | Some VernacNop -> mt() + | Some com -> pr_vernac com + | None -> mt() in + if !translate_file then + msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) + else + msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + States.unfreeze fs; + Constrintern.set_temporary_implicits_in []; + Constrextern.set_temporary_implicits_out []; + Format.set_formatter_out_channel stdout + +let rec vernac_com interpfun (loc,com) = + let rec interp = function + | VernacLoad (verbosely, fname) -> + (* translator state *) + let ch = !chan_translate in + let cs = Lexer.com_state() in + let cl = !Pp.comments in + (* end translator state *) + (* coqdoc state *) + let cds = Constrintern.coqdoc_freeze() in + if !Options.translate_file then begin + let _,f = find_file_in_path (Library.get_load_path ()) + (make_suffix fname ".v") in + chan_translate := open_out (f^"8"); + Pp.comments := [] + end; + begin try + read_vernac_file verbosely (make_suffix fname ".v"); + if !Options.translate_file then close_out !chan_translate; + chan_translate := ch; + Lexer.restore_com_state cs; + Pp.comments := cl; + Constrintern.coqdoc_unfreeze cds; + with e -> + if !Options.translate_file then close_out !chan_translate; + chan_translate := ch; + Lexer.restore_com_state cs; + Pp.comments := cl; + Constrintern.coqdoc_unfreeze cds; + raise e end; + + | VernacList l -> List.iter (fun (_,v) -> interp v) l + + | VernacTime v -> + let tstart = System.get_time() in + if not !just_parsing then interp v; + let tend = System.get_time() in + msgnl (str"Finished transaction in " ++ + System.fmt_time_difference tstart tend) + + (* To be interpreted in v7 or translator input only *) + | VernacV7only v -> + Options.v7_only := true; + if !Options.v7 || Options.do_translate() then interp v; + Options.v7_only := false + + (* To be interpreted in translator output only *) + | VernacV8only v -> + if not !Options.v7 && not (do_translate()) then + interp v + + | v -> if not !just_parsing then interpfun v + + in + try + Options.v7_only := false; + if do_translate () then + match pre_printing com with + None -> + pr_new_syntax loc (Some com); + interp com + | Some state -> + (try + interp com; + post_printing loc state com + with e -> + post_printing loc state com; + raise e) + else + interp com + with e -> + Format.set_formatter_out_channel stdout; + Options.v7_only := false; + raise (DuringCommandInterp (loc, e)) + +and vernac interpfun input = + vernac_com interpfun (parse_phrase input) + +and read_vernac_file verbosely s = + let interpfun = + if verbosely then + Vernacentries.interp + else + Options.silently Vernacentries.interp + in + let (in_chan, fname, input) = open_file_twice_if verbosely s in + try + (* we go out of the following infinite loop when a End_of_input is + * raised, which means that we raised the end of the file being loaded *) + while true do vernac interpfun input; pp_flush () done + with e -> (* whatever the exception *) + Format.set_formatter_out_channel stdout; + close_input in_chan input; (* we must close the file first *) + match real_error e with + | End_of_input -> + if do_translate () then pr_new_syntax (make_loc (max_int,max_int)) None + | _ -> raise_with_file fname e + +(* raw_do_vernac : char Stream.t -> unit + * parses and executes one command of the vernacular char stream. + * Marks the end of the command in the lib_stk to make vernac undoing + * easier. *) + +let raw_do_vernac po = + vernac (States.with_heavy_rollback Vernacentries.interp) (po,None); + Lib.mark_end_of_command() + +(* XML output hooks *) +let xml_start_library = ref (fun _ -> ()) +let xml_end_library = ref (fun _ -> ()) + +let set_xml_start_library f = xml_start_library := f +let set_xml_end_library f = xml_end_library := f + +(* Load a vernac file. Errors are annotated with file and location *) +let load_vernac verb file = + chan_translate := + if !Options.translate_file then open_out (file^"8") else stdout; + try + read_vernac_file verb file; + if !Options.translate_file then close_out !chan_translate; + with e -> + if !Options.translate_file then close_out !chan_translate; + raise_with_file file e + +(* Compile a vernac file (f is assumed without .v suffix) *) +let compile verbosely f = + let ldir,long_f_dot_v = Library.start_library f in + if !dump then dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); + if !Options.xml_export then !xml_start_library (); + let _ = load_vernac verbosely long_f_dot_v in + if Pfedit.get_all_proof_names () <> [] then + (message "Error: There are pending proofs"; exit 1); + if !Options.xml_export then !xml_end_library (); + Library.save_library_to ldir (long_f_dot_v ^ "o") + diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli new file mode 100644 index 00000000..d8f4b247 --- /dev/null +++ b/toplevel/vernac.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: vernac.mli,v 1.10.2.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(* Parsing of vernacular. *) + +(* Read a vernac command on the specified input (parse only). + Raises [End_of_file] if EOF (or Ctrl-D) is reached. *) + +val parse_phrase : Pcoq.Gram.parsable * in_channel option -> + Util.loc * Vernacexpr.vernac_expr + +(* Reads and executes vernac commands from a stream. + The boolean [just_parsing] disables interpretation of commands. *) + +exception DuringCommandInterp of Util.loc * exn +exception End_of_input + +val just_parsing : bool ref +val raw_do_vernac : Pcoq.Gram.parsable -> unit + +(* Set XML hooks *) +val set_xml_start_library : (unit -> unit) -> unit +val set_xml_end_library : (unit -> unit) -> unit + +(* Load a vernac file, verbosely or not. Errors are annotated with file + and location *) + +val load_vernac : bool -> string -> unit + + +(* Compile a vernac file, verbosely or not (f is assumed without .v suffix) *) + +val compile : bool -> string -> unit + +(* Interpret a vernac AST *) + +val vernac_com : + (Vernacexpr.vernac_expr -> unit) -> + Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml new file mode 100644 index 00000000..1c6ad9a6 --- /dev/null +++ b/toplevel/vernacentries.ml @@ -0,0 +1,1240 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: vernacentries.ml,v 1.195.2.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(* Concrete syntax of the mathematical vernacular MV V2.6 *) + +open Pp +open Util +open Options +open Names +open Entries +open Nameops +open Term +open Pfedit +open Tacmach +open Proof_trees +open Constrintern +open Prettyp +open Printer +open Tacinterp +open Command +open Goptions +open Libnames +open Nametab +open Vernacexpr +open Decl_kinds +open Topconstr +open Pretyping + +(* Pcoq hooks *) + +type pcoq_hook = { + start_proof : unit -> unit; + solve : int -> unit; + abort : string -> unit; + search : searchable -> dir_path list * bool -> unit; + print_name : reference -> unit; + print_check : Environ.unsafe_judgment -> unit; + print_eval : (constr -> constr) -> Environ.env -> constr_expr -> + Environ.unsafe_judgment -> unit; + show_goal : int option -> unit +} + +let pcoq = ref None +let set_pcoq_hook f = pcoq := Some f + +(* Misc *) + +let cl_of_qualid = function + | FunClass -> Classops.CL_FUN + | SortClass -> Classops.CL_SORT + | RefClass r -> Class.class_of_ref (Nametab.global r) + +(*******************) +(* "Show" commands *) + +let show_proof () = + let pts = get_pftreestate () in + let pf = proof_of_pftreestate pts in + let cursor = cursor_of_pftreestate pts in + let evc = evc_of_pftreestate pts in + let (pfterm,meta_types) = extract_open_pftreestate pts in + msgnl (str"LOC: " ++ + prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ + str"Subgoals" ++ fnl () ++ + prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ + prtype ty ++ fnl ()) + meta_types + ++ str"Proof: " ++ prterm (Evarutil.nf_evar evc pfterm)) + +let show_node () = + let pts = get_pftreestate () in + let pf = proof_of_pftreestate pts + and cursor = cursor_of_pftreestate pts in + msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ + prgl (goal_of_proof pf) ++ fnl () ++ + (match pf.Proof_type.ref with + | None -> (str"BY <rule>") + | Some(r,spfl) -> + (str"BY " ++ Refiner.pr_rule r ++ fnl () ++ + str" " ++ + hov 0 (prlist_with_sep pr_fnl prgl + (List.map goal_of_proof spfl))))) + +let show_script () = + let pts = get_pftreestate () in + let pf = proof_of_pftreestate pts + and evc = evc_of_pftreestate pts in + msgnl (Refiner.print_treescript true evc (Global.named_context()) pf) + +let show_top_evars () = + let pfts = get_pftreestate () in + let gls = top_goal_of_pftreestate pfts in + let sigma = project gls in + msg (pr_evars_int 1 (Evd.non_instantiated sigma)) + +let show_prooftree () = + let pts = get_pftreestate () in + let pf = proof_of_pftreestate pts + and evc = evc_of_pftreestate pts in + msg (Refiner.print_proof evc (Global.named_context()) pf) + +let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () + + (* Simulate the Intro(s) tactic *) + +let fresh_id_of_name avoid gl = function + Anonymous -> Tactics.fresh_id avoid (id_of_string "H") gl + | Name id -> id + +let rec do_renum avoid gl = function + [] -> mt () + | [n] -> pr_id (fresh_id_of_name avoid gl n) + | n :: l -> + let id = fresh_id_of_name avoid gl n in + pr_id id ++ spc () ++ do_renum (id :: avoid) gl l + +let show_intro all = + let pf = get_pftreestate() in + let gl = nth_goal_of_pftreestate 1 pf in + let l,_= decompose_prod (strip_outer_cast (pf_concl gl)) in + let nl = List.rev_map fst l in + if all then + msgnl (do_renum [] gl nl) + else + try + let n = List.hd nl in + msgnl (pr_id (fresh_id_of_name [] gl n)) + with Failure "hd" -> message "" + +(********************) +(* "Print" commands *) + +let print_path_entry (s,l) = + (str s ++ str " " ++ tbrk (0,2) ++ str (string_of_dirpath l)) + +let print_loadpath () = + let l = Library.get_full_load_path () in + msgnl (Pp.t (str "Physical path: " ++ + tab () ++ str "Logical Path:" ++ fnl () ++ + prlist_with_sep pr_fnl print_path_entry l)) + +let print_modules () = + let opened = Library.opened_libraries () + and loaded = Library.loaded_libraries () in + let loaded_opened = list_intersect loaded opened + and only_loaded = list_subtract loaded opened in + str"Loaded and imported library files: " ++ + pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ + str"Loaded and not imported library files: " ++ + pr_vertical_list pr_dirpath only_loaded + + +let print_module r = + let (loc,qid) = qualid_of_reference r in + try + let globdir = Nametab.locate_dir qid in + match globdir with + DirModule (dirpath,(mp,_)) -> + msgnl (Printmod.print_module (Printmod.printable_body dirpath) mp) + | _ -> raise Not_found + with + Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid) + +let print_modtype r = + let (loc,qid) = qualid_of_reference r in + try + let kn = Nametab.locate_modtype qid in + msgnl (Printmod.print_modtype kn) + with + Not_found -> msgnl (str"Unknown Module Type " ++ pr_qualid qid) + +let dump_universes s = + let output = open_out s in + try + Univ.dump_universes output (Global.universes ()); + close_out output; + msgnl (str ("Universes written to file \""^s^"\".")) + with + e -> close_out output; raise e + +(*********************) +(* "Locate" commands *) + +let locate_file f = + try + let _,file = + System.where_in_path (Library.get_load_path()) f in + msgnl (str file) + with Not_found -> + msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++ + str"on loadpath")) + +let msg_found_library = function + | Library.LibLoaded, fulldir, file -> + msgnl(pr_dirpath fulldir ++ str " has been loaded from file" ++ fnl () ++ + str file) + | Library.LibInPath, fulldir, file -> + msgnl(pr_dirpath fulldir ++ str " is bound to file " ++ str file) +let msg_notfound_library loc qid = function + | Library.LibUnmappedDir -> + let dir = fst (repr_qualid qid) in + user_err_loc (loc,"locate_library", + str "Cannot find a physical path bound to logical path " ++ + pr_dirpath dir ++ fnl ()) + | Library.LibNotFound -> + msgnl (hov 0 + (str"Unable to locate library" ++ spc () ++ pr_qualid qid)) + | e -> assert false + +let print_located_library r = + let (loc,qid) = qualid_of_reference r in + try msg_found_library (Library.locate_qualified_library qid) + with e -> msg_notfound_library loc qid e + +(**********) +(* Syntax *) + +let vernac_syntax = Metasyntax.add_syntax_obj + +let vernac_grammar = Metasyntax.add_grammar_obj + +let vernac_syntax_extension = Metasyntax.add_syntax_extension + +let vernac_delimiters = Metasyntax.add_delimiters + +let vernac_bind_scope sc cll = + List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll + +let vernac_open_close_scope = Symbols.open_close_scope + +let vernac_arguments_scope qid scl = + Symbols.declare_arguments_scope (global qid) scl + +let vernac_infix = Metasyntax.add_infix + +let vernac_distfix = Metasyntax.add_distfix + +let vernac_notation = Metasyntax.add_notation + +(***********) +(* Gallina *) + +let start_proof_and_print idopt k t hook = + start_proof_com idopt k t hook; + print_subgoals (); + if !pcoq <> None then (out_some !pcoq).start_proof () + +let vernac_definition (local,_ as k) id def hook = + match def with + | ProveBody (bl,t) -> (* local binders, typ *) + if Lib.is_modtype () then + errorlabstrm "Vernacentries.VernacDefinition" + (str "Proof editing mode not supported in module types") + else + let hook _ _ = () in + let kind = if local=Local then IsLocal else IsGlobal DefinitionBody in + start_proof_and_print (Some id) kind (bl,t) hook + | DefineBody (bl,red_option,c,typ_opt) -> + let red_option = match red_option with + | None -> None + | Some r -> + let (evc,env)= Command.get_current_context () in + Some (interp_redexp env evc r) in + declare_definition id k bl red_option c typ_opt hook + +let vernac_start_proof kind sopt (bl,t) lettop hook = + if not(refining ()) then + if lettop then + errorlabstrm "Vernacentries.StartProof" + (str "Let declarations can only be used in proof editing mode"); + if Lib.is_modtype () then + errorlabstrm "Vernacentries.StartProof" + (str "Proof editing mode not supported in module types"); + start_proof_and_print sopt (IsGlobal (Proof kind)) (bl,t) hook + +let vernac_end_proof = function + | Admitted -> admit () + | Proved (is_opaque,idopt) -> + if_verbose show_script (); + match idopt with + | None -> save_named is_opaque + | Some ((_,id),None) -> save_anonymous is_opaque id + | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id + + (* A stupid macro that should be replaced by ``Exact c. Save.'' all along + the theories [??] *) + +let vernac_exact_proof c = + by (Tactics.exact_proof c); + save_named true + +let vernac_assumption kind l = + List.iter (fun (is_coe,(idl,c)) -> declare_assumption idl is_coe kind [] c) l + +let vernac_inductive f indl = build_mutual indl f + +let vernac_fixpoint = build_recursive + +let vernac_cofixpoint = build_corecursive + +let vernac_scheme = build_scheme + +(**********************) +(* Modules *) + +let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o = + (* We check the state of the system (in section, in module type) + and what module information is supplied *) + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections"; + + if not (Lib.is_modtype ()) then + error "Declare Module allowed in module types only"; + + let constrain_mty = match mty_ast_o with + Some (_,true) -> true + | _ -> false + in + + match mty_ast_o, constrain_mty, mexpr_ast_o with + | _, false, None -> (* no ident, no/soft type *) + Declaremods.start_module Modintern.interp_modtype + id binders_ast mty_ast_o; + if_verbose message + ("Interactive Declaration of Module "^ string_of_id id ^" started") + + | Some _, true, None (* no ident, hard type *) + | _, false, Some (CMEident _) -> (* ident, no/soft type *) + Declaremods.declare_module + Modintern.interp_modtype Modintern.interp_modexpr + id binders_ast mty_ast_o mexpr_ast_o; + if_verbose message + ("Module "^ string_of_id id ^" is declared") + + | _, true, Some (CMEident _) -> (* ident, hard type *) + error "You cannot declare an equality and a type in module declaration" + + | _, _, Some _ -> (* not ident *) + error "Only simple modules allowed in module declarations" + + | None,true,None -> assert false (* 1st None ==> false *) + +let vernac_define_module id binders_ast mty_ast_o mexpr_ast_o = + (* We check the state of the system (in section, in module type) + and what module information is supplied *) + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections"; + + if Lib.is_modtype () then + error "Module definitions not allowed in module types. Use Declare Module instead"; + + match mexpr_ast_o with + | None -> + Declaremods.start_module Modintern.interp_modtype + id binders_ast mty_ast_o; + if_verbose message + ("Interactive Module "^ string_of_id id ^" started") + + | Some _ -> + Declaremods.declare_module + Modintern.interp_modtype Modintern.interp_modexpr + id binders_ast mty_ast_o mexpr_ast_o; + if_verbose message + ("Module "^ string_of_id id ^" is defined") + +(* let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o = *) +(* (\* We check the state of the system (in section, in module type) *) +(* and what module information is supplied *\) *) +(* if Lib.sections_are_opened () then *) +(* error "Modules and Module Types are not allowed inside sections"; *) + +(* let constrain_mty = match mty_ast_o with *) +(* Some (_,true) -> true *) +(* | _ -> false *) +(* in *) + +(* match Lib.is_modtype (), mty_ast_o, constrain_mty, mexpr_ast_o with *) +(* | _, None, _, None *) +(* | true, Some _, false, None *) +(* | false, _, _, None -> *) +(* Declaremods.start_module Modintern.interp_modtype *) +(* id binders_ast mty_ast_o; *) +(* if_verbose message *) +(* ("Interactive Module "^ string_of_id id ^" started") *) + +(* | true, Some _, true, None *) +(* | true, _, false, Some (CMEident _) *) +(* | false, _, _, Some _ -> *) +(* Declaremods.declare_module *) +(* Modintern.interp_modtype Modintern.interp_modexpr *) +(* id binders_ast mty_ast_o mexpr_ast_o; *) +(* if_verbose message *) +(* ("Module "^ string_of_id id ^" is defined") *) + +(* | true, _, _, _ -> *) +(* error "Module definition not allowed in a Module Type" *) + +let vernac_end_module id = + Declaremods.end_module id; + if_verbose message + (if Lib.is_modtype () then + "Module "^ string_of_id id ^" is declared" + else + "Module "^ string_of_id id ^" is defined") + + + + +let vernac_declare_module_type id binders_ast mty_ast_o = + if Lib.sections_are_opened () then + error "Modules and Module Types are not allowed inside sections"; + + match mty_ast_o with + | None -> + Declaremods.start_modtype Modintern.interp_modtype id binders_ast; + if_verbose message + ("Interactive Module Type "^ string_of_id id ^" started") + + | Some base_mty -> + Declaremods.declare_modtype Modintern.interp_modtype + id binders_ast base_mty; + if_verbose message + ("Module Type "^ string_of_id id ^" is defined") + + +let vernac_end_modtype id = + Declaremods.end_modtype id; + if_verbose message + ("Module Type "^ string_of_id id ^" is defined") + + +(**********************) +(* Gallina extensions *) + +let vernac_record struc binders sort nameopt cfs = + let const = match nameopt with + | None -> add_prefix "Build_" (snd (snd struc)) + | Some (_,id) -> id in + let sigma = Evd.empty in + let env = Global.env() in + let s = interp_constr sigma env sort in + let s = Reductionops.whd_betadeltaiota env sigma s in + let s = match kind_of_term s with + | Sort s -> s + | _ -> user_err_loc + (constr_loc sort,"definition_structure", str "Sort expected") in + Record.definition_structure (struc,binders,cfs,const,s) + + (* Sections *) + +let vernac_begin_section id = let _ = Lib.open_section id in () + +let vernac_end_section id = + Discharge.close_section (is_verbose ()) id + + +let vernac_end_segment id = + check_no_pending_proofs (); + try + match Lib.what_is_opened () with + | _,Lib.OpenedModule _ -> vernac_end_module id + | _,Lib.OpenedModtype _ -> vernac_end_modtype id + | _,Lib.OpenedSection _ -> vernac_end_section id + | _ -> anomaly "No more opened things" + with + Not_found -> error "There is nothing to end." + +let is_obsolete_module (_,qid) = + match repr_qualid qid with + | dir, id when dir = empty_dirpath -> + (match string_of_id id with + | ("Refine" | "Inv" | "Equality" | "EAuto" | "AutoRewrite" + | "EqDecide" | "Xml" | "Extraction" | "Tauto" | "Setoid_replace" + | "Elimdep" + | "DatatypesSyntax" | "LogicSyntax" | "Logic_TypeSyntax" + | "SpecifSyntax" | "PeanoSyntax" | "TypeSyntax" | "PolyListSyntax") + -> true + | _ -> false) + | _ -> false + +let test_renamed_module (_,qid) = + match repr_qualid qid with + | dir, id when dir = empty_dirpath -> + (match string_of_id id with + | "List" -> warning "List has been renamed into MonoList" + | "PolyList" -> warning "PolyList has been renamed into List and old List into MonoList" + | _ -> ()) + | _ -> () + +let vernac_require import _ qidl = + let qidl = List.map qualid_of_reference qidl in + try + match import with + | None -> List.iter Library.read_library qidl + | Some b -> Library.require_library None qidl b + with e -> + (* Compatibility message *) + let qidl' = List.filter is_obsolete_module qidl in + if qidl' = qidl then + List.iter + (fun (_,qid) -> + warning ("Module "^(string_of_qualid qid)^ + " is now built-in and shouldn't be required")) qidl + else + (if not !Options.v7 then List.iter test_renamed_module qidl; + raise e) + +let vernac_import export refl = + let import_one ref = + let qid = qualid_of_reference ref in + Library.import_library export qid + in + List.iter import_one refl; + Lib.add_frozen_state () + +(* else + let import (loc,qid) = + try + let mp = Nametab.locate_module qid in + Declaremods.import_module mp + with Not_found -> + user_err_loc + (loc,"vernac_import", + str ((string_of_qualid qid)^" is not a module")) + in + List.iter import qidl; +*) + +let vernac_canonical locqid = + Recordobj.objdef_declare (Nametab.global locqid) + +let locate_reference ref = + let (loc,qid) = qualid_of_reference ref in + try match Nametab.extended_locate qid with + | TrueGlobal ref -> ref + | SyntacticDef kn -> + match Syntax_def.search_syntactic_definition loc kn with + | Rawterm.RRef (_,ref) -> ref + | _ -> raise Not_found + with Not_found -> + error_global_not_found_loc loc qid + +let vernac_coercion stre ref qids qidt = + let target = cl_of_qualid qidt in + let source = cl_of_qualid qids in + let ref' = locate_reference ref in + Class.try_add_new_coercion_with_target ref' stre source target; + if_verbose message ((string_of_reference ref) ^ " is now a coercion") + +let vernac_identity_coercion stre id qids qidt = + let target = cl_of_qualid qidt in + let source = cl_of_qualid qids in + Class.try_add_new_identity_coercion id stre source target + + +(***********) +(* Solving *) +let vernac_solve n tcom b = + if not (refining ()) then + error "Unknown command of the non proof-editing mode"; + begin + if b then + solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ())) + else solve_nth n (Tacinterp.hide_interp tcom None) + end; + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + if subtree_solved () then begin + Options.if_verbose msgnl (str "Subgoal proved"); + make_focus 0; + reset_top_of_tree () + end; + print_subgoals(); + if !pcoq <> None then (out_some !pcoq).solve n + + (* A command which should be a tactic. It has been + added by Christine to patch an error in the design of the proof + machine, and enables to instantiate existential variables when + there are no more goals to solve. It cannot be a tactic since + all tactics fail if there are no further goals to prove. *) + +let vernac_solve_existential = instantiate_nth_evar_com + +let vernac_set_end_tac tac = + if not (refining ()) then + error "Unknown command of the non proof-editing mode"; + if tac <> (Tacexpr.TacId "") then set_end_tac (Tacinterp.interp tac) +(* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) + + +(*****************************) +(* Auxiliary file management *) + +let vernac_require_from export spec filename = + match export with + Some exp -> + Library.require_library_from_file spec None filename exp + | None -> Library.read_library_from_file filename + +let vernac_add_loadpath isrec pdir ldiropt = + let alias = match ldiropt with + | None -> Nameops.default_root_prefix + | Some ldir -> ldir in + (if isrec then Mltop.add_rec_path else Mltop.add_path) pdir alias + +let vernac_remove_loadpath = Library.remove_path + + (* Coq syntax for ML or system commands *) + +let vernac_add_ml_path isrec s = + (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (System.glob s) + +let vernac_declare_ml_module l = Mltop.declare_ml_modules l + +let vernac_chdir = function + | None -> message (Sys.getcwd()) + | Some s -> + begin + try Sys.chdir (System.glob s) + with Sys_error str -> warning ("Cd failed: " ^ str) + end; + if_verbose message (Sys.getcwd()) + + +(********************) +(* State management *) + +let abort_refine f x = + if Pfedit.refining() then delete_all_proofs (); + f x + (* used to be: error "Must save or abort current goal first" *) + +let vernac_write_state file = abort_refine States.extern_state file + +let vernac_restore_state file = abort_refine States.intern_state file + + +(*************) +(* Resetting *) + +let vernac_reset_name id = abort_refine Lib.reset_name id + +let vernac_reset_initial () = abort_refine Lib.reset_initial () + +let vernac_back n = Lib.back n + + +(************) +(* Commands *) + +let vernac_declare_tactic_definition = Tacinterp.add_tacdef + +let vernac_hints = Auto.add_hints + +let vernac_syntactic_definition = Command.syntax_definition + +let vernac_declare_implicits locqid = function + | Some imps -> Impargs.declare_manual_implicits (Nametab.global locqid) imps + | None -> Impargs.declare_implicits (Nametab.global locqid) + +let vernac_reserve idl c = + let t = Constrintern.interp_type Evd.empty (Global.env()) c in + let t = Detyping.detype (false,Global.env()) [] [] t in + List.iter (fun id -> Reserve.declare_reserved_type id t) idl + +let make_silent_if_not_pcoq b = + if !pcoq <> None then + error "Turning on/off silent flag is not supported in Centaur mode" + else make_silent b + +let _ = + declare_bool_option + { optsync = false; + optname = "silent"; + optkey = (PrimaryTable "Silent"); + optread = is_silent; + optwrite = make_silent_if_not_pcoq } + +let _ = + declare_bool_option + { optsync = true; + optname = "implicit arguments"; + optkey = (SecondaryTable ("Implicit","Arguments")); + optread = Impargs.is_implicit_args; + optwrite = Impargs.make_implicit_args } + +let impargs = if !Options.v7 then "Implicits" else "Implicit" + +let _ = + declare_bool_option + { optsync = false; (* synchronisation is in Impargs *) + optname = "strict implicit arguments"; + optkey = (SecondaryTable ("Strict",impargs)); + optread = Impargs.is_strict_implicit_args; + optwrite = Impargs.make_strict_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optname = "contextual implicit arguments"; + optkey = (SecondaryTable ("Contextual",impargs)); + optread = Impargs.is_contextual_implicit_args; + optwrite = Impargs.make_contextual_implicit_args } + +let _ = + declare_bool_option + { optsync = true; + optname = "coercion printing"; + optkey = (SecondaryTable ("Printing","Coercions")); + optread = (fun () -> !Constrextern.print_coercions); + optwrite = (fun b -> Constrextern.print_coercions := b) } + +let _ = + declare_bool_option + { optsync = true; + optname = "implicit arguments printing"; + optkey = (SecondaryTable ("Printing",impargs)); + optread = (fun () -> !Constrextern.print_implicits); + optwrite = (fun b -> Constrextern.print_implicits := b) } + +let _ = + declare_bool_option + { optsync = true; + optname = "projection printing using dot notation"; + optkey = (SecondaryTable ("Printing","Projections")); + optread = (fun () -> !Constrextern.print_projections); + optwrite = (fun b -> Constrextern.print_projections := b) } + +let _ = + declare_bool_option + { optsync = true; + optname = "notations printing"; + optkey = (SecondaryTable ("Printing",if !Options.v7 then "Symbols" else "Notations")); + optread = (fun () -> not !Constrextern.print_no_symbol); + optwrite = (fun b -> Constrextern.print_no_symbol := not b) } + +let _ = + declare_bool_option + { optsync = true; + optname = "raw printing"; + optkey = (SecondaryTable ("Printing","All")); + optread = (fun () -> !Options.raw_print); + optwrite = (fun b -> Options.raw_print := b) } + +let _ = + declare_int_option + { optsync=false; + optkey=PrimaryTable("Undo"); + optname="the undo limit"; + optread=Pfedit.get_undo; + optwrite=Pfedit.set_undo } + +let _ = + declare_int_option + { optsync=false; + optkey=SecondaryTable("Hyps","Limit"); + optname="the hypotheses limit"; + optread=Options.print_hyps_limit; + optwrite=Options.set_print_hyps_limit } + +let _ = + declare_int_option + { optsync=true; + optkey=SecondaryTable("Printing","Depth"); + optname="the printing depth"; + optread=Pp_control.get_depth_boxes; + optwrite=Pp_control.set_depth_boxes } + +let _ = + declare_int_option + { optsync=true; + optkey=SecondaryTable("Printing","Width"); + optname="the printing width"; + optread=Pp_control.get_margin; + optwrite=Pp_control.set_margin } + +let vernac_set_opacity opaq locqid = + match Nametab.global locqid with + | ConstRef sp -> + if opaq then Tacred.set_opaque_const sp + else Tacred.set_transparent_const sp + | VarRef id -> + if opaq then Tacred.set_opaque_var id + else Tacred.set_transparent_var id + | _ -> error "cannot set an inductive type or a constructor as transparent" + +let vernac_set_option key = function + | StringValue s -> set_string_option_value key s + | IntValue n -> set_int_option_value key (Some n) + | BoolValue b -> set_bool_option_value key b + +let vernac_unset_option key = + try set_bool_option_value key false + with _ -> + set_int_option_value key None + +let vernac_add_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#add s + | QualidRefValue locqid -> (get_ref_table key)#add locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_remove_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#remove s + | QualidRefValue locqid -> (get_ref_table key)#remove locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_mem_option key lv = + let f = function + | StringRefValue s -> (get_string_table key)#mem s + | QualidRefValue locqid -> (get_ref_table key)#mem locqid + in + try List.iter f lv with Not_found -> error_undeclared_key key + +let vernac_print_option key = + try (get_ref_table key)#print + with Not_found -> + try (get_string_table key)#print + with Not_found -> + try print_option_value key + with Not_found -> error_undeclared_key key + +let get_current_context_of_args = function + | Some n -> get_goal_context n + | None -> get_current_context () + +let vernac_check_may_eval redexp glopt rc = + let (evmap,env) = get_current_context_of_args glopt in + let c = interp_constr evmap env rc in + let j = Typeops.typing env c in + match redexp with + | None -> + if !pcoq <> None then (out_some !pcoq).print_check j + else msg (print_judgment env j) + | Some r -> + let redfun = Tacred.reduction_of_redexp (interp_redexp env evmap r) in + if !pcoq <> None + then (out_some !pcoq).print_eval (redfun env evmap) env rc j + else msg (print_eval redfun env j) + + (* The same but avoiding the current goal context if any *) +let vernac_global_check c = + let evmap = Evd.empty in + let env = Global.env() in + let c = interp_constr evmap env c in + let senv = Global.safe_env() in + let j = Safe_typing.typing senv c in + msg (print_safe_judgment env j) + +let vernac_print = function + | PrintTables -> print_tables () + | PrintLocalContext -> msg (print_local_context ()) + | PrintFullContext -> msg (print_full_context_typ ()) + | PrintSectionContext qid -> msg (print_sec_context_typ qid) + | PrintInspect n -> msg (inspect n) + | PrintGrammar (uni,ent) -> Metasyntax.print_grammar uni ent + | PrintLoadPath -> (* For compatibility ? *) print_loadpath () + | PrintModules -> msg (print_modules ()) + | PrintModule qid -> print_module qid + | PrintModuleType qid -> print_modtype qid + | PrintMLLoadPath -> Mltop.print_ml_path () + | PrintMLModules -> Mltop.print_ml_modules () + | PrintName qid -> + if !pcoq <> None then (out_some !pcoq).print_name qid + else msg (print_name qid) + | PrintOpaqueName qid -> msg (print_opaque_name qid) + | PrintGraph -> ppnl (Prettyp.print_graph()) + | PrintClasses -> ppnl (Prettyp.print_classes()) + | PrintCoercions -> ppnl (Prettyp.print_coercions()) + | PrintCoercionPaths (cls,clt) -> + ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) + | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ())) + | PrintUniverses (Some s) -> dump_universes s + | PrintHint qid -> Auto.print_hint_ref (Nametab.global qid) + | PrintHintGoal -> Auto.print_applicable_hint () + | PrintHintDbName s -> Auto.print_hint_db_by_name s + | PrintHintDb -> Auto.print_searchtable () + | PrintScopes -> + pp (Symbols.pr_scopes (Constrextern.without_symbols pr_rawterm)) + | PrintScope s -> + pp (Symbols.pr_scope (Constrextern.without_symbols pr_rawterm) s) + | PrintVisibility s -> + pp (Symbols.pr_visibility (Constrextern.without_symbols pr_rawterm) s) + | PrintAbout qid -> msgnl (print_about qid) + | PrintImplicit qid -> msg (print_impargs qid) + +let global_module r = + let (loc,qid) = qualid_of_reference r in + try Nametab.full_name_module qid + with Not_found -> + user_err_loc (loc, "global_module", + str "Module/section " ++ pr_qualid qid ++ str " not found") + +let interp_search_restriction = function + | SearchOutside l -> (List.map global_module l, true) + | SearchInside l -> (List.map global_module l, false) + +open Search + +let interp_search_about_item = function + | SearchRef qid -> GlobSearchRef (Nametab.global qid) + | SearchString s -> GlobSearchString s + +let vernac_search s r = + let r = interp_search_restriction r in + if !pcoq <> None then (out_some !pcoq).search s r else + match s with + | SearchPattern c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + Search.search_pattern pat r + | SearchRewrite c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + Search.search_rewrite pat r + | SearchHead locqid -> + Search.search_by_head (Nametab.global locqid) r + | SearchAbout sl -> + Search.search_about (List.map interp_search_about_item sl) r + +let vernac_locate = function + | LocateTerm qid -> msgnl (print_located_qualid qid) + | LocateLibrary qid -> print_located_library qid + | LocateFile f -> locate_file f + | LocateNotation ntn -> + ppnl (Symbols.locate_notation (Constrextern.without_symbols pr_rawterm) + (Metasyntax.standardise_locatable_notation ntn)) + +(********************) +(* Proof management *) + +let vernac_goal = function + | None -> () + | Some c -> + if not (refining()) then begin + let unnamed_kind = Lemma (* Arbitrary *) in + start_proof_com None (IsGlobal (Proof unnamed_kind)) c (fun _ _ ->()); + print_subgoals () + end else + error "repeated Goal not permitted in refining mode" + +let vernac_abort = function + | None -> + delete_current_proof (); + if_verbose message "Current goal aborted"; + if !pcoq <> None then (out_some !pcoq).abort "" + | Some id -> + delete_proof id; + let s = string_of_id (snd id) in + if_verbose message ("Goal "^s^" aborted"); + if !pcoq <> None then (out_some !pcoq).abort s + +let vernac_abort_all () = + if refining() then begin + delete_all_proofs (); + message "Current goals aborted" + end else + error "No proof-editing in progress" + +let vernac_restart () = restart_proof(); print_subgoals () + + (* Proof switching *) + +let vernac_suspend = suspend_proof + +let vernac_resume = function + | None -> resume_last_proof () + | Some id -> resume_proof id + +let vernac_undo n = + undo n; + print_subgoals () + + (* Est-ce normal que "Focus" ne semble pas se comporter comme "Focus 1" ? *) +let vernac_focus = function + | None -> traverse_nth_goal 1; print_subgoals () + | Some n -> traverse_nth_goal n; print_subgoals () + + (* Reset the focus to the top of the tree *) +let vernac_unfocus () = + make_focus 0; reset_top_of_tree (); print_subgoals () + +let vernac_go = function + | GoTo n -> Pfedit.traverse n;show_node() + | GoTop -> Pfedit.reset_top_of_tree ();show_node() + | GoNext -> Pfedit.traverse_next_unproven ();show_node() + | GoPrev -> Pfedit.traverse_prev_unproven ();show_node() + +let apply_subproof f occ = + let pts = get_pftreestate() in + let evc = evc_of_pftreestate pts in + let rec aux pts = function + | [] -> pts + | (n::l) -> aux (Tacmach.traverse n pts) occ in + let pts = aux pts (occ@[-1]) in + let pf = proof_of_pftreestate pts in + f evc (Global.named_context()) pf + +let explain_proof occ = + msg (apply_subproof (Refiner.print_treescript true) occ) + +let explain_tree occ = + msg (apply_subproof Refiner.print_proof occ) + +let vernac_show = function + | ShowGoal nopt -> + if !pcoq <> None then (out_some !pcoq).show_goal nopt + else msg (match nopt with + | None -> pr_open_subgoals () + | Some n -> pr_nth_open_subgoal n) + | ShowGoalImplicitly None -> + Constrextern.with_implicits msg (pr_open_subgoals ()) + | ShowGoalImplicitly (Some n) -> + Constrextern.with_implicits msg (pr_nth_open_subgoal n) + | ShowProof -> show_proof () + | ShowNode -> show_node () + | ShowScript -> show_script () + | ShowExistentials -> show_top_evars () + | ShowTree -> show_prooftree () + | ShowProofNames -> + msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names())) + | ShowIntros all -> show_intro all + | ExplainProof occ -> explain_proof occ + | ExplainTree occ -> explain_tree occ + +let vernac_check_guard () = + let pts = get_pftreestate () in + let pf = proof_of_pftreestate pts + and cursor = cursor_of_pftreestate pts in + let (pfterm,_) = extract_open_pftreestate pts in + let message = + try + Inductiveops.control_only_guard (Evarutil.evar_env (goal_of_proof pf)) + pfterm; + (str "The condition holds up to here") + with UserError(_,s) -> + (str ("Condition violated : ") ++s) + in + msgnl message + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + + +(**************************) +(* Not supported commands *) +(*** +let _ = + add "ResetSection" + (function + | [VARG_IDENTIFIER id] -> + (fun () -> reset_section (string_of_id id)) + | _ -> bad_vernac_args "ResetSection") + +(* Modules *) + +let _ = + vinterp_add "BeginModule" + (function + | [VARG_IDENTIFIER id] -> + let s = string_of_id id in + let lpe,_ = System.find_file_in_path (Library.get_load_path ()) (s^".v") in + let dir = extend_dirpath (Library.find_logical_path lpe) id in + fun () -> + Lib.start_module dir + | _ -> bad_vernac_args "BeginModule") + +let _ = + vinterp_add "WriteModule" + (function + | [VARG_IDENTIFIER id] -> + let mid = Lib.end_module id in + fun () -> let m = string_of_id id in Library.save_module_to mid m + | [VARG_IDENTIFIER id; VARG_STRING f] -> + let mid = Lib.end_module id in + fun () -> Library.save_module_to mid f + | _ -> bad_vernac_args "WriteModule") + +let _ = + vinterp_add "CLASS" + (function + | [VARG_STRING kind; VARG_QUALID qid] -> + let stre = + if kind = "LOCAL" then + make_strength_0() + else + Nametab.NeverDischarge + in + fun () -> + let ref = Nametab.global (dummy_loc, qid) in + Class.try_add_new_class ref stre; + if_verbose message + ((string_of_qualid qid) ^ " is now a class") + | _ -> bad_vernac_args "CLASS") + +(* Meta-syntax commands *) +let _ = + add "TOKEN" + (function + | [VARG_STRING s] -> (fun () -> Metasyntax.add_token_obj s) + | _ -> bad_vernac_args "TOKEN") +***) + +(* Search commands *) + +(*** +let _ = + add "Searchisos" + (function + | [VARG_CONSTR com] -> + (fun () -> + let env = Global.env() in + let c = constr_of_com Evd.empty env com in + let cc = nf_betaiota env Evd.empty c in + Searchisos.type_search cc) + | _ -> bad_vernac_args "Searchisos") +***) + +let interp c = match c with + (* Control (done in vernac) *) + | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false + | (VernacV7only _ | VernacV8only _) -> assert false + + (* Syntax *) + | VernacSyntax (whatfor,sel) -> vernac_syntax whatfor sel + | VernacTacticGrammar al -> Metasyntax.add_tactic_grammar al + | VernacGrammar (univ,al) -> vernac_grammar univ al + | VernacSyntaxExtension (lcl,sl,l8) -> vernac_syntax_extension lcl sl l8 + | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr + | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl + | VernacOpenCloseScope sc -> vernac_open_close_scope sc + | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope qid scl + | VernacInfix (local,mv,qid,mv8,sc) -> vernac_infix local mv qid mv8 sc + | VernacDistfix (local,assoc,n,inf,qid,sc) -> + vernac_distfix local assoc n inf qid sc + | VernacNotation (local,c,infpl,mv8,sc) -> + vernac_notation local c infpl mv8 sc + + (* Gallina *) + | VernacDefinition (k,(_,id),d,f) -> vernac_definition k id d f + | VernacStartTheoremProof (k,(_,id),t,top,f) -> + vernac_start_proof k (Some id) t top f + | VernacEndProof e -> vernac_end_proof e + | VernacExactProof c -> vernac_exact_proof c + | VernacAssumption (stre,l) -> vernac_assumption stre l + | VernacInductive (finite,l) -> vernac_inductive finite l + | VernacFixpoint l -> vernac_fixpoint l + | VernacCoFixpoint l -> vernac_cofixpoint l + | VernacScheme l -> vernac_scheme l + + (* Modules *) + | VernacDeclareModule ((_,id),bl,mtyo,mexpro) -> + vernac_declare_module id bl mtyo mexpro + | VernacDefineModule ((_,id),bl,mtyo,mexpro) -> + vernac_define_module id bl mtyo mexpro + | VernacDeclareModuleType ((_,id),bl,mtyo) -> + vernac_declare_module_type id bl mtyo + + (* Gallina extensions *) + | VernacBeginSection (_,id) -> vernac_begin_section id + + | VernacEndSegment (_,id) -> vernac_end_segment id + + | VernacRecord (_,id,bl,s,idopt,fs) -> vernac_record id bl s idopt fs + | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl + | VernacImport (export,qidl) -> vernac_import export qidl + | VernacCanonical qid -> vernac_canonical qid + | VernacCoercion (str,r,s,t) -> vernac_coercion str r s t + | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t + + (* Solving *) + | VernacSolve (n,tac,b) -> vernac_solve n tac b + | VernacSolveExistential (n,c) -> vernac_solve_existential n c + + (* Auxiliary file and library management *) + | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f + | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias + | VernacRemoveLoadPath s -> vernac_remove_loadpath s + | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s + | VernacDeclareMLModule l -> vernac_declare_ml_module l + | VernacChdir s -> vernac_chdir s + + (* State management *) + | VernacWriteState s -> vernac_write_state s + | VernacRestoreState s -> vernac_restore_state s + + (* Resetting *) + | VernacResetName id -> vernac_reset_name id + | VernacResetInitial -> vernac_reset_initial () + | VernacBack n -> vernac_back n + + (* Commands *) + | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l + | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints + | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b + | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits qid l + | VernacReserve (idl,c) -> vernac_reserve idl c + | VernacSetOpacity (opaq, qidl) -> List.iter (vernac_set_opacity opaq) qidl + | VernacSetOption (key,v) -> vernac_set_option key v + | VernacUnsetOption key -> vernac_unset_option key + | VernacRemoveOption (key,v) -> vernac_remove_option key v + | VernacAddOption (key,v) -> vernac_add_option key v + | VernacMemOption (key,v) -> vernac_mem_option key v + | VernacPrintOption key -> vernac_print_option key + | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c + | VernacGlobalCheck c -> vernac_global_check c + | VernacPrint p -> vernac_print p + | VernacSearch (s,r) -> vernac_search s r + | VernacLocate l -> vernac_locate l + | VernacComments l -> if_verbose message ("Comments ok\n") + | VernacNop -> () + + (* Proof management *) + | VernacGoal t -> vernac_start_proof Theorem None ([],t) false (fun _ _ ->()) + | VernacAbort id -> vernac_abort id + | VernacAbortAll -> vernac_abort_all () + | VernacRestart -> vernac_restart () + | VernacSuspend -> vernac_suspend () + | VernacResume id -> vernac_resume id + | VernacUndo n -> vernac_undo n + | VernacFocus n -> vernac_focus n + | VernacUnfocus -> vernac_unfocus () + | VernacGo g -> vernac_go g + | VernacShow s -> vernac_show s + | VernacCheckGuard -> vernac_check_guard () + | VernacDebug b -> vernac_debug b + | VernacProof tac -> vernac_set_end_tac tac + (* Toplevel control *) + | VernacToplevelControl e -> raise e + + (* Extensions *) + | VernacExtend (opn,args) -> Vernacinterp.call (opn,args) diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli new file mode 100644 index 00000000..a359b4a1 --- /dev/null +++ b/toplevel/vernacentries.mli @@ -0,0 +1,54 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: vernacentries.mli,v 1.16.2.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(*i*) +open Names +open Term +open Vernacinterp +open Vernacexpr +open Topconstr +(*i*) + +(* Vernacular entries *) + +val show_script : unit -> unit +val show_prooftree : unit -> unit + +val show_node : unit -> unit + +(* This function can be used by any command that want to observe terms + in the context of the current goal, as for instance in pcoq *) +val get_current_context_of_args : int option -> Evd.evar_map * Environ.env + +(* this function is used to analyse the extra arguments in search commands. + It is used in pcoq. *) (*i anciennement: inside_outside i*) +(* +val interp_search_restriction : search_restriction -> dir_path list * bool +*) + +type pcoq_hook = { + start_proof : unit -> unit; + solve : int -> unit; + abort : string -> unit; + search : searchable -> dir_path list * bool -> unit; + print_name : Libnames.reference -> unit; + print_check : Environ.unsafe_judgment -> unit; + print_eval : (constr -> constr) -> Environ.env -> constr_expr -> Environ.unsafe_judgment -> unit; + show_goal : int option -> unit +} + +val set_pcoq_hook : pcoq_hook -> unit + +(* This function makes sure that the function given is argument is preceded + by a command aborting all proofs if necessary. + It is used in pcoq. *) +val abort_refine : ('a -> unit) -> 'a -> unit;; + +val interp : Vernacexpr.vernac_expr -> unit diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml new file mode 100644 index 00000000..e1525c17 --- /dev/null +++ b/toplevel/vernacexpr.ml @@ -0,0 +1,293 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: vernacexpr.ml,v 1.55.2.1 2004/07/16 19:31:50 herbelin Exp $ *) + +open Util +open Names +open Tacexpr +open Extend +open Genarg +open Topconstr +open Decl_kinds +open Ppextend + +(* Toplevel control exceptions *) +exception ProtectedLoop +exception Drop +exception Quit + +open Libnames +open Nametab + +type lident = identifier located +type lname = name located +type lstring = string +type lreference = reference + +type class_rawexpr = FunClass | SortClass | RefClass of reference + +type printable = + | PrintTables + | PrintLocalContext + | PrintFullContext + | PrintSectionContext of reference + | PrintInspect of int + | PrintGrammar of string * string + | PrintLoadPath + | PrintModules + | PrintModule of reference + | PrintModuleType of reference + | PrintMLLoadPath + | PrintMLModules + | PrintName of reference + | PrintOpaqueName of reference + | PrintGraph + | PrintClasses + | PrintCoercions + | PrintCoercionPaths of class_rawexpr * class_rawexpr + | PrintUniverses of string option + | PrintHint of reference + | PrintHintGoal + | PrintHintDbName of string + | PrintHintDb + | PrintScopes + | PrintScope of string + | PrintVisibility of string option + | PrintAbout of reference + | PrintImplicit of reference + +type search_about_item = + | SearchRef of reference + | SearchString of string + +type searchable = + | SearchPattern of pattern_expr + | SearchRewrite of pattern_expr + | SearchHead of reference + | SearchAbout of search_about_item list + +type locatable = + | LocateTerm of reference + | LocateLibrary of reference + | LocateFile of string + | LocateNotation of notation + +type goable = + | GoTo of int + | GoTop + | GoNext + | GoPrev + +type showable = + | ShowGoal of int option + | ShowGoalImplicitly of int option + | ShowProof + | ShowNode + | ShowScript + | ShowExistentials + | ShowTree + | ShowProofNames + | ShowIntros of bool + | ExplainProof of int list + | ExplainTree of int list + +type comment = + | CommentConstr of constr_expr + | CommentString of string + | CommentInt of int + +type hints = + | HintsResolve of (identifier option * constr_expr) list + | HintsImmediate of (identifier option * constr_expr) list + | HintsUnfold of (identifier option * reference) list + | HintsConstructors of identifier option * reference list + | HintsExtern of identifier option * int * constr_expr * raw_tactic_expr + | HintsDestruct of identifier * + int * (bool,unit) location * constr_expr * raw_tactic_expr + +type search_restriction = + | SearchInside of reference list + | SearchOutside of reference list + +type option_value = + | StringValue of string + | IntValue of int + | BoolValue of bool + +type option_ref_value = + | StringRefValue of string + | QualidRefValue of reference + +type rec_flag = bool (* true = Rec; false = NoRec *) +type verbose_flag = bool (* true = Verbose; false = Silent *) +type opacity_flag = bool (* true = Opaque; false = Transparent *) +type locality_flag = bool (* true = Local; false = Global *) +type coercion_flag = bool (* true = AddCoercion; false = NoCoercion *) +type export_flag = bool (* true = Export; false = Import *) +type specif_flag = bool (* true = Specification; false = Implementation *) +type inductive_flag = bool (* true = Inductive; false = CoInductive *) +type onlyparsing_flag = bool (* true = Parse only; false = Print also *) + +type sort_expr = Rawterm.rawsort + +type decl_notation = (string * constr_expr * scope_name option) option +type simple_binder = lident list * constr_expr +type 'a with_coercion = coercion_flag * 'a +type constructor_expr = (lident * constr_expr) with_coercion +type inductive_expr = + lident * decl_notation * local_binder list * constr_expr + * constructor_expr list +type definition_expr = + | ProveBody of local_binder list * constr_expr + | DefineBody of local_binder list * raw_red_expr option * constr_expr + * constr_expr option + +type local_decl_expr = + | AssumExpr of lname * constr_expr + | DefExpr of lname * constr_expr * constr_expr option + +type module_binder = lident list * module_type_ast + +type proof_end = + | Admitted + | Proved of opacity_flag * (lident * theorem_kind option) option + +type vernac_expr = + (* Control *) + | VernacList of located_vernac_expr list + | VernacLoad of verbose_flag * lstring + | VernacTime of vernac_expr + | VernacVar of lident + + (* Syntax *) + | VernacGrammar of lstring * raw_grammar_entry list + | VernacTacticGrammar of + (lstring * (lstring * grammar_production list) * raw_tactic_expr) list + | VernacSyntax of lstring * raw_syntax_entry list + | VernacSyntaxExtension of locality_flag * + (lstring * syntax_modifier list) option + * (lstring * syntax_modifier list) option + | VernacDistfix of locality_flag * + grammar_associativity * precedence * lstring * lreference * + scope_name option + | VernacOpenCloseScope of (locality_flag * bool * scope_name) + | VernacDelimiters of scope_name * lstring + | VernacBindScope of scope_name * class_rawexpr list + | VernacArgumentsScope of lreference * scope_name option list + | VernacInfix of locality_flag * (lstring * syntax_modifier list) * + lreference * (lstring * syntax_modifier list) option * scope_name option + | VernacNotation of + locality_flag * constr_expr * (lstring * syntax_modifier list) option * + (lstring * syntax_modifier list) option * scope_name option + + (* Gallina *) + | VernacDefinition of definition_kind * lident * definition_expr * + declaration_hook + | VernacStartTheoremProof of theorem_kind * lident * + (local_binder list * constr_expr) * bool * declaration_hook + | VernacEndProof of proof_end + | VernacExactProof of constr_expr + | VernacAssumption of assumption_kind * simple_binder with_coercion list + | VernacInductive of inductive_flag * inductive_expr list + | VernacFixpoint of (fixpoint_expr * decl_notation) list + | VernacCoFixpoint of cofixpoint_expr list + | VernacScheme of (lident * bool * lreference * sort_expr) list + + (* Gallina extensions *) + | VernacRecord of bool (* = Record or Structure *) + * lident with_coercion * local_binder list + * constr_expr * lident option * local_decl_expr with_coercion list + | VernacBeginSection of lident + | VernacEndSegment of lident + | VernacRequire of + export_flag option * specif_flag option * lreference list + | VernacImport of export_flag * lreference list + | VernacCanonical of lreference + | VernacCoercion of strength * lreference * class_rawexpr * class_rawexpr + | VernacIdentityCoercion of strength * lident * + class_rawexpr * class_rawexpr + + (* Modules and Module Types *) + | VernacDeclareModule of lident * + module_binder list * (module_type_ast * bool) option * module_ast option + | VernacDefineModule of lident * + module_binder list * (module_type_ast * bool) option * module_ast option + | VernacDeclareModuleType of lident * + module_binder list * module_type_ast option + + (* Solving *) + | VernacSolve of int * raw_tactic_expr * bool + | VernacSolveExistential of int * constr_expr + + (* Auxiliary file and library management *) + | VernacRequireFrom of export_flag option * specif_flag option * lstring + | VernacAddLoadPath of rec_flag * lstring * dir_path option + | VernacRemoveLoadPath of lstring + | VernacAddMLPath of rec_flag * lstring + | VernacDeclareMLModule of lstring list + | VernacChdir of lstring option + + (* State management *) + | VernacWriteState of lstring + | VernacRestoreState of lstring + + (* Resetting *) + | VernacResetName of lident + | VernacResetInitial + | VernacBack of int + + (* Commands *) + | VernacDeclareTacticDefinition of + rec_flag * (lident * raw_tactic_expr) list + | VernacHints of locality_flag * lstring list * hints + | VernacSyntacticDefinition of identifier * constr_expr * locality_flag * + onlyparsing_flag + | VernacDeclareImplicits of lreference * explicitation list option + | VernacReserve of lident list * constr_expr + | VernacSetOpacity of opacity_flag * lreference list + | VernacUnsetOption of Goptions.option_name + | VernacSetOption of Goptions.option_name * option_value + | VernacAddOption of Goptions.option_name * option_ref_value list + | VernacRemoveOption of Goptions.option_name * option_ref_value list + | VernacMemOption of Goptions.option_name * option_ref_value list + | VernacPrintOption of Goptions.option_name + | VernacCheckMayEval of raw_red_expr option * int option * constr_expr + | VernacGlobalCheck of constr_expr + | VernacPrint of printable + | VernacSearch of searchable * search_restriction + | VernacLocate of locatable + | VernacComments of comment list + | VernacNop + + (* Proof management *) + | VernacGoal of constr_expr + | VernacAbort of lident option + | VernacAbortAll + | VernacRestart + | VernacSuspend + | VernacResume of lident option + | VernacUndo of int + | VernacFocus of int option + | VernacUnfocus + | VernacGo of goable + | VernacShow of showable + | VernacCheckGuard + | VernacDebug of bool + | VernacProof of raw_tactic_expr + (* Toplevel control *) + | VernacToplevelControl of exn + + (* For translation from V7 to V8 syntax *) + | VernacV8only of vernac_expr + | VernacV7only of vernac_expr + + (* For extension *) + | VernacExtend of string * raw_generic_argument list + +and located_vernac_expr = loc * vernac_expr diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml new file mode 100644 index 00000000..c7846d71 --- /dev/null +++ b/toplevel/vernacinterp.ml @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: vernacinterp.ml,v 1.17.8.1 2004/07/16 19:31:50 herbelin Exp $ *) + +open Pp +open Util +open Names +open Libnames +open Himsg +open Proof_type +open Tacinterp +open Coqast +open Vernacexpr +open Ast +open Extend + +let disable_drop e = + if e <> Drop then e + else UserError("Vernac.disable_drop",(str"Drop is forbidden.")) + +(* Table of vernac entries *) +let vernac_tab = + (Hashtbl.create 51 : + (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t) + +let vinterp_add s f = + try + Hashtbl.add vernac_tab s f + with Failure _ -> + errorlabstrm "vinterp_add" + (str"Cannot add the vernac command " ++ str s ++ str" twice") + +let overwriting_vinterp_add s f = + begin + try + let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s + with Not_found -> () + end; + Hashtbl.add vernac_tab s f + +let vinterp_map s = + try + Hashtbl.find vernac_tab s + with Not_found -> + errorlabstrm "Vernac Interpreter" + (str"Cannot find vernac command " ++ str s) + +let vinterp_init () = Hashtbl.clear vernac_tab + +(* Interpretation of a vernac command *) + +let call (opn,converted_args) = + let loc = ref "Looking up command" in + try + let callback = vinterp_map opn in + loc:= "Checking arguments"; + let hunk = callback converted_args in + loc:= "Executing command"; + hunk() + with + | Drop -> raise Drop + | ProtectedLoop -> raise ProtectedLoop + | e -> + if !Options.debug then + msgnl (str"Vernac Interpreter " ++ str !loc); + raise e + +let bad_vernac_args s = + anomalylabstrm s + (str"Vernac " ++ str s ++ str" called with bad arguments") diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli new file mode 100644 index 00000000..86b80935 --- /dev/null +++ b/toplevel/vernacinterp.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: vernacinterp.mli,v 1.11.10.1 2004/07/16 19:31:50 herbelin Exp $ i*) + +(*i*) +open Tacexpr +(*i*) + +(* Interpretation of extended vernac phrases. *) + +val disable_drop : exn -> exn + +val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit +val overwriting_vinterp_add : + string -> (raw_generic_argument list -> unit -> unit) -> unit + +val vinterp_init : unit -> unit +val call : string * raw_generic_argument list -> unit |