diff options
Diffstat (limited to 'library')
32 files changed, 500 insertions, 1769 deletions
diff --git a/library/declare.ml b/library/declare.ml index c59d190a0e..31c9c24bc3 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -9,7 +9,7 @@ (** This module is about the low-level declaration of logical objects *) open Pp -open Errors +open CErrors open Util open Names open Libnames @@ -149,7 +149,7 @@ let cache_constant ((sp,kn), obj) = obj.cst_was_seff <- false; if Global.exists_objlabel (Label.of_id (basename sp)) then constant_of_kn kn - else Errors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) + else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) end else let () = check_exists sp in let kn', exported = Global.add_constant dir id obj.cst_decl in @@ -353,7 +353,8 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; mind_entry_polymorphic = false; mind_entry_universes = Univ.UContext.empty; - mind_entry_private = None }) + mind_entry_private = None; +}) type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry @@ -398,7 +399,7 @@ let declare_mind mie = let pr_rank i = pr_nth (i+1) let fixpoint_message indexes l = - Flags.if_verbose msg_info (match l with + Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "no recursive definition") | [id] -> pr_id id ++ str " is recursively defined" ++ (match indexes with @@ -413,7 +414,7 @@ let fixpoint_message indexes l = | None -> mt ())) let cofixpoint_message l = - Flags.if_verbose msg_info (match l with + Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "No corecursive definition.") | [id] -> pr_id id ++ str " is corecursively defined" | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ @@ -423,30 +424,47 @@ let recursive_message isfix i l = (if isfix then fixpoint_message i else cofixpoint_message) l let definition_message id = - Flags.if_verbose msg_info (pr_id id ++ str " is defined") + Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is defined") let assumption_message id = (* Changing "assumed" to "declared", "assuming" referring more to the type of the object than to the name of the object (see discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) - Flags.if_verbose msg_info (pr_id id ++ str " is declared") + Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is declared") (** Global universe names, in a different summary *) +type universe_context_decl = polymorphic * Univ.universe_context_set + +let cache_universe_context (p, ctx) = + Global.push_context_set p ctx; + if p then Lib.add_section_context ctx + +let input_universe_context : universe_context_decl -> Libobject.obj = + declare_object + { (default_object "Global universe context state") with + cache_function = (fun (na, pi) -> cache_universe_context pi); + load_function = (fun _ (_, pi) -> cache_universe_context pi); + discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); + classify_function = (fun a -> Keep a) } + +let declare_universe_context poly ctx = + Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) + (* Discharged or not *) type universe_decl = polymorphic * (Id.t * Univ.universe_level) list let cache_universes (p, l) = - let glob = Universes.global_universe_names () in + let glob = Global.global_universe_names () in let glob', ctx = List.fold_left (fun ((idl,lid),ctx) (id, lev) -> - ((Idmap.add id lev idl, Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) + ((Idmap.add id (p, lev) idl, + Univ.LMap.add lev id lid), + Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in - Global.push_context_set p ctx; - if p then Lib.add_section_context ctx; - Universes.set_global_universe_names glob' + cache_universe_context (p, ctx); + Global.set_global_universe_names glob' let input_universes : universe_decl -> Libobject.obj = declare_object @@ -457,6 +475,12 @@ let input_universes : universe_decl -> Libobject.obj = classify_function = (fun a -> Keep a) } let do_universe poly l = + let in_section = Lib.sections_are_opened () in + let () = + if poly && not in_section then + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic universes outside sections") + in let l = List.map (fun (l, id) -> let lev = Universes.new_univ_level (Global.current_dirpath ()) in @@ -467,8 +491,10 @@ let do_universe poly l = type constraint_decl = polymorphic * Univ.constraints let cache_constraints (na, (p, c)) = - Global.add_constraints c; - if p then Lib.add_section_context (Univ.ContextSet.add_constraints c Univ.ContextSet.empty) + let ctx = + Univ.ContextSet.add_constraints c + Univ.ContextSet.empty (* No declared universes here, just constraints *) + in cache_universe_context (p,ctx) let discharge_constraints (_, (p, c as a)) = if p then None else Some a @@ -483,16 +509,40 @@ let input_constraints : constraint_decl -> Libobject.obj = classify_function = (fun a -> Keep a) } let do_constraint poly l = - let u_of_id = - let names, _ = Universes.global_universe_names () in - fun (loc, id) -> - try Idmap.find id names - with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + let open Misctypes in + let u_of_id x = + match x with + | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) + | GSet -> Loc.dummy_loc, (false, Univ.Level.set) + | GType None -> + user_err ~hdr:"Constraint" + (str "Cannot declare constraints on anonymous universes") + | GType (Some (loc, id)) -> + let id = Id.of_string id in + let names, _ = Global.global_universe_names () in + try loc, Idmap.find id names + with Not_found -> + user_err ~loc ~hdr:"Constraint" (str "Undeclared universe " ++ pr_id id) + in + let in_section = Lib.sections_are_opened () in + let () = + if poly && not in_section then + user_err ~hdr:"Constraint" + (str"Cannot declare polymorphic constraints outside sections") + in + let check_poly loc p loc' p' = + if poly then () + else if p || p' then + let loc = if p then loc else loc' in + user_err ~loc ~hdr:"Constraint" + (str "Cannot declare a global constraint on " ++ + str "a polymorphic universe, use " + ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let lu = u_of_id l and ru = u_of_id r in - Univ.Constraint.add (lu, d, ru) acc) + let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in + check_poly ploc p rloc p'; + Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in Lib.add_anonymous_leaf (input_constraints (poly, constraints)) diff --git a/library/declare.mli b/library/declare.mli index 8dd24d2780..f70d594d7e 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -34,14 +34,6 @@ val declare_variable : variable -> variable_declaration -> object_name type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind -(** [declare_constant id cd] declares a global declaration - (constant/parameter) with name [id] in the current section; it returns - the full path of the declaration - - internal specify if the constant has been created by the kernel or by the - user, and in the former case, if its errors should be silent - - *) type internal_flag = | UserAutomaticRequest | InternalTacticRequest @@ -53,6 +45,12 @@ val definition_entry : ?fix_exn:Future.fix_exn -> ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry +(** [declare_constant id cd] declares a global declaration + (constant/parameter) with name [id] in the current section; it returns + the full path of the declaration + + internal specify if the constant has been created by the kernel or by the + user, and in the former case, if its errors should be silent *) val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant @@ -89,7 +87,11 @@ val exists_name : Id.t -> bool -(** Global universe names and constraints *) +(** Global universe contexts, names and constraints *) + +val declare_universe_context : polymorphic -> Univ.universe_context_set -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_constraint : polymorphic -> + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> + unit diff --git a/library/declaremods.ml b/library/declaremods.ml index 701c15e142..3a263b1e12 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Declarations @@ -166,13 +166,13 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - errorlabstrm "consistency_checks" + user_err ~hdr:"consistency_checks" (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = @@ -642,7 +642,11 @@ let declare_module interp_modast id args res mexpr_o fs = let env = Global.env () in let mty_entry_o, subs, inl_res = match res with | Enforce (mty,ann) -> - Some (fst (interp_modast env ModType mty)), [], inl2intopt ann + let inl = inl2intopt ann in + let mte, _ = interp_modast env ModType mty in + (* We check immediately that mte is well-formed *) + let _ = Mod_typing.translate_mse env None inl mte in + Some mte, [], inl | Check mtys -> None, build_subtypes interp_modast env mp arg_entries_r mtys, default_inline () @@ -818,7 +822,7 @@ let protect_summaries f = try f fs with reraise -> (* Something wrong: undo the whole process *) - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in let () = Summary.unfreeze_summaries fs in iraise reraise @@ -893,7 +897,13 @@ let start_library dir = Lib.start_compilation dir mp; Lib.add_frozen_state () +let end_library_hook = ref ignore +let append_end_library_hook f = + let old_f = !end_library_hook in + end_library_hook := fun () -> old_f(); f () + let end_library ?except dir = + !end_library_hook(); let oname = Lib.end_compilation_checks dir in let mp,cenv,ast = Global.export ?except dir in let prefix, lib_stack = Lib.end_compilation oname in diff --git a/library/declaremods.mli b/library/declaremods.mli index 2b440c087a..3917fe8d64 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -90,6 +90,9 @@ val end_library : ?except:Future.UUIDSet.t -> library_name -> Safe_typing.compiled_library * library_objects * Safe_typing.native_library +(** append a function to be executed at end_library *) +val append_end_library_hook : (unit -> unit) -> unit + (** [really_import_module mp] opens the module [mp] (in a Caml sense). It modifies Nametab and performs the [open_object] function for every object of the module. Raises [Not_found] when [mp] is unknown diff --git a/library/decls.ml b/library/decls.ml index 6e21880f1f..2952c258a5 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -14,6 +14,8 @@ open Names open Decl_kinds open Libnames +module NamedDecl = Context.Named.Declaration + (** Datas associated to section variables and local definitions *) type variable_data = @@ -46,20 +48,18 @@ let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) -open Context.Named.Declaration - let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right (fun d signv -> - let id = get_id d in - let d = if variable_opacity id then LocalAssum (id, get_type d) else d in + let id = NamedDecl.get_id d in + let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = Context.Named.fold_outside (fun d sec_ids -> - let id = get_id d in + let id = NamedDecl.get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) diff --git a/library/global.ml b/library/global.ml index 2398e92b03..5fa710b360 100644 --- a/library/global.ml +++ b/library/global.ml @@ -8,6 +8,7 @@ open Names open Environ +open Decl_kinds (** We introduce here the global environment of the system, and we declare it as a synchronized table. *) @@ -42,7 +43,7 @@ let () = let assert_not_parsing () = if !Flags.we_are_parsing then - Errors.anomaly ( + CErrors.anomaly ( Pp.strbrk"The global environment cannot be accessed during parsing") let safe_env () = assert_not_parsing(); !global_env @@ -84,6 +85,7 @@ let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let push_context b c = globalize0 (Safe_typing.push_context b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) +let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) @@ -228,6 +230,17 @@ let universes_of_global env r = let universes_of_global gr = universes_of_global (env ()) gr +(** Global universe names *) +type universe_names = + (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + +let global_universes = + Summary.ref ~name:"Global universe names" + ((Idmap.empty, Univ.LMap.empty) : universe_names) + +let global_universe_names () = !global_universes +let set_global_universe_names s = global_universes := s + let is_polymorphic r = let env = env() in match r with @@ -244,6 +257,14 @@ let is_template_polymorphic r = | IndRef ind -> Environ.template_polymorphic_ind ind env | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env +let is_type_in_type r = + let env = env() in + match r with + | VarRef id -> false + | ConstRef c -> Environ.type_in_type_constant c env + | IndRef ind -> Environ.type_in_type_ind ind env + | ConstructRef cstr -> Environ.type_in_type_ind (inductive_of_constructor cstr) env + let current_dirpath () = Safe_typing.current_dirpath (safe_env ()) diff --git a/library/global.mli b/library/global.mli index bf653307c4..a4a38ce846 100644 --- a/library/global.mli +++ b/library/global.mli @@ -27,6 +27,7 @@ val named_context : unit -> Context.Named.t (** Changing the (im)predicativity of the system *) val set_engagement : Declarations.engagement -> unit +val set_typing_flags : Declarations.typing_flags -> unit (** Variables, Local definitions, constants, inductive types *) @@ -95,6 +96,13 @@ val constraints_of_constant_body : val universes_of_constant_body : Declarations.constant_body -> Univ.universe_context +(** Global universe name <-> level mapping *) +type universe_names = + (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t + +val global_universe_names : unit -> universe_names +val set_global_universe_names : universe_names -> unit + (** {6 Compiled libraries } *) val start_library : DirPath.t -> module_path @@ -116,6 +124,7 @@ val is_joined_environment : unit -> bool val is_polymorphic : Globnames.global_reference -> bool val is_template_polymorphic : Globnames.global_reference -> bool +val is_type_in_type : Globnames.global_reference -> bool val type_of_global_in_context : Environ.env -> Globnames.global_reference -> Constr.types Univ.in_universe_context diff --git a/library/globnames.ml b/library/globnames.ml index bec463ecf2..a78f5f13a9 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Names open Term open Mod_subst diff --git a/library/goptions.ml b/library/goptions.ml index 5f6512e117..1c08b9539f 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -9,7 +9,7 @@ (* This module manages customization parameters at the vernacular level *) open Pp -open Errors +open CErrors open Util open Libobject open Libnames @@ -36,7 +36,7 @@ type option_state = { let nickname table = String.concat " " table let error_undeclared_key key = - errorlabstrm "Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") (****************************************************************************) (* 1- Tables *) @@ -108,7 +108,8 @@ module MakeTable = (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = - pp (str table_name ++ + Feedback.msg_notice + (str table_name ++ (hov 0 (if MySet.is_empty table then str " None" ++ fnl () else MySet.fold @@ -122,7 +123,7 @@ module MakeTable = method mem x = let y = A.encode x in let answer = MySet.mem y !t in - msg_info (A.member_message y answer) + Feedback.msg_info (A.member_message y answer) method print = print_table A.title A.printer !t end @@ -207,6 +208,10 @@ type 'a option_sig = { optread : unit -> 'a; optwrite : 'a -> unit } +type option_locality = OptLocal | OptDefault | OptGlobal + +type option_mod = OptSet | OptAppend + module OptionOrd = struct type t = option_name @@ -232,52 +237,57 @@ with Not_found -> open Libobject open Lib -let declare_option cast uncast +let warn_deprecated_option = + CWarnings.create ~name:"deprecated-option" ~category:"deprecated" + (fun key -> str "Option" ++ spc () ++ str (nickname key) ++ + strbrk " is deprecated") + +let get_locality = function + | Some true -> OptLocal + | Some false -> OptGlobal + | None -> OptDefault + +let declare_option cast uncast append ?(preprocess = fun x -> x) { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in - (* spiwack: I use two spaces in the nicknames of "local" and "global" objects. - That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are - lists of strings *without* spaces. *) - let (write,lwrite,gwrite) = if sync then - let ldecl_obj = (* "Local": doesn't survive section or modules. *) - declare_object {(default_object ("L "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose)} - in - let decl_obj = (* default locality: survives sections but not modules. *) - declare_object {(default_object (nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose); - discharge_function = (fun (_,v) -> Some v)} - in - let gdecl_obj = (* "Global": survives section and modules. *) - declare_object {(default_object ("G "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun v -> Substitute v); - subst_function = (fun (_,v) -> v); - discharge_function = (fun (_,v) -> Some v); - load_function = (fun _ (_,v) -> write v)} - in - let _ = Summary.declare_summary (nickname key) - { Summary.freeze_function = (fun _ -> read ()); - Summary.unfreeze_function = write; - Summary.init_function = (fun () -> write default) } - in - begin fun v -> add_anonymous_leaf (decl_obj v) end , - begin fun v -> add_anonymous_leaf (ldecl_obj v) end , - begin fun v -> add_anonymous_leaf (gdecl_obj v) end - else write,write,write - in - let warn () = - if depr then - msg_warning (str "Option " ++ str (nickname key) ++ str " is deprecated") + let change = + if sync then + let _ = Summary.declare_summary (nickname key) + { Summary.freeze_function = (fun _ -> read ()); + Summary.unfreeze_function = write; + Summary.init_function = (fun () -> write default) } in + let cache_options (_,(l,m,v)) = + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v) in + let load_options i o = cache_options o in + let subst_options (subst,obj) = obj in + let discharge_options (_,(l,_,_ as o)) = + match l with OptLocal -> None | _ -> Some o in + let classify_options (l,_,_ as o) = + match l with OptGlobal -> Substitute o | _ -> Dispose in + let options : option_locality * option_mod * _ -> obj = + declare_object + { (default_object (nickname key)) with + load_function = load_options; + cache_function = cache_options; + subst_function = subst_options; + discharge_function = discharge_options; + classify_function = classify_options } in + (fun l m v -> let v = preprocess v in Lib.add_anonymous_leaf (options (l, m, v))) + else + (fun _ m v -> + let v = preprocess v in + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v)) in + let warn () = if depr then warn_deprecated_option key in let cread () = cast (read ()) in - let cwrite v = warn (); write (uncast v) in - let clwrite v = warn (); lwrite (uncast v) in - let cgwrite v = warn (); gwrite (uncast v) in - value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab; + let cwrite l v = warn (); change l OptSet (uncast v) in + let cappend l v = warn (); change l OptAppend (uncast v) in + value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab; write type 'a write_function = 'a -> unit @@ -286,36 +296,38 @@ let declare_int_option = declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_bool_option = declare_option (fun v -> BoolValue v) (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun x y -> x^","^y) let declare_stringopt_option = declare_option (fun v -> StringOptValue v) (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) (* Setting values of options *) +let warn_unknown_option = + CWarnings.create ~name:"unknown-option" ~category:"option" + (fun key -> strbrk "There is no option " ++ + str (nickname key) ++ str ".") + let set_option_value locality check_and_cast key v = - let (name, depr, (_,read,write,lwrite,gwrite)) = - try get_option key - with Not_found -> - errorlabstrm "Goptions.set_option_value" - (str "There is no option " ++ str (nickname key) ++ str ".") - in - let write = match locality with - | None -> write - | Some true -> lwrite - | Some false -> gwrite - in - write (check_and_cast v (read ())) + let opt = try Some (get_option key) with Not_found -> None in + match opt with + | None -> warn_unknown_option key + | Some (name, depr, (_,read,write,append)) -> + write (get_locality locality) (check_and_cast v (read ())) let bad_type_error () = error "Bad type of value for this option." @@ -345,13 +357,18 @@ let check_unset_value v = function let set_int_option_value_gen locality = set_option_value locality check_int_value let set_bool_option_value_gen locality key v = - try set_option_value locality check_bool_value key v - with UserError (_,s) -> msg_warning s + set_option_value locality check_bool_value key v let set_string_option_value_gen locality = set_option_value locality check_string_value let unset_option_value_gen locality key = - try set_option_value locality check_unset_value key () - with UserError (_,s) -> msg_warning s + set_option_value locality check_unset_value key () + +let set_string_option_append_value_gen locality key v = + let opt = try Some (get_option key) with Not_found -> None in + match opt with + | None -> warn_unknown_option key + | Some (name, depr, (_,read,write,append)) -> + append (get_locality locality) (check_string_value v (read ())) let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None @@ -361,27 +378,27 @@ let set_string_option_value = set_string_option_value_gen None let msg_option_value (name,v) = match v with - | BoolValue true -> str "true" - | BoolValue false -> str "false" + | BoolValue true -> str "on" + | BoolValue false -> str "off" | IntValue (Some n) -> int n | IntValue None -> str "undefined" - | StringValue s -> str s + | StringValue s -> quote (str s) | StringOptValue None -> str"undefined" - | StringOptValue (Some s) -> str s + | StringOptValue (Some s) -> quote (str s) (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = - let (name, depr, (_,read,_,_,_)) = get_option key in + let (name, depr, (_,read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> - msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) + Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> - msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) + Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in - let fold key (name, depr, (sync,read,_,_,_)) accu = + let fold key (name, depr, (sync,read,_,_)) accu = let state = { opt_sync = sync; opt_name = name; @@ -400,13 +417,13 @@ let print_tables () = in str "Synchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p ++ print_option key name (read ()) depr else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p else p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ diff --git a/library/goptions.mli b/library/goptions.mli index 26864503b1..3b3651f393 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -122,13 +122,19 @@ type 'a option_sig = { (** When an option is declared synchronous ([optsync] is [true]), the output is a synchronous write function. Otherwise it is [optwrite] *) +(** The [preprocess] function is triggered before setting the option. It can be + used to emit a warning on certain values, and clean-up the final value. *) type 'a write_function = 'a -> unit -val declare_int_option : int option option_sig -> int option write_function -val declare_bool_option : bool option_sig -> bool write_function -val declare_string_option: string option_sig -> string write_function -val declare_stringopt_option: string option option_sig -> string option write_function +val declare_int_option : ?preprocess:(int option -> int option) -> + int option option_sig -> int option write_function +val declare_bool_option : ?preprocess:(bool -> bool) -> + bool option_sig -> bool write_function +val declare_string_option: ?preprocess:(string -> string) -> + string option_sig -> string write_function +val declare_stringopt_option: ?preprocess:(string option -> string option) -> + string option option_sig -> string option write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -154,6 +160,7 @@ val get_ref_table : val set_int_option_value_gen : bool option -> option_name -> int option -> unit val set_bool_option_value_gen : bool option -> option_name -> bool -> unit val set_string_option_value_gen : bool option -> option_name -> string -> unit +val set_string_option_append_value_gen : bool option -> option_name -> string -> unit val unset_option_value_gen : bool option -> option_name -> unit val set_int_option_value : option_name -> int option -> unit diff --git a/library/heads.ml b/library/heads.ml index 4c9b789769..02465f22fc 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -70,7 +70,7 @@ let kind_of_head env t = | Const (cst,_) -> (try on_subterm k l b (constant_head cst) with Not_found -> - Errors.anomaly + CErrors.anomaly Pp.(str "constant not found in kind_of_head: " ++ str (Names.Constant.to_string cst))) | Construct _ | CoFix _ -> diff --git a/library/impargs.ml b/library/impargs.ml index 4e344a9543..836568b890 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Names open Globnames @@ -22,6 +22,9 @@ open Constrexpr open Termops open Namegen open Decl_kinds +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration (*s Flags governing the computation of implicit arguments *) @@ -68,15 +71,14 @@ let is_reversible_pattern_implicit_args () = !implicit_args.reversible_pattern let is_contextual_implicit_args () = !implicit_args.contextual let is_maximal_implicit_args () = !implicit_args.maximal -let with_implicits flags f x = +let with_implicit_protection f x = let oflags = !implicit_args in try - implicit_args := flags; let rslt = f x in implicit_args := oflags; rslt with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in let () = implicit_args := oflags in iraise reraise @@ -165,7 +167,6 @@ let update pos rig (na,st) = (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = - let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true @@ -174,7 +175,7 @@ let is_flexible_reference env bound depth f = let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> - Environ.lookup_named id env |> is_local_def + env |> Environ.lookup_named id |> is_local_def | Ind _ | Construct _ -> false | _ -> true @@ -188,7 +189,7 @@ let is_reversible_pattern bound depth f l = (* Precondition: rels in env are for inductive types only *) let add_free_rels_until strict strongly_strict revpat bound env m pos acc = let rec frec rig (env,depth as ed) c = - let hd = if strict then whd_betadeltaiota env c else c in + let hd = if strict then whd_all env c else c in let c = if strongly_strict then hd else c in match kind_of_term hd with | Rel n when (n < bound+depth) && (n >= depth) -> @@ -236,7 +237,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in let open Context.Rel.Declaration in let rec aux env avoid n names t = - let t = whd_betadeltaiota env t in + let t = whd_all env t in match kind_of_term t with | Prod (na,a,b) -> let na',avoid' = find_displayed_name_in all avoid na (names,b) in @@ -250,7 +251,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = add_free_rels_until strict strongly_strict revpat n env t Conclusion v else v in - match kind_of_term (whd_betadeltaiota env t) with + match kind_of_term (whd_all env t) with | Prod (na,a,b) -> let na',avoid = find_displayed_name_in all [] na ([],b) in let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in @@ -339,14 +340,14 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - errorlabstrm "" + user_err (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then - errorlabstrm "" + user_err (str "Bad implicit argument number: " ++ int i ++ str ".") else - errorlabstrm "" + user_err (str "Cannot set implicit argument number " ++ int i ++ str ": it has no name.")) l @@ -450,8 +451,7 @@ let compute_all_mib_implicits flags manual kn = let compute_var_implicits flags manual id = let env = Global.env () in - let open Context.Named.Declaration in - compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) + compute_semi_auto_implicits env flags manual (NamedDecl.get_type (lookup_named id env)) (* Implicits of a global reference. *) @@ -492,13 +492,15 @@ let implicits_of_global ref = let l = Refmap.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in - let rename imp name = match imp, name with - | Some (_, x,y), Name id -> Some (id, x,y) - | _ -> imp in - List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l + let rec rename implicits names = match implicits, names with + | [], _ -> [] + | _, [] -> implicits + | Some (_, x,y) :: implicits, Name id :: names -> + Some (id, x,y) :: rename implicits names + | imp :: implicits, _ :: names -> imp :: rename implicits names + in + List.map (fun (t, il) -> t, rename il rename_l) l with Not_found -> l - | Invalid_argument _ -> - anomaly (Pp.str "renamings list and implicits list have different lenghts") with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = @@ -516,21 +518,11 @@ let subst_implicits (subst,(req,l)) = (ImplLocal,List.smartmap (subst_implicits_decl subst) l) let impls_of_context ctx = - let map (id, impl, _, _) = match impl with - | Implicit -> Some (id, Manual, (true, true)) + let map (decl, impl) = match impl with + | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) | _ -> None in - let is_set (_, _, b, _) = match b with - | None -> true - | Some _ -> false - in - List.rev_map map (List.filter is_set ctx) - -let section_segment_of_reference = function - | ConstRef con -> pi1 (section_segment_of_constant con) - | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - pi1 (section_segment_of_mutual_inductive kn) - | _ -> [] + List.rev_map map (List.filter (fst %> is_local_assum) ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -545,7 +537,7 @@ let discharge_implicits (_,(req,l)) = | ImplLocal -> None | ImplInteractive (ref,flags,exp) -> (try - let vars = section_segment_of_reference ref in + let vars = variable_section_segment_of_reference ref in let ref' = if isVarRef ref then ref else pop_global_reference ref in let extra_impls = impls_of_context vars in let l' = [ref', List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in @@ -563,7 +555,7 @@ let discharge_implicits (_,(req,l)) = | ImplMutualInductive (kn,flags) -> (try let l' = List.map (fun (gr, l) -> - let vars = section_segment_of_reference gr in + let vars = variable_section_segment_of_reference gr in let extra_impls = impls_of_context vars in ((if isVarRef gr then gr else pop_global_reference gr), List.map (add_section_impls vars extra_impls) l)) l @@ -664,14 +656,14 @@ let check_inclusion l = let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then - error "Sequences of implicit arguments must be of different lengths"; + error "Sequences of implicit arguments must be of different lengths."; aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) let check_rigidity isrigid = if not isrigid then - errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") + user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = let pb = Environ.lookup_projection p env in diff --git a/library/impargs.mli b/library/impargs.mli index 34e529ca2c..3919a519c9 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -29,8 +29,7 @@ val is_reversible_pattern_implicit_args : unit -> bool val is_contextual_implicit_args : unit -> bool val is_maximal_implicit_args : unit -> bool -type implicits_flags -val with_implicits : implicits_flags -> ('a -> 'b) -> 'a -> 'b +val with_implicit_protection : ('a -> 'b) -> 'a -> 'b (** {6 ... } *) (** An [implicits_list] is a list of positions telling which arguments @@ -136,14 +135,5 @@ val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list -type implicit_interactive_request - -type implicit_discharge_request = - | ImplLocal - | ImplConstant of constant * implicits_flags - | ImplMutualInductive of mutual_inductive * implicits_flags - | ImplInteractive of global_reference * implicits_flags * - implicit_interactive_request - val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool (** Equality on [explicitation]. *) diff --git a/library/kindops.ml b/library/kindops.ml index c634193da8..21b1bec33c 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -25,7 +25,7 @@ let string_of_theorem_kind = function let string_of_definition_kind def = let (locality, poly, kind) = def in - let error () = Errors.anomaly (Pp.str "Internal definition kind") in + let error () = CErrors.anomaly (Pp.str "Internal definition kind") in match kind with | Definition -> begin match locality with @@ -64,4 +64,4 @@ let string_of_definition_kind def = | Global -> "Global Instance" end | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> - Errors.anomaly (Pp.str "Internal definition kind") + CErrors.anomaly (Pp.str "Internal definition kind") diff --git a/library/lib.ml b/library/lib.ml index f8bb6bac59..4fd29a94de 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -7,12 +7,15 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Libnames open Globnames open Nameops open Libobject +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) @@ -75,7 +78,7 @@ let classify_segment seg = | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> - errorlabstrm "Lib.classify_segment" + user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in @@ -231,11 +234,16 @@ let add_leaves id objs = List.iter add_obj objs; oname -let add_anonymous_leaf obj = +let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in let oname = make_oname id in - cache_object (oname,obj); - add_entry oname (Leaf obj) + if cache_first then begin + cache_object (oname,obj); + add_entry oname (Leaf obj) + end else begin + add_entry oname (Leaf obj); + cache_object (oname,obj) + end let add_frozen_state () = add_anonymous_entry @@ -267,7 +275,7 @@ let start_mod is_type export id mp fs = else Nametab.exists_module dir in if exists then - errorlabstrm "open_module" (pr_id id ++ str " already exists"); + user_err ~hdr:"open_module" (pr_id id ++ str " already exists"); add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs)); path_prefix := prefix; prefix @@ -277,7 +285,7 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in - errorlabstrm "" + user_err (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = @@ -322,7 +330,7 @@ let end_compilation_checks dir = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> - errorlabstrm "Lib.end_compilation_checks" + user_err ~hdr:"Lib.end_compilation_checks" (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () @@ -374,7 +382,7 @@ let find_opening_node id = let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then - errorlabstrm "Lib.find_opening_node" + user_err ~hdr:"Lib.find_opening_node" (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." @@ -388,7 +396,7 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t @@ -417,7 +425,7 @@ let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - check_same_poly poly vars; + List.iter (fun tab -> check_same_poly poly (pi1 tab)) !sectab; sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl let add_section_context ctx = @@ -428,12 +436,10 @@ let add_section_context ctx = sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = - let open Context.Named.Declaration in let rec aux = function - | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) -> - let (id',b,t) = to_tuple decl in + | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> let l, r = aux (idl,hyps) in - (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r + (decl,impl) :: l, if poly then Univ.ContextSet.union r ctx else r | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r @@ -443,17 +449,11 @@ let extract_hyps (secs,ohyps) = | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) -let instance_from_variable_context sign = - let rec inst_rec = function - | (id,b,None,_) :: sign -> id :: inst_rec sign - | _ :: sign -> inst_rec sign - | [] -> [] in - Array.of_list (inst_rec sign) - -let named_of_variable_context ctx = let open Context.Named.Declaration in - List.map (function id,_,None,t -> LocalAssum (id,t) - | id,_,Some b,t -> LocalDef (id,b,t)) - ctx +let instance_from_variable_context = + List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let named_of_variable_context = + List.map fst let add_section_replacement f g poly hyps = match !sectab with @@ -483,6 +483,12 @@ let section_segment_of_constant con = let section_segment_of_mutual_inductive kn = Names.Mindmap.find kn (snd (pi3 (List.hd !sectab))) +let variable_section_segment_of_reference = function + | ConstRef con -> pi1 (section_segment_of_constant con) + | IndRef (kn,_) | ConstructRef ((kn,_),_) -> + pi1 (section_segment_of_mutual_inductive kn) + | _ -> [] + let section_instance = function | VarRef id -> let eq = function @@ -500,13 +506,6 @@ let section_instance = function let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false -let full_replacement_context () = List.map pi2 !sectab -let full_section_segment_of_constant con = - List.map (fun (vars,_,(x,_)) -> fun hyps -> - named_of_variable_context - (try pi1 (Names.Cmap.find con x) - with Not_found -> fst (extract_hyps (vars, hyps)))) !sectab - (*************) (* Sections. *) @@ -519,7 +518,7 @@ let open_section id = let dir = add_dirpath_suffix olddir id in let prefix = dir, (mp, add_dirpath_suffix oldsec id) in if Nametab.exists_section dir then - errorlabstrm "open_section" (pr_id id ++ str " already exists."); + user_err ~hdr:"open_section" (pr_id id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) @@ -607,15 +606,6 @@ let rec dp_of_mp = function |Names.MPbound _ -> library_dp () |Names.MPdot (mp,_) -> dp_of_mp mp -let rec split_mp = function - |Names.MPfile dp -> dp, Names.DirPath.empty - |Names.MPdot (prfx, lbl) -> - let mprec, dprec = split_mp prfx in - mprec, Libnames.add_dirpath_suffix dprec (Names.Label.to_id lbl) - |Names.MPbound mbid -> - let (_,id,dp) = Names.MBId.repr mbid in - library_dp (), Names.DirPath.make [id] - let rec split_modpath = function |Names.MPfile dp -> dp, [] |Names.MPbound mbid -> library_dp (), [Names.MBId.to_id mbid] @@ -627,20 +617,6 @@ let library_part = function |VarRef id -> library_dp () |ref -> dp_of_mp (mp_of_global ref) -let remove_section_part ref = - let sp = Nametab.path_of_global ref in - let dir,_ = repr_path sp in - match ref with - | VarRef id -> - anomaly (Pp.str "remove_section_part not supported on local variables") - | _ -> - if is_dirpath_prefix_of dir (cwd ()) then - (* Not yet (fully) discharged *) - pop_dirpath_n (sections_depth ()) (cwd ()) - else - (* Theorem/Lemma outside its outer section of definition *) - dir - (************************) (* Discharging names *) diff --git a/library/lib.mli b/library/lib.mli index e2e71ac90f..9f9d8c7e5f 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -54,7 +54,7 @@ val segment_of_objects : current list of operations (most recent ones coming first). *) val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name -val add_anonymous_leaf : Libobject.obj -> unit +val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] @@ -138,10 +138,8 @@ val library_dp : unit -> Names.DirPath.t (** Extract the library part of a name even if in a section *) val dp_of_mp : Names.module_path -> Names.DirPath.t -val split_mp : Names.module_path -> Names.DirPath.t * Names.DirPath.t val split_modpath : Names.module_path -> Names.DirPath.t * Names.Id.t list val library_part : Globnames.global_reference -> Names.DirPath.t -val remove_section_part : Globnames.global_reference -> Names.DirPath.t (** {6 Sections } *) @@ -162,8 +160,7 @@ val xml_open_section : (Names.Id.t -> unit) Hook.t val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) -type variable_info = Names.Id.t * Decl_kinds.binding_kind * - Term.constr option * Term.types +type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t @@ -172,7 +169,8 @@ val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.constant -> abstr_info val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info - +val variable_section_segment_of_reference : Globnames.global_reference -> variable_context + val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array val is_in_section : Globnames.global_reference -> bool @@ -190,10 +188,3 @@ val discharge_kn : Names.mutual_inductive -> Names.mutual_inductive val discharge_con : Names.constant -> Names.constant val discharge_global : Globnames.global_reference -> Globnames.global_reference val discharge_inductive : Names.inductive -> Names.inductive - -(* discharging a constant in one go *) -val full_replacement_context : unit -> Opaqueproof.work_list list -val full_section_segment_of_constant : - Names.constant -> (Context.Named.t -> Context.Named.t) list - - diff --git a/library/libnames.ml b/library/libnames.ml index 99ff2f2fb4..dd74e192ff 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names diff --git a/library/libobject.ml b/library/libobject.ml index bbbb134df2..caa03c85be 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -12,18 +12,6 @@ open Util module Dyn = Dyn.Make(struct end) -(* The relax flag is used to make it possible to load files while ignoring - failures to incorporate some objects. This can be useful when one - wants to work with restricted Coq programs that have only parts of - the full capabilities, but may still be able to work correctly for - limited purposes. One example is for the graphical interface, that uses - such a limited Coq process to do only parsing. It loads .vo files, but - is only interested in loading the grammar rule definitions. *) - -let relax_flag = ref false;; - -let relax b = relax_flag := b;; - type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a @@ -43,7 +31,7 @@ let default_object s = { load_function = (fun _ _ -> ()); open_function = (fun _ _ -> ()); subst_function = (fun _ -> - Errors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); + CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun obj -> Keep obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x)} @@ -78,20 +66,9 @@ let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) -let make_dyn (type a) (tag : a Dyn.tag) = - let infun x = Dyn.Dyn (tag, x) in - let outfun : (Dyn.t -> a) = fun dyn -> - let Dyn.Dyn (t, x) = dyn in - match Dyn.eq t tag with - | None -> assert false - | Some Refl -> x - in - (infun, outfun) - let declare_object_full odecl = let na = odecl.object_name in - let tag = Dyn.create na in - let (infun, outfun) = make_dyn tag in + let (infun, outfun) = Dyn.Easy.make_dyn na in let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj) and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj) and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj) @@ -120,36 +97,21 @@ let declare_object_full odecl = let declare_object odecl = try fst (declare_object_full odecl) - with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) + with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) let declare_object_full odecl = try declare_object_full odecl - with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) - -let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t) + with e -> CErrors.fatal_error (CErrors.print e) (CErrors.is_anomaly e) (* this function describes how the cache, load, open, and export functions - are triggered. In relaxed mode, this function just return a meaningless - value instead of raising an exception when they fail. *) + are triggered. *) let apply_dyn_fun deflt f lobj = let tag = object_tag lobj in - try - let dodecl = - try - Hashtbl.find cache_tab tag - with Not_found -> - failwith "local to_apply_dyn_fun" in - f dodecl - with - Failure "local to_apply_dyn_fun" -> - if not (!relax_flag || Hashtbl.mem missing_tab tag) then - begin - Pp.msg_warning - (Pp.str ("Cannot find library functions for an object with tag " - ^ tag ^ " (a plugin may be missing)")); - Hashtbl.add missing_tab tag () - end; - deflt + let dodecl = + try Hashtbl.find cache_tab tag + with Not_found -> assert false + in + f dodecl let cache_object ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj diff --git a/library/libobject.mli b/library/libobject.mli index dbe0de8f8a..51b9af059f 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -107,7 +107,6 @@ val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj -val relax : bool -> unit (** {6 Debug} *) diff --git a/library/library.ml b/library/library.ml index 8e2402ddae..3086e3d182 100644 --- a/library/library.ml +++ b/library/library.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names @@ -35,7 +35,7 @@ module Delayed : sig type 'a delayed -val in_delayed : string -> in_channel -> 'a delayed +val in_delayed : string -> in_channel -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = @@ -50,7 +50,7 @@ type 'a delayed = { let in_delayed f ch = let pos = pos_in ch in let _, digest = System.skip_in_segment f ch in - { del_file = f; del_digest = digest; del_off = pos; } + ({ del_file = f; del_digest = digest; del_off = pos; }, digest) (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) @@ -64,7 +64,7 @@ let fetch_delayed del = let () = close_in ch in if not (String.equal digest digest') then raise (Faulty f); obj - with e when Errors.noncritical e -> raise (Faulty f) + with e when CErrors.noncritical e -> raise (Faulty f) end @@ -131,7 +131,7 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - errorlabstrm "Library.find_library" + user_err ~hdr:"Library.find_library" (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = @@ -271,6 +271,12 @@ exception LibUnmappedDir exception LibNotFound type library_location = LibLoaded | LibInPath +let warn_several_object_files = + CWarnings.create ~name:"several-object-files" ~category:"require" + (fun (vi, vo) -> str"Loading" ++ spc () ++ str vi ++ + strbrk " instead of " ++ str vo ++ + strbrk " because it is more recent") + let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in @@ -287,9 +293,8 @@ let locate_absolute_library dir = | [] -> raise LibNotFound | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ - str vo ++ str " because it is more recent"); - vi + warn_several_object_files (vi, vo); + vi | [vo;vi] -> vo | _ -> assert false @@ -311,8 +316,7 @@ let locate_qualified_library ?root ?(warn = true) qid = | [lpath, file] -> lpath, file | [lpath_vo, vo; lpath_vi, vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ - str vo ++ str " because it is more recent"); + warn_several_object_files (vi, vo); lpath_vi, vi | [lpath_vo, vo; _ ] -> lpath_vo, vo | _ -> assert false @@ -325,12 +329,12 @@ let locate_qualified_library ?root ?(warn = true) qid = let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) let error_lib_not_found qid = - errorlabstrm "load_absolute_library_from" + user_err ~hdr:"load_absolute_library_from" (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") let try_locate_absolute_library dir = @@ -370,11 +374,11 @@ let access_table what tables dp i = | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in - Flags.if_verbose msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); + Flags.if_verbose Feedback.msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); let t = try fetch_delayed f with Faulty f -> - errorlabstrm "Library.access_table" + user_err ~hdr:"Library.access_table" (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") @@ -427,53 +431,55 @@ let mk_summary m = { let intern_from_file f = let ch = raw_intern_library f in let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in - let (lmd : seg_lib delayed) = in_delayed f ch in + let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in let _ = System.skip_in_segment f ch in - let (del_opaque : seg_proofs delayed) = in_delayed f ch in + let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in match univs with - | None -> mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty + | None -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty | Some (utab,uall,true) -> add_univ_table lsd.md_name (Fetched utab); - mk_library lsd lmd (Dvivo (digest_lsd,digest_u)) uall + mk_library lsd lmd (Dvivo (digest_lmd,digest_u)) uall | Some (utab,_,false) -> add_univ_table lsd.md_name (Fetched utab); - mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty + mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = - Pp.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> + Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then - errorlabstrm "load_physical_library" + user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); - Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f)); - m.library_digests, intern_library_deps (needed, contents) dir m (Some f) + Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); + m.library_digests, intern_library_deps (needed, contents) dir m f and intern_library_deps libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library dir from) libs m.library_deps in (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = - let digest, libs = intern_library libs (dir, None) from in + let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ str ".vo makes inconsistent assumptions over library " ++ pr_dirpath dir); + user_err (str "Compiled library " ++ pr_dirpath caller ++ + str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ + over library " ++ pr_dirpath dir); libs let rec_intern_library libs (dir, f) = @@ -547,12 +553,20 @@ let in_require : require_obj -> obj = let (f_xml_require, xml_require) = Hook.make ~default:ignore () +let warn_require_in_module = + CWarnings.create ~name:"require-in-module" ~category:"deprecated" + (fun () -> strbrk "Require inside a module is" ++ + strbrk " deprecated and strongly discouraged. " ++ + strbrk "You can Require a module at toplevel " ++ + strbrk "and optionally Import it inside another one.") + let require_library_from_dirpath modrefl export = let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin + warn_require_in_module (); add_anonymous_leaf (in_require (needed,modrefl,None)); Option.iter (fun exp -> add_anonymous_leaf (in_import_library (modrefl,exp))) @@ -568,8 +582,8 @@ let require_library_from_dirpath modrefl export = let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> - user_err_loc - (loc,"import_library", pr_qualid qid ++ str " is not a module") + user_err ~loc ~hdr:"import_library" + (pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -593,8 +607,8 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err_loc (loc,"import_library", - pr_qualid dir ++ str " is not a module")) + user_err ~loc ~hdr:"import_library" + (pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -605,7 +619,7 @@ let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then - errorlabstrm "" + user_err (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") @@ -618,7 +632,7 @@ let check_module_name s = (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ strbrk " is not allowed in module names\n" in - let err c = errorlabstrm "" (msg c) in + let err c = user_err (msg c) in match String.get s 0 with | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do @@ -628,17 +642,14 @@ let check_module_name s = done | c -> err c -let start_library f = - let () = if not (Sys.file_exists f) then - errorlabstrm "" (hov 0 (str "Can't find file" ++ spc () ++ str f)) - in +let start_library fo = let ldir0 = try - let lp = Loadpath.find_load_path (Filename.dirname f) in + let lp = Loadpath.find_load_path (Filename.dirname fo) in Loadpath.logical lp with Not_found -> Nameops.default_root_prefix in - let file = Filename.chop_extension (Filename.basename f) in + let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in check_module_name file; check_coq_overwriting ldir0 id; @@ -657,10 +668,10 @@ let load_library_todo f = let tasks, _, _ = System.marshal_in_segment f ch in let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; - if tasks = None then errorlabstrm "restart" (str"not a .vio file"); - if s2 = None then errorlabstrm "restart" (str"not a .vio file"); - if s3 = None then errorlabstrm "restart" (str"not a .vio file"); - if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); + if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); + if pi3 (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) @@ -676,7 +687,7 @@ let current_deps () = let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = - errorlabstrm "" + user_err (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -693,12 +704,13 @@ let error_recursively_dependent_library dir = writing the content and computing the checksum... *) let save_library_to ?todo dir f otab = - let f, except = match todo with + let except = match todo with | None -> assert(!Flags.compilation_mode = Flags.BuildVo); - f ^ "o", Future.UUIDSet.empty + assert(Filename.check_suffix f ".vo"); + Future.UUIDSet.empty | Some (l,_) -> - f ^ "io", + assert(Filename.check_suffix f ".vio"); List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~except dir in @@ -722,7 +734,7 @@ let save_library_to ?todo dir f otab = except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> - if not(is_done_or_todo i x) then Errors.errorlabstrm "library" + if not(is_done_or_todo i x) then CErrors.user_err ~hdr:"library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; let sd = { @@ -754,8 +766,8 @@ let save_library_to ?todo dir f otab = if not (Nativelib.compile_library dir ast fn) then error "Could not compile the library to native code." with reraise -> - let reraise = Errors.push reraise in - let () = msg_warning (str "Removed file " ++ str f') in + let reraise = CErrors.push reraise in + let () = Feedback.msg_warning (str "Removed file " ++ str f') in let () = close_out ch in let () = Sys.remove f' in iraise reraise diff --git a/library/library.mli b/library/library.mli index 8f5b775d8d..b9044b60dd 100644 --- a/library/library.mli +++ b/library/library.mli @@ -37,9 +37,9 @@ type seg_proofs = Term.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid located list -> unit -(** Start the compilation of a file as a library. The argument must be an - existing file on the system, and the returned path is the associated - absolute logical path of the library. *) +(** Start the compilation of a file as a library. The first argument must be + output file, and the + returned path is the associated absolute logical path of the library. *) val start_library : CUnix.physical_path -> DirPath.t (** End the compilation of a library and save it to a ".vo" file *) diff --git a/library/library.mllib b/library/library.mllib index 9206573658..df4f735034 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -5,7 +5,6 @@ Libobject Summary Nametab Global -Universes Lib Declaremods Loadpath diff --git a/library/loadpath.ml b/library/loadpath.ml index f8169576dd..d03c6c5553 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -8,7 +8,7 @@ open Pp open Util -open Errors +open CErrors open Names open Libnames @@ -50,6 +50,13 @@ let remove_load_path dir = let filter p = not (String.equal p.path_physical dir) in load_paths := List.filter filter !load_paths +let warn_overriding_logical_loadpath = + CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" + (fun (phys_path, old_path, coq_path) -> + str phys_path ++ strbrk " was previously bound to " ++ + pr_dirpath old_path ++ strbrk "; it is remapped to " ++ + pr_dirpath coq_path) + let add_load_path phys_path coq_path ~implicit = let phys_path = CUnix.canonical_path_name phys_path in let filter p = String.equal p.path_physical phys_path in @@ -65,17 +72,12 @@ let add_load_path phys_path coq_path ~implicit = let replace = if DirPath.equal coq_path old_path then implicit <> old_implicit - else if DirPath.equal coq_path (Nameops.default_root_prefix) - && String.equal phys_path (CUnix.canonical_path_name Filename.current_dir_name) then - false (* This is the default "-I ." path, don't override the old path *) else let () = (* Do not warn when overriding the default "-I ." path *) if not (DirPath.equal old_path Nameops.default_root_prefix) then - msg_warning - (str phys_path ++ strbrk " was previously bound to " ++ - pr_dirpath old_path ++ strbrk "; it is remapped to " ++ - pr_dirpath coq_path) in + warn_overriding_logical_loadpath (phys_path, old_path, coq_path) + in true in if replace then begin diff --git a/library/nameops.ml b/library/nameops.ml index 71405d0240..6020db33d9 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -67,9 +67,21 @@ let root_of_id id = let suffixstart = cut_ident true id in Id.of_string (String.sub (Id.to_string id) 0 suffixstart) -(* Rem: semantics is a bit different, if an ident starts with toto00 then - after successive renamings it comes to toto09, then it goes on with toto10 *) -let lift_subscript id = +(* Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + [bar0] ↦ [bar1] + [bar00] ↦ [bar01] + [bar1] ↦ [bar2] + [bar01] ↦ [bar01] + [bar9] ↦ [bar10] + [bar09] ↦ [bar10] + [bar99] ↦ [bar100] +*) +let increment_subscript id = let id = Id.to_string id in let len = String.length id in let rec add carrypos = diff --git a/library/nameops.mli b/library/nameops.mli index 39ce409bcf..3a67b61a13 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -21,9 +21,34 @@ val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t val add_prefix : string -> Id.t -> Id.t -val has_subscript : Id.t -> bool -val lift_subscript : Id.t -> Id.t -val forget_subscript : Id.t -> Id.t +(** Below, by {i subscript} we mean a suffix composed solely from (decimal) digits. *) + +val has_subscript : Id.t -> bool + +val increment_subscript : Id.t -> Id.t +(** Return the same identifier as the original one but whose {i subscript} is incremented. + If the original identifier does not have a suffix, [0] is appended to it. + + Example mappings: + + [bar] ↦ [bar0] + + [bar0] ↦ [bar1] + + [bar00] ↦ [bar01] + + [bar1] ↦ [bar2] + + [bar01] ↦ [bar01] + + [bar9] ↦ [bar10] + + [bar09] ↦ [bar10] + + [bar99] ↦ [bar100] +*) + +val forget_subscript : Id.t -> Id.t val out_name : Name.t -> Id.t (** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"] diff --git a/library/nametab.ml b/library/nametab.ml index bbae98fc01..b76048e890 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Pp open Names @@ -16,10 +16,8 @@ open Globnames exception GlobalizationError of qualid -let error_global_not_found_loc loc q = - Loc.raise loc (GlobalizationError q) - -let error_global_not_found q = raise (GlobalizationError q) +let error_global_not_found ?loc q = + Loc.raise ?loc (GlobalizationError q) (* Kinds of global names *) @@ -82,6 +80,14 @@ module Make (U : UserName) (E : EqualityType) : NAMETREE struct type elt = E.t + (* A name became inaccessible, even with absolute qualification. + Example: + Module F (X : S). Module X. + The argument X of the functor F is masked by the inner module X. + *) + let masking_absolute n = + Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) + type user_name = U.t type path_status = @@ -119,9 +125,7 @@ struct | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - msg_warning (str ("Trying to mask the absolute name \"" - ^ U.to_string n ^ "\"!")); - tree.path + masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) else tree.path @@ -144,7 +148,6 @@ struct | Nothing | Relative _ -> mktree (Absolute (uname,o)) tree.map - let rec push_exactly uname o level tree = function | [] -> anomaly (Pp.str "Prefix longer than path! Impossible!") @@ -155,9 +158,7 @@ let rec push_exactly uname o level tree = function | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - msg_warning (str ("Trying to mask the absolute name \"" - ^ U.to_string n ^ "\"!")); - tree.path + masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) in @@ -452,11 +453,11 @@ let global r = try match locate_extended qid with | TrueGlobal ref -> ref | SynDef _ -> - user_err_loc (loc,"global", - str "Unexpected reference to a notation: " ++ - pr_qualid qid) + user_err ~loc ~hdr:"global" + (str "Unexpected reference to a notation: " ++ + pr_qualid qid) with Not_found -> - error_global_not_found_loc loc qid + error_global_not_found ~loc qid (* Exists functions ********************************************************) @@ -525,14 +526,14 @@ let shortest_qualid_of_tactic kn = let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> - if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e + if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive r = match global r with | IndRef ind -> ind | ref -> - user_err_loc (loc_of_reference r,"global_inductive", - pr_reference r ++ spc () ++ str "is not an inductive type") + user_err ~loc:(loc_of_reference r) ~hdr:"global_inductive" + (pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) diff --git a/library/nametab.mli b/library/nametab.mli index a8a0572b33..d20c399b60 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -60,8 +60,7 @@ open Globnames exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found_loc : Loc.t -> qualid -> 'a -val error_global_not_found : qualid -> 'a +val error_global_not_found : ?loc:Loc.t -> qualid -> 'a (** {6 Register visibility of things } *) diff --git a/library/states.ml b/library/states.ml index 2e1be764ab..95bd819d66 100644 --- a/library/states.ml +++ b/library/states.ml @@ -35,7 +35,7 @@ let with_state_protection f x = try let a = f x in unfreeze st; a with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in (unfreeze st; iraise reraise) let with_state_protection_on_exception = Future.transactify diff --git a/library/summary.ml b/library/summary.ml index 19e7e5fd93..6efa07f388 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util module Dyn = Dyn.Make(struct end) @@ -22,19 +22,8 @@ let summaries = ref Int.Map.empty let mangle id = id ^ "-SUMMARY" -let make_dyn (type a) (tag : a Dyn.tag) = - let infun x = Dyn.Dyn (tag, x) in - let outfun : (Dyn.t -> a) = fun dyn -> - let Dyn.Dyn (t, x) = dyn in - match Dyn.eq t tag with - | None -> assert false - | Some Refl -> x - in - (infun, outfun) - let internal_declare_summary hash sumname sdecl = - let tag = Dyn.create (mangle sumname) in - let (infun, outfun) = make_dyn tag in + let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in @@ -116,10 +105,10 @@ let unfreeze_summaries fs = in let fold id decl state = try fold id decl state - with e when Errors.noncritical e -> - let e = Errors.push e in + with e when CErrors.noncritical e -> + let e = CErrors.push e in Printf.eprintf "Error unfrezing summay %s\n%s\n%!" - (name_of_summary id) (Pp.string_of_ppcmds (Errors.iprint e)); + (name_of_summary id) (Pp.string_of_ppcmds (CErrors.iprint e)); iraise e in (** We rely on the order of the frozen list, and the order of folding *) @@ -160,7 +149,7 @@ let unfreeze_summary datas = let (name, summary) = Int.Map.find id !summaries in try summary.unfreeze_function data with e -> - let e = Errors.push e in + let e = CErrors.push e in prerr_endline ("Exception unfreezing " ^ name); iraise e) datas @@ -197,4 +186,29 @@ let ref ?(freeze=fun _ r -> r) ~name x = init_function = (fun () -> r := x) }; r +module Local = struct + +type 'a local_ref = ('a CEphemeron.key * string) ref + +let (:=) r v = r := (CEphemeron.create v, snd !r) + +let (!) r = + let key, name = !r in + try CEphemeron.get key + with CEphemeron.InvalidKey -> + let _, { init_function } = + Int.Map.find (String.hash (mangle name)) !summaries in + init_function (); + CEphemeron.get (fst !r) + +let ref ?(freeze=fun x -> x) ~name init = + let r = Pervasives.ref (CEphemeron.create init, name) in + declare_summary name + { freeze_function = (fun _ -> freeze !r); + unfreeze_function = ((:=) r); + init_function = (fun () -> r := init) }; + r + +end + let dump = Dyn.dump diff --git a/library/summary.mli b/library/summary.mli index 27889cab27..1b57613cb7 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -42,6 +42,17 @@ val declare_summary : string -> 'a summary_declaration -> unit val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref +(* As [ref] but the value is local to a process, i.e. not sent to, say, proof + * workers. It is useful to implement a local cache for example. *) +module Local : sig + + type 'a local_ref + val ref : ?freeze:('a -> 'a) -> name:string -> 'a -> 'a local_ref + val (:=) : 'a local_ref -> 'a -> unit + val (!) : 'a local_ref -> 'a + +end + (** Special name for the summary of ML modules. This summary entry is special because its unfreeze may load ML code and hence add summary entries. Thus is has to be recognizable, and handled appropriately *) diff --git a/library/universes.ml b/library/universes.ml deleted file mode 100644 index c4eb2afcbb..0000000000 --- a/library/universes.ml +++ /dev/null @@ -1,1101 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Util -open Pp -open Names -open Term -open Environ -open Univ -open Globnames - -(** Global universe names *) -type universe_names = - Univ.universe_level Idmap.t * Id.t Univ.LMap.t - -let global_universes = - Summary.ref ~name:"Global universe names" - ((Idmap.empty, Univ.LMap.empty) : universe_names) - -let global_universe_names () = !global_universes -let set_global_universe_names s = global_universes := s - -let pr_with_global_universes l = - try Nameops.pr_id (LMap.find l (snd !global_universes)) - with Not_found -> Level.pr l - -(** Local universe names of polymorphic references *) - -type universe_binders = (Id.t * Univ.universe_level) list - -let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" - -let universe_binders_of_global ref = - try - let l = Refmap.find ref !universe_binders_table in l - with Not_found -> [] - -let register_universe_binders ref l = - universe_binders_table := Refmap.add ref l !universe_binders_table - -(* To disallow minimization to Set *) - -let set_minimization = ref true -let is_set_minimization () = !set_minimization - -type universe_constraint_type = ULe | UEq | ULub - -type universe_constraint = universe * universe_constraint_type * universe - -module Constraints = struct - module S = Set.Make( - struct - type t = universe_constraint - - let compare_type c c' = - match c, c' with - | ULe, ULe -> 0 - | ULe, _ -> -1 - | _, ULe -> 1 - | UEq, UEq -> 0 - | UEq, _ -> -1 - | ULub, ULub -> 0 - | ULub, _ -> 1 - - let compare (u,c,v) (u',c',v') = - let i = compare_type c c' in - if Int.equal i 0 then - let i' = Universe.compare u u' in - if Int.equal i' 0 then Universe.compare v v' - else - if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0 - else i' - else i - end) - - include S - - let add (l,d,r as cst) s = - if Universe.equal l r then s - else add cst s - - let tr_dir = function - | ULe -> Le - | UEq -> Eq - | ULub -> Eq - - let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ " - - let pr c = - fold (fun (u1,op,u2) pp_std -> - pp_std ++ Universe.pr u1 ++ str (op_str op) ++ - Universe.pr u2 ++ fnl ()) c (str "") - - let equal x y = - x == y || equal x y - -end - -type universe_constraints = Constraints.t -type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option -type 'a universe_constrained = 'a * universe_constraints - -type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints - -let enforce_eq_instances_univs strict x y c = - let d = if strict then ULub else UEq in - let ax = Instance.to_array x and ay = Instance.to_array y in - if Array.length ax != Array.length ay then - Errors.anomaly (Pp.str "Invalid argument: enforce_eq_instances_univs called with" ++ - Pp.str " instances of different lengths"); - CArray.fold_right2 - (fun x y -> Constraints.add (Universe.make x, d, Universe.make y)) - ax ay c - -let subst_univs_universe_constraint fn (u,d,v) = - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (u',d,v') - -let subst_univs_universe_constraints subst csts = - Constraints.fold - (fun c -> Option.fold_right Constraints.add (subst_univs_universe_constraint subst c)) - csts Constraints.empty - - -let to_constraints g s = - let tr (x,d,y) acc = - let add l d l' acc = Constraint.add (l,Constraints.tr_dir d,l') acc in - match Universe.level x, d, Universe.level y with - | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc - | _, ULe, Some l' -> enforce_leq x y acc - | _, ULub, _ -> acc - | _, d, _ -> - let f = if d == ULe then UGraph.check_leq else UGraph.check_eq in - if f g x y then acc else - raise (Invalid_argument - "to_constraints: non-trivial algebraic constraint between universes") - in Constraints.fold tr s Constraint.empty - -let eq_constr_univs_infer univs fold m n accu = - if m == n then Some accu - else - let cstrs = ref accu in - let eq_universes strict = UGraph.check_eq_instances univs in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - if res then Some !cstrs else None - -(** Variant of [eq_constr_univs_infer] taking kind-of-term functions, - to expose subterms of [m] and [n], arguments. *) -let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = - (* spiwack: duplicates the code of [eq_constr_univs_infer] because I - haven't find a way to factor the code without destroying - pointer-equality optimisations in [eq_constr_univs_infer]. - Pointer equality is not sufficient to ensure equality up to - [kind1,kind2], because [kind1] and [kind2] may be different, - typically evaluating [m] and [n] in different evar maps. *) - let cstrs = ref accu in - let eq_universes strict = UGraph.check_eq_instances univs in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' m n = - Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n - in - let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in - if res then Some !cstrs else None - -let leq_constr_univs_infer univs fold m n accu = - if m == n then Some accu - else - let cstrs = ref accu in - let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let leq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts - eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - let res = compare_leq m n in - if res then Some !cstrs else None - -let eq_constr_universes m n = - if m == n then true, Constraints.empty - else - let cstrs = ref Constraints.empty in - let eq_universes strict l l' = - cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - (cstrs := Constraints.add - (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs; - true) - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - res, !cstrs - -let leq_constr_universes m n = - if m == n then true, Constraints.empty - else - let cstrs = ref Constraints.empty in - let eq_universes strict l l' = - cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else (cstrs := Constraints.add - (Sorts.univ_of_sort s1,UEq,Sorts.univ_of_sort s2) !cstrs; - true) - in - let leq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - (cstrs := Constraints.add - (Sorts.univ_of_sort s1,ULe,Sorts.univ_of_sort s2) !cstrs; - true) - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - let res = compare_leq m n in - res, !cstrs - -let compare_head_gen_proj env equ eqs eqc' m n = - match kind_of_term m, kind_of_term n with - | Proj (p, c), App (f, args) - | App (f, args), Proj (p, c) -> - (match kind_of_term f with - | Const (p', u) when eq_constant (Projection.constant p) p' -> - let pb = Environ.lookup_projection p env in - let npars = pb.Declarations.proj_npars in - if Array.length args == npars + 1 then - eqc' c args.(npars) - else false - | _ -> false) - | _ -> Constr.compare_head_gen equ eqs eqc' m n - -let eq_constr_universes_proj env m n = - if m == n then true, Constraints.empty - else - let cstrs = ref Constraints.empty in - let eq_universes strict l l' = - cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - (cstrs := Constraints.add - (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs; - true) - in - let rec eq_constr' m n = - m == n || compare_head_gen_proj env eq_universes eq_sorts eq_constr' m n - in - let res = eq_constr' m n in - res, !cstrs - -(* Generator of levels *) -let new_univ_level, set_remote_new_univ_level = - RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) - -let new_univ_level _ = new_univ_level () - (* Univ.Level.make db (new_univ_level ()) *) - -let fresh_level () = new_univ_level (Global.current_dirpath ()) - -(* TODO: remove *) -let new_univ dp = Univ.Universe.make (new_univ_level dp) -let new_Type dp = mkType (new_univ dp) -let new_Type_sort dp = Type (new_univ dp) - -let fresh_universe_instance ctx = - Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) - (UContext.instance ctx) - -let fresh_instance_from_context ctx = - let inst = fresh_universe_instance ctx in - let constraints = instantiate_univ_constraints inst ctx in - inst, constraints - -let fresh_instance ctx = - let ctx' = ref LSet.empty in - let inst = - Instance.subst_fn (fun v -> - let u = new_univ_level (Global.current_dirpath ()) in - ctx' := LSet.add u !ctx'; u) - (UContext.instance ctx) - in !ctx', inst - -let existing_instance ctx inst = - let () = - let a1 = Instance.to_array inst - and a2 = Instance.to_array (UContext.instance ctx) in - let len1 = Array.length a1 and len2 = Array.length a2 in - if not (len1 == len2) then - Errors.errorlabstrm "Universes" - (str "Polymorphic constant expected " ++ int len2 ++ - str" levels but was given " ++ int len1) - else () - in LSet.empty, inst - -let fresh_instance_from ctx inst = - let ctx', inst = - match inst with - | Some inst -> existing_instance ctx inst - | None -> fresh_instance ctx - in - let constraints = instantiate_univ_constraints inst ctx in - inst, (ctx', constraints) - -let unsafe_instance_from ctx = - (Univ.UContext.instance ctx, ctx) - -(** Fresh universe polymorphic construction *) - -let fresh_constant_instance env c inst = - let cb = lookup_constant c env in - if cb.Declarations.const_polymorphic then - let inst, ctx = - fresh_instance_from - (Declareops.universes_of_constant (Environ.opaque_tables env) cb) inst - in - ((c, inst), ctx) - else ((c,Instance.empty), ContextSet.empty) - -let fresh_inductive_instance env ind inst = - let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in - ((ind,inst), ctx) - else ((ind,Instance.empty), ContextSet.empty) - -let fresh_constructor_instance env (ind,i) inst = - let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in - (((ind,i),inst), ctx) - else (((ind,i),Instance.empty), ContextSet.empty) - -let unsafe_constant_instance env c = - let cb = lookup_constant c env in - if cb.Declarations.const_polymorphic then - let inst, ctx = unsafe_instance_from - (Declareops.universes_of_constant (Environ.opaque_tables env) cb) in - ((c, inst), ctx) - else ((c,Instance.empty), UContext.empty) - -let unsafe_inductive_instance env ind = - let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in - ((ind,inst), ctx) - else ((ind,Instance.empty), UContext.empty) - -let unsafe_constructor_instance env (ind,i) = - let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in - (((ind,i),inst), ctx) - else (((ind,i),Instance.empty), UContext.empty) - -open Globnames - -let fresh_global_instance ?names env gr = - match gr with - | VarRef id -> mkVar id, ContextSet.empty - | ConstRef sp -> - let c, ctx = fresh_constant_instance env sp names in - mkConstU c, ctx - | ConstructRef sp -> - let c, ctx = fresh_constructor_instance env sp names in - mkConstructU c, ctx - | IndRef sp -> - let c, ctx = fresh_inductive_instance env sp names in - mkIndU c, ctx - -let fresh_constant_instance env sp = - fresh_constant_instance env sp None - -let fresh_inductive_instance env sp = - fresh_inductive_instance env sp None - -let fresh_constructor_instance env sp = - fresh_constructor_instance env sp None - -let unsafe_global_instance env gr = - match gr with - | VarRef id -> mkVar id, UContext.empty - | ConstRef sp -> - let c, ctx = unsafe_constant_instance env sp in - mkConstU c, ctx - | ConstructRef sp -> - let c, ctx = unsafe_constructor_instance env sp in - mkConstructU c, ctx - | IndRef sp -> - let c, ctx = unsafe_inductive_instance env sp in - mkIndU c, ctx - -let constr_of_global gr = - let c, ctx = fresh_global_instance (Global.env ()) gr in - if not (Univ.ContextSet.is_empty ctx) then - if Univ.LSet.is_empty (Univ.ContextSet.levels ctx) then - (* Should be an error as we might forget constraints, allow for now - to make firstorder work with "using" clauses *) - c - else raise (Invalid_argument - ("constr_of_global: globalization of polymorphic reference " ^ - Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^ - " would forget universes.")) - else c - -let constr_of_reference = constr_of_global - -let unsafe_constr_of_global gr = - unsafe_global_instance (Global.env ()) gr - -let constr_of_global_univ (gr,u) = - match gr with - | VarRef id -> mkVar id - | ConstRef sp -> mkConstU (sp,u) - | ConstructRef sp -> mkConstructU (sp,u) - | IndRef sp -> mkIndU (sp,u) - -let fresh_global_or_constr_instance env = function - | IsConstr c -> c, ContextSet.empty - | IsGlobal gr -> fresh_global_instance env gr - -let global_of_constr c = - match kind_of_term c with - | Const (c, u) -> ConstRef c, u - | Ind (i, u) -> IndRef i, u - | Construct (c, u) -> ConstructRef c, u - | Var id -> VarRef id, Instance.empty - | _ -> raise Not_found - -let global_app_of_constr c = - match kind_of_term c with - | Const (c, u) -> (ConstRef c, u), None - | Ind (i, u) -> (IndRef i, u), None - | Construct (c, u) -> (ConstructRef c, u), None - | Var id -> (VarRef id, Instance.empty), None - | Proj (p, c) -> (ConstRef (Projection.constant p), Instance.empty), Some c - | _ -> raise Not_found - -open Declarations - -let type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env, ContextSet.empty - | ConstRef c -> - let cb = Environ.lookup_constant c env in - let ty = Typeops.type_of_constant_type env cb.const_type in - if cb.const_polymorphic then - let inst, ctx = fresh_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) None in - Vars.subst_instance_constr inst ty, ctx - else ty, ContextSet.empty - - | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - if mib.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.mind_universes None in - let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - else - let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in - ty, ContextSet.empty - | ConstructRef cstr -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - if mib.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.mind_universes None in - Inductive.type_of_constructor (cstr,inst) specif, ctx - else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty - -let type_of_global t = type_of_reference (Global.env ()) t - -let unsafe_type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env - | ConstRef c -> - let cb = Environ.lookup_constant c env in - Typeops.type_of_constant_type env cb.const_type - - | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let (_, inst), _ = unsafe_inductive_instance env ind in - Inductive.type_of_inductive env (specif, inst) - - | ConstructRef (ind, _ as cstr) -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - let (_, inst), _ = unsafe_inductive_instance env ind in - Inductive.type_of_constructor (cstr,inst) specif - -let unsafe_type_of_global t = unsafe_type_of_reference (Global.env ()) t - -let fresh_sort_in_family env = function - | InProp -> prop_sort, ContextSet.empty - | InSet -> set_sort, ContextSet.empty - | InType -> - let u = fresh_level () in - Type (Univ.Universe.make u), ContextSet.singleton u - -let new_sort_in_family sf = - fst (fresh_sort_in_family (Global.env ()) sf) - -let extend_context (a, ctx) (ctx') = - (a, ContextSet.union ctx ctx') - -let new_global_univ () = - let u = fresh_level () in - (Univ.Universe.make u, ContextSet.singleton u) - -(** Simplification *) - -module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) - -let add_list_map u t map = - try - let l = LMap.find u map in - LMap.update u (t :: l) map - with Not_found -> - LMap.add u [t] map - -module UF = LevelUnionFind - -(** Precondition: flexible <= ctx *) -let choose_canonical ctx flexible algs s = - let global = LSet.diff s ctx in - let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in - (** If there is a global universe in the set, choose it *) - if not (LSet.is_empty global) then - let canon = LSet.choose global in - canon, (LSet.remove canon global, rigid, flexible) - else (** No global in the equivalence class, choose a rigid one *) - if not (LSet.is_empty rigid) then - let canon = LSet.choose rigid in - canon, (global, LSet.remove canon rigid, flexible) - else (** There are only flexible universes in the equivalence - class, choose a non-algebraic. *) - let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in - if not (LSet.is_empty nonalgs) then - let canon = LSet.choose nonalgs in - canon, (global, rigid, LSet.remove canon flexible) - else - let canon = LSet.choose algs in - canon, (global, rigid, LSet.remove canon flexible) - -let subst_univs_fn_puniverses lsubst (c, u as cu) = - let u' = Instance.subst_fn lsubst u in - if u' == u then cu else (c, u') - -let nf_evars_and_universes_opt_subst f subst = - let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in - let lsubst = Univ.level_subst_of subst in - let rec aux c = - match kind_of_term c with - | Evar (evk, args) -> - let args = Array.map aux args in - (match try f (evk, args) with Not_found -> None with - | None -> c - | Some c -> aux c) - | Const pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkConstU pu' - | Ind pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkIndU pu' - | Construct pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkConstructU pu' - | Sort (Type u) -> - let u' = Univ.subst_univs_universe subst u in - if u' == u then c else mkSort (sort_of_univ u') - | _ -> map_constr aux c - in aux - -let fresh_universe_context_set_instance ctx = - if ContextSet.is_empty ctx then LMap.empty, ctx - else - let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in - let univs',subst = LSet.fold - (fun u (univs',subst) -> - let u' = fresh_level () in - (LSet.add u' univs', LMap.add u u' subst)) - univs (LSet.empty, LMap.empty) - in - let cst' = subst_univs_level_constraints subst cst in - subst, (univs', cst') - -let normalize_univ_variable ~find ~update = - let rec aux cur = - let b = find cur in - let b' = subst_univs_universe aux b in - if Universe.equal b' b then b - else update cur b' - in aux - -let normalize_univ_variable_opt_subst ectx = - let find l = - match Univ.LMap.find l !ectx with - | Some b -> b - | None -> raise Not_found - in - let update l b = - assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false - in normalize_univ_variable ~find ~update - -let normalize_univ_variable_subst subst = - let find l = Univ.LMap.find l !subst in - let update l b = - assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in - normalize_univ_variable ~find ~update - -let normalize_universe_opt_subst subst = - let normlevel = normalize_univ_variable_opt_subst subst in - subst_univs_universe normlevel - -let normalize_universe_subst subst = - let normlevel = normalize_univ_variable_subst subst in - subst_univs_universe normlevel - -let normalize_opt_subst ctx = - let ectx = ref ctx in - let normalize = normalize_univ_variable_opt_subst ectx in - let () = - Univ.LMap.iter (fun u v -> - if Option.is_empty v then () - else try ignore(normalize u) with Not_found -> assert(false)) ctx - in !ectx - -type universe_opt_subst = universe option universe_map - -let make_opt_subst s = - fun x -> - (match Univ.LMap.find x s with - | Some u -> u - | None -> raise Not_found) - -let subst_opt_univs_constr s = - let f = make_opt_subst s in - Vars.subst_univs_fn_constr f - - -let normalize_univ_variables ctx = - let ctx = normalize_opt_subst ctx in - let undef, def, subst = - Univ.LMap.fold (fun u v (undef, def, subst) -> - match v with - | None -> (Univ.LSet.add u undef, def, subst) - | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) - ctx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) - in ctx, undef, def, subst - -let pr_universe_body = function - | None -> mt () - | Some v -> str" := " ++ Univ.Universe.pr v - -let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body - -exception Found of Level.t -let find_inst insts v = - try LMap.iter (fun k (enf,alg,v') -> - if not alg && enf && Universe.equal v' v then raise (Found k)) - insts; raise Not_found - with Found l -> l - -let compute_lbound left = - (** The universe variable was not fixed yet. - Compute its level using its lower bound. *) - let sup l lbound = - match lbound with - | None -> Some l - | Some l' -> Some (Universe.sup l l') - in - List.fold_left (fun lbound (d, l) -> - if d == Le (* l <= ?u *) then sup l lbound - else (* l < ?u *) - (assert (d == Lt); - if not (Universe.level l == None) then - sup (Universe.super l) lbound - else None)) - None left - -let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) = - if enforce then - let inst = Universe.make u in - let cstrs' = enforce_leq lbound inst cstrs in - (ctx, us, LSet.remove u algs, - LMap.add u (enforce,alg,lbound) insts, cstrs'), (enforce, alg, inst) - else (* Actually instantiate *) - (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, - LMap.add u (enforce,alg,lbound) insts, cstrs), (enforce, alg, lbound) - -type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t - -let pr_constraints_map cmap = - LMap.fold (fun l cstrs acc -> - Level.pr l ++ str " => " ++ - prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () - ++ acc) - cmap (mt ()) - -let remove_alg l (ctx, us, algs, insts, cstrs) = - (ctx, us, LSet.remove l algs, insts, cstrs) - -let minimize_univ_variables ctx us algs left right cstrs = - let left, lbounds = - Univ.LMap.fold (fun r lower (left, lbounds as acc) -> - if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc - else (* Fixed universe, just compute its glb for sharing *) - let lbounds' = - match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with - | None -> lbounds - | Some lbound -> LMap.add r (true, false, lbound) lbounds - in (Univ.LMap.remove r left, lbounds')) - left (left, Univ.LMap.empty) - in - let rec instance (ctx', us, algs, insts, cstrs as acc) u = - let acc, left = - try let l = LMap.find u left in - List.fold_left - (fun (acc, left') (d, l) -> - let acc', (enf,alg,l') = aux acc l in - let l' = - if enf then Universe.make l - else l' - in acc', (d, l') :: left') - (acc, []) l - with Not_found -> acc, [] - and right = - try Some (LMap.find u right) - with Not_found -> None - in - let instantiate_lbound lbound = - let alg = LSet.mem u algs in - if alg then - (* u is algebraic: we instantiate it with it's lower bound, if any, - or enforce the constraints if it is bounded from the top. *) - instantiate_with_lbound u lbound true false acc - else (* u is non algebraic *) - match Universe.level lbound with - | Some l -> (* The lowerbound is directly a level *) - (* u is not algebraic but has no upper bounds, - we instantiate it with its lower bound if it is a - different level, otherwise we keep it. *) - if not (Level.equal l u) then - (* Should check that u does not - have upper constraints that are not already in right *) - let acc' = remove_alg l acc in - instantiate_with_lbound u lbound false false acc' - else acc, (true, false, lbound) - | None -> - try - (* if right <> None then raise Not_found; *) - (* Another universe represents the same lower bound, - we can share them with no harm. *) - let can = find_inst insts lbound in - instantiate_with_lbound u (Universe.make can) false false acc - with Not_found -> - (* We set u as the canonical universe representing lbound *) - instantiate_with_lbound u lbound false true acc - in - let acc' acc = - match right with - | None -> acc - | Some cstrs -> - let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in - if List.is_empty dangling then acc - else - let ((ctx', us, algs, insts, cstrs), (enf,_,inst as b)) = acc in - let cstrs' = List.fold_left (fun cstrs (d, r) -> - if d == Univ.Le then - enforce_leq inst (Universe.make r) cstrs - else - try let lev = Option.get (Universe.level inst) in - Constraint.add (lev, d, r) cstrs - with Option.IsNone -> failwith "") - cstrs dangling - in - (ctx', us, algs, insts, cstrs'), b - in - if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u)) - else - let lbound = compute_lbound left in - match lbound with - | None -> (* Nothing to do *) - acc' (acc, (true, false, Universe.make u)) - | Some lbound -> - try acc' (instantiate_lbound lbound) - with Failure _ -> acc' (acc, (true, false, Universe.make u)) - and aux (ctx', us, algs, seen, cstrs as acc) u = - try acc, LMap.find u seen - with Not_found -> instance acc u - in - LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> - if v == None then fst (aux acc u) - else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) - us (ctx, us, algs, lbounds, cstrs) - -let normalize_context_set ctx us algs = - let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in - let uf = UF.create () in - (** Keep the Prop/Set <= i constraints separate for minimization *) - let smallles, csts = - Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> - if d == Le then - if Univ.Level.is_small l then - if is_set_minimization () && LSet.mem r ctx then - (Constraint.add cstr smallles, noneqs) - else (smallles, noneqs) - else if Level.is_small r then - if Level.is_prop r then - raise (Univ.UniverseInconsistency - (Le,Universe.make l,Universe.make r,None)) - else (smallles, Constraint.add (l,Eq,r) noneqs) - else (smallles, Constraint.add cstr noneqs) - else (smallles, Constraint.add cstr noneqs)) - csts (Constraint.empty, Constraint.empty) - in - let csts = - (* We first put constraints in a normal-form: all self-loops are collapsed - to equalities. *) - let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) - ctx UGraph.empty_universes - in - let g = - Univ.Constraint.fold - (fun (l, d, r) g -> - let g = - if not (Level.is_small l || LSet.mem l ctx) then - try UGraph.add_universe l false g - with UGraph.AlreadyDeclared -> g - else g - in - let g = - if not (Level.is_small r || LSet.mem r ctx) then - try UGraph.add_universe r false g - with UGraph.AlreadyDeclared -> g - else g - in g) csts g - in - let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in - UGraph.constraints_of_universes g - in - let noneqs = - Constraint.fold (fun (l,d,r as cstr) noneqs -> - if d == Eq then (UF.union l r uf; noneqs) - else (* We ignore the trivial Prop/Set <= i constraints. *) - if d == Le && Univ.Level.is_small l then noneqs - else if Univ.Level.is_prop l && d == Lt && Univ.Level.is_set r - then noneqs - else Constraint.add cstr noneqs) - csts Constraint.empty - in - let noneqs = Constraint.union noneqs smallles in - let partition = UF.partition uf in - let flex x = LMap.mem x us in - let ctx, subst, us, eqs = List.fold_left (fun (ctx, subst, us, cstrs) s -> - let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in - (* Add equalities for globals which can't be merged anymore. *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) global - cstrs - in - (* Also add equalities for rigid variables *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) rigid - cstrs - in - let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in - let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in - let canonu = Some (Universe.make canon) in - let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in - (LSet.diff ctx flexible, subst, us, cstrs)) - (ctx, LMap.empty, us, Constraint.empty) partition - in - (* Noneqs is now in canonical form w.r.t. equality constraints, - and contains only inequality constraints. *) - let noneqs = subst_univs_level_constraints subst noneqs in - (* Compute the left and right set of flexible variables, constraints - mentionning other variables remain in noneqs. *) - let noneqs, ucstrsl, ucstrsr = - Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> - let lus = LMap.mem l us - and rus = LMap.mem r us - in - let ucstrsl' = - if lus then add_list_map l (d, r) ucstrsl - else ucstrsl - and ucstrsr' = - add_list_map r (d, l) ucstrsr - in - let noneqs = - if lus || rus then noneq - else Constraint.add cstr noneq - in (noneqs, ucstrsl', ucstrsr')) - noneqs (Constraint.empty, LMap.empty, LMap.empty) - in - (* Now we construct the instantiation of each variable. *) - let ctx', us, algs, inst, noneqs = - minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs - in - let us = normalize_opt_subst us in - (us, algs), (ctx', Constraint.union noneqs eqs) - -(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) -(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) - -let universes_of_constr c = - let rec aux s c = - match kind_of_term c with - | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.fold LSet.add (Instance.levels u) s - | Sort u when not (Sorts.is_small u) -> - let u = univ_of_sort u in - LSet.fold LSet.add (Universe.levels u) s - | _ -> fold_constr aux s c - in aux LSet.empty c - -let restrict_universe_context (univs,csts) s = - (* Universes that are not necessary to typecheck the term. - E.g. univs introduced by tactics and not used in the proof term. *) - let diff = LSet.diff univs s in - let rec aux diff candid univs ness = - let (diff', candid', univs', ness') = - Constraint.fold - (fun (l, d, r as c) (diff, candid, univs, csts) -> - if not (LSet.mem l diff) then - (LSet.remove r diff, candid, univs, Constraint.add c csts) - else if not (LSet.mem r diff) then - (LSet.remove l diff, candid, univs, Constraint.add c csts) - else (diff, Constraint.add c candid, univs, csts)) - candid (diff, Constraint.empty, univs, ness) - in - if ness' == ness then (LSet.diff univs diff', ness) - else aux diff' candid' univs' ness' - in aux diff csts univs Constraint.empty - -let simplify_universe_context (univs,csts) = - let uf = UF.create () in - let noneqs = - Constraint.fold (fun (l,d,r) noneqs -> - if d == Eq && (LSet.mem l univs || LSet.mem r univs) then - (UF.union l r uf; noneqs) - else Constraint.add (l,d,r) noneqs) - csts Constraint.empty - in - let partition = UF.partition uf in - let flex x = LSet.mem x univs in - let subst, univs', csts' = List.fold_left (fun (subst, univs, cstrs) s -> - let canon, (global, rigid, flexible) = choose_canonical univs flex LSet.empty s in - (* Add equalities for globals which can't be merged anymore. *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) (LSet.union global rigid) - cstrs - in - let subst = LSet.fold (fun f -> LMap.add f canon) - flexible subst - in (subst, LSet.diff univs flexible, cstrs)) - (LMap.empty, univs, noneqs) partition - in - (* Noneqs is now in canonical form w.r.t. equality constraints, - and contains only inequality constraints. *) - let csts' = subst_univs_level_constraints subst csts' in - (univs', csts'), subst - -let is_trivial_leq (l,d,r) = - Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) - -(* Prop < i <-> Set+1 <= i <-> Set < i *) -let translate_cstr (l,d,r as cstr) = - if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then - (Level.set, d, r) - else cstr - -let refresh_constraints univs (ctx, cstrs) = - let cstrs', univs' = - Univ.Constraint.fold (fun c (cstrs', univs as acc) -> - let c = translate_cstr c in - if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) - cstrs (Univ.Constraint.empty, univs) - in ((ctx, cstrs'), univs') - - -(**********************************************************************) -(* Tools for sort-polymorphic inductive types *) - -(* Miscellaneous functions to remove or test local univ assumed to - occur only in the le constraints *) - -(* - Solve a system of universe constraint of the form - - u_s11, ..., u_s1p1, w1 <= u1 - ... - u_sn1, ..., u_snpn, wn <= un - -where - - - the ui (1 <= i <= n) are universe variables, - - the sjk select subsets of the ui for each equations, - - the wi are arbitrary complex universes that do not mention the ui. -*) - -let is_direct_sort_constraint s v = match s with - | Some u -> univ_level_mem u v - | None -> false - -let solve_constraints_system levels level_bounds level_min = - let open Univ in - let levels = - Array.mapi (fun i o -> - match o with - | Some u -> - (match Universe.level u with - | Some u -> Some u - | _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None) - | None -> None) - levels in - let v = Array.copy level_bounds in - let nind = Array.length v in - let clos = Array.map (fun _ -> Int.Set.empty) levels in - (* First compute the transitive closure of the levels dependencies *) - for i=0 to nind-1 do - for j=0 to nind-1 do - if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then - clos.(i) <- Int.Set.add j clos.(i); - done; - done; - let rec closure () = - let continue = ref false in - Array.iteri (fun i deps -> - let deps' = - Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps - in - if Int.Set.equal deps deps' then () - else (clos.(i) <- deps'; continue := true)) - clos; - if !continue then closure () - else () - in - closure (); - for i=0 to nind-1 do - for j=0 to nind-1 do - if not (Int.equal i j) && Int.Set.mem j clos.(i) then - (v.(i) <- Universe.sup v.(i) level_bounds.(j)); - (* level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) *) - done; - (* for j=0 to nind-1 do *) - (* match levels.(j) with *) - (* | Some u when not (Univ.Level.is_small u) -> *) - (* v.(i) <- univ_level_rem u v.(i) level_min.(i) *) - (* | _ -> () *) - (* done *) - done; - v diff --git a/library/universes.mli b/library/universes.mli deleted file mode 100644 index 53cf5f3844..0000000000 --- a/library/universes.mli +++ /dev/null @@ -1,272 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Util -open Names -open Term -open Environ -open Univ - -val set_minimization : bool ref -val is_set_minimization : unit -> bool - -(** Universes *) - -(** Global universe name <-> level mapping *) -type universe_names = - Univ.universe_level Idmap.t * Id.t Univ.LMap.t - -val global_universe_names : unit -> universe_names -val set_global_universe_names : universe_names -> unit - -val pr_with_global_universes : Level.t -> Pp.std_ppcmds - -(** Local universe name <-> level mapping *) - -type universe_binders = (Id.t * Univ.universe_level) list - -val register_universe_binders : Globnames.global_reference -> universe_binders -> unit -val universe_binders_of_global : Globnames.global_reference -> universe_binders - -(** The global universe counter *) -val set_remote_new_univ_level : universe_level RemoteCounter.installer - -(** Side-effecting functions creating new universe levels. *) - -val new_univ_level : Names.dir_path -> universe_level -val new_univ : Names.dir_path -> universe -val new_Type : Names.dir_path -> types -val new_Type_sort : Names.dir_path -> sorts - -val new_global_univ : unit -> universe in_universe_context_set -val new_sort_in_family : sorts_family -> sorts - -(** {6 Constraints for type inference} - - When doing conversion of universes, not only do we have =/<= constraints but - also Lub constraints which correspond to unification of two levels which might - not be necessary if unfolding is performed. -*) - -type universe_constraint_type = ULe | UEq | ULub - -type universe_constraint = universe * universe_constraint_type * universe -module Constraints : sig - include Set.S with type elt = universe_constraint - - val pr : t -> Pp.std_ppcmds -end - -type universe_constraints = Constraints.t -type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option -type 'a universe_constrained = 'a * universe_constraints -type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints - -val subst_univs_universe_constraints : universe_subst_fn -> - universe_constraints -> universe_constraints - -val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function - -val to_constraints : UGraph.t -> universe_constraints -> constraints - -(** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, - application grouping, the universe constraints in [u] and additional constraints [c]. *) -val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> - constr -> constr -> 'a -> 'a option - -(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of - {!eq_constr_univs_infer} taking kind-of-term functions, to expose - subterms of [m] and [n], arguments. *) -val eq_constr_univs_infer_with : - (constr -> (constr,types) kind_of_term) -> - (constr -> (constr,types) kind_of_term) -> - UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option - -(** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] - modulo alpha, casts, application grouping, the universe constraints - in [u] and additional constraints [c]. *) -val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> - constr -> constr -> 'a -> 'a option - -(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, - application grouping and the universe constraints in [c]. *) -val eq_constr_universes : constr -> constr -> bool universe_constrained - -(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo - alpha, casts, application grouping and the universe constraints in [c]. *) -val leq_constr_universes : constr -> constr -> bool universe_constrained - -(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, - application grouping and the universe constraints in [c]. *) -val eq_constr_universes_proj : env -> constr -> constr -> bool universe_constrained - -(** Build a fresh instance for a given context, its associated substitution and - the instantiated constraints. *) - -val fresh_instance_from_context : universe_context -> - universe_instance constrained - -val fresh_instance_from : universe_context -> universe_instance option -> - universe_instance in_universe_context_set - -val fresh_sort_in_family : env -> sorts_family -> - sorts in_universe_context_set -val fresh_constant_instance : env -> constant -> - pconstant in_universe_context_set -val fresh_inductive_instance : env -> inductive -> - pinductive in_universe_context_set -val fresh_constructor_instance : env -> constructor -> - pconstructor in_universe_context_set - -val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> - constr in_universe_context_set - -val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> - constr in_universe_context_set - -(** Get fresh variables for the universe context. - Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) -val fresh_universe_context_set_instance : universe_context_set -> - universe_level_subst * universe_context_set - -(** Raises [Not_found] if not a global reference. *) -val global_of_constr : constr -> Globnames.global_reference puniverses - -val global_app_of_constr : constr -> Globnames.global_reference puniverses * constr option - -val constr_of_global_univ : Globnames.global_reference puniverses -> constr - -val extend_context : 'a in_universe_context_set -> universe_context_set -> - 'a in_universe_context_set - -(** Simplification and pruning of constraints: - [normalize_context_set ctx us] - - - Instantiate the variables in [us] with their most precise - universe levels respecting the constraints. - - - Normalizes the context [ctx] w.r.t. equality constraints, - choosing a canonical universe in each equivalence class - (a global one if there is one) and transitively saturate - the constraints w.r.t to the equalities. *) - -module UF : Unionfind.PartitionSig with type elt = universe_level - -type universe_opt_subst = universe option universe_map - -val make_opt_subst : universe_opt_subst -> universe_subst_fn - -val subst_opt_univs_constr : universe_opt_subst -> constr -> constr - -val normalize_context_set : universe_context_set -> - universe_opt_subst (* The defined and undefined variables *) -> - universe_set (* univ variables that can be substituted by algebraics *) -> - (universe_opt_subst * universe_set) in_universe_context_set - -val normalize_univ_variables : universe_opt_subst -> - universe_opt_subst * universe_set * universe_set * universe_subst - -val normalize_univ_variable : - find:(universe_level -> universe) -> - update:(universe_level -> universe -> universe) -> - universe_level -> universe - -val normalize_univ_variable_opt_subst : universe_opt_subst ref -> - (universe_level -> universe) - -val normalize_univ_variable_subst : universe_subst ref -> - (universe_level -> universe) - -val normalize_universe_opt_subst : universe_opt_subst ref -> - (universe -> universe) - -val normalize_universe_subst : universe_subst ref -> - (universe -> universe) - -(** Create a fresh global in the global environment, without side effects. - BEWARE: this raises an ANOMALY on polymorphic constants/inductives: - the constraints should be properly added to an evd. - See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for - the proper way to get a fresh copy of a global reference. *) -val constr_of_global : Globnames.global_reference -> constr - -(** ** DEPRECATED ** synonym of [constr_of_global] *) -val constr_of_reference : Globnames.global_reference -> constr - -(** [unsafe_constr_of_global gr] turns [gr] into a constr, works on polymorphic - references by taking the original universe instance that is not recorded - anywhere. The constraints are forgotten as well. DO NOT USE in new code. *) -val unsafe_constr_of_global : Globnames.global_reference -> constr in_universe_context - -(** Returns the type of the global reference, by creating a fresh instance of polymorphic - references and computing their instantiated universe context. (side-effect on the - universe counter, use with care). *) -val type_of_global : Globnames.global_reference -> types in_universe_context_set - -(** [unsafe_type_of_global gr] returns [gr]'s type, works on polymorphic - references by taking the original universe instance that is not recorded - anywhere. The constraints are forgotten as well. - USE with care. *) -val unsafe_type_of_global : Globnames.global_reference -> types - -(** Full universes substitutions into terms *) - -val nf_evars_and_universes_opt_subst : (existential -> constr option) -> - universe_opt_subst -> constr -> constr - -(** Shrink a universe context to a restricted set of variables *) - -val universes_of_constr : constr -> universe_set -val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set -val simplify_universe_context : universe_context_set -> - universe_context_set * universe_level_subst - -val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t - -(** Pretty-printing *) - -val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds - -(* For tracing *) - -type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t - -val pr_constraints_map : constraints_map -> Pp.std_ppcmds - -val choose_canonical : universe_set -> (Level.t -> bool) (* flexibles *) -> universe_set -> universe_set -> - universe_level * (universe_set * universe_set * universe_set) - -val compute_lbound : (constraint_type * Univ.universe) list -> universe option - -val instantiate_with_lbound : - Univ.LMap.key -> - Univ.universe -> - bool -> - bool -> - Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints -> - (Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints) * - (bool * bool * Univ.universe) - -val minimize_univ_variables : - Univ.LSet.t -> - Univ.universe option Univ.LMap.t -> - Univ.LSet.t -> - constraints_map -> constraints_map -> - Univ.constraints -> - Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints - -(** {6 Support for old-style sort-polymorphism } *) - -val solve_constraints_system : universe option array -> universe array -> universe array -> - universe array |