summaryrefslogtreecommitdiff
path: root/toplevel
diff options
context:
space:
mode:
Diffstat (limited to 'toplevel')
-rw-r--r--toplevel/cerrors.ml134
-rw-r--r--toplevel/cerrors.mli25
-rw-r--r--toplevel/class.ml460
-rw-r--r--toplevel/class.mli68
-rw-r--r--toplevel/command.ml701
-rw-r--r--toplevel/command.mli85
-rw-r--r--toplevel/coqinit.ml115
-rw-r--r--toplevel/coqinit.mli27
-rw-r--r--toplevel/coqtop.ml325
-rw-r--r--toplevel/coqtop.mli23
-rw-r--r--toplevel/discharge.ml328
-rw-r--r--toplevel/discharge.mli18
-rw-r--r--toplevel/doc.tex10
-rw-r--r--toplevel/fhimsg.ml362
-rw-r--r--toplevel/fhimsg.mli74
-rw-r--r--toplevel/himsg.ml665
-rw-r--r--toplevel/himsg.mli33
-rw-r--r--toplevel/line_oriented_parser.ml29
-rw-r--r--toplevel/line_oriented_parser.mli13
-rw-r--r--toplevel/metasyntax.ml1428
-rw-r--r--toplevel/metasyntax.mli63
-rw-r--r--toplevel/minicoq.ml149
-rw-r--r--toplevel/mltop.ml4296
-rw-r--r--toplevel/mltop.mli77
-rw-r--r--toplevel/protectedtoplevel.ml173
-rw-r--r--toplevel/protectedtoplevel.mli26
-rw-r--r--toplevel/record.ml236
-rw-r--r--toplevel/record.mli28
-rwxr-xr-xtoplevel/recordobj.ml77
-rwxr-xr-xtoplevel/recordobj.mli12
-rw-r--r--toplevel/searchisos.mli16
-rw-r--r--toplevel/toplevel.ml326
-rw-r--r--toplevel/toplevel.mli46
-rw-r--r--toplevel/usage.ml76
-rw-r--r--toplevel/usage.mli20
-rw-r--r--toplevel/vernac.ml301
-rw-r--r--toplevel/vernac.mli46
-rw-r--r--toplevel/vernacentries.ml1240
-rw-r--r--toplevel/vernacentries.mli54
-rw-r--r--toplevel/vernacexpr.ml293
-rw-r--r--toplevel/vernacinterp.ml76
-rw-r--r--toplevel/vernacinterp.mli24
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