From 1cdaa823aa2db2f68cf63561a85771bb98aec70f Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 2 Apr 2019 13:22:11 +0200 Subject: [api] Remove 8.10 deprecations. Some of them are significant so presumably it will take a bit of effort to fix overlays. I left out the removal of `nf_enter` for now as MTac2 needs some serious porting in order to avoid it. --- interp/impargs.ml | 2 -- interp/impargs.mli | 4 ---- 2 files changed, 6 deletions(-) (limited to 'interp') diff --git a/interp/impargs.ml b/interp/impargs.ml index d83a0ce918..90fb5a2036 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -120,8 +120,6 @@ let argument_position_eq p1 p2 = match p1, p2 with | Hyp h1, Hyp h2 -> Int.equal h1 h2 | _ -> false -let explicitation_eq = Constrexpr_ops.explicitation_eq - type implicit_explanation = | DepRigid of argument_position | DepFlex of argument_position diff --git a/interp/impargs.mli b/interp/impargs.mli index 0070423530..ccdd448460 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -143,7 +143,3 @@ val projection_implicits : env -> Projection.t -> implicit_status list -> val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list - -val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool - [@@ocaml.deprecated "Use Constrexpr_ops.explicitation_eq instead (since 8.10)"] -(** Equality on [explicitation]. *) -- cgit v1.2.3 From 067dc98d6395b5041680aa137909d9d5519908c9 Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sat, 19 Jan 2019 16:22:12 -0800 Subject: Simplify dispose_implicits --- interp/impargs.ml | 35 ++++++++++------------------------- 1 file changed, 10 insertions(+), 25 deletions(-) (limited to 'interp') diff --git a/interp/impargs.ml b/interp/impargs.ml index d83a0ce918..6a0fa6f238 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -554,31 +554,16 @@ let add_section_impls vars extra_impls (cond,impls) = let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None - | ImplInteractive (ref,flags,exp) -> - (try - let vars = variable_section_segment_of_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 - Some (ImplInteractive (ref,flags,exp),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) - | ImplConstant (con,flags) -> - (try - let vars = variable_section_segment_of_reference (ConstRef con) in - let extra_impls = impls_of_context vars in - let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in - let l' = [ConstRef con,newimpls] in - Some (ImplConstant (con,flags),l') - with Not_found -> (* con not defined in this section *) Some (req,l)) - | ImplMutualInductive (kn,flags) -> - (try - let l' = List.map (fun (gr, l) -> - let vars = variable_section_segment_of_reference gr in - let extra_impls = impls_of_context vars in - (gr, - List.map (add_section_impls vars extra_impls) l)) l - in - Some (ImplMutualInductive (kn,flags),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) + | ImplMutualInductive _ | ImplInteractive _ | ImplConstant _ -> + let l' = + try + List.map (fun (gr, l) -> + let vars = variable_section_segment_of_reference gr in + let extra_impls = impls_of_context vars in + let newimpls = List.map (add_section_impls vars extra_impls) l in + (gr, newimpls)) l + with Not_found -> l in + Some (req,l') let rebuild_implicits (req,l) = match req with -- cgit v1.2.3 From 2c94706d810e371a416b8c2893eb88c40a09b75c Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sat, 19 Jan 2019 20:41:24 -0800 Subject: Remove ref from some implicit_discharge_request --- interp/impargs.ml | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) (limited to 'interp') diff --git a/interp/impargs.ml b/interp/impargs.ml index 6a0fa6f238..cb0f561c4c 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -499,9 +499,9 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal - | ImplConstant of Constant.t * implicits_flags + | ImplConstant of implicits_flags | ImplMutualInductive of MutInd.t * implicits_flags - | ImplInteractive of GlobRef.t * implicits_flags * + | ImplInteractive of implicits_flags * implicit_interactive_request let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" @@ -568,10 +568,10 @@ let discharge_implicits (_,(req,l)) = let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false - | ImplConstant (con,flags) -> - let oldimpls = snd (List.hd l) in - let newimpls = compute_constant_implicits flags con in - req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] + | ImplConstant flags -> + let ref,oldimpls = List.hd l in + let newimpls = compute_global_implicits flags ref in + req, [ref, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags kn in let rec aux olds news = @@ -582,15 +582,14 @@ let rebuild_implicits (req,l) = | _, _ -> assert false in req, aux l newimpls - | ImplInteractive (ref,flags,o) -> + | ImplInteractive (flags,o) -> + let ref,oldimpls = List.hd l in (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> - let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> - let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags ref) in let p = List.length (snd newimpls) - userimplsize in @@ -625,7 +624,7 @@ let declare_implicits_gen req flags ref = let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = - if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in + if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = @@ -634,7 +633,7 @@ let declare_var_implicits id = let declare_constant_implicits con = let flags = !implicit_args in - declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) + declare_implicits_gen (ImplConstant flags) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in @@ -684,7 +683,7 @@ let declare_manual_implicits local ref ?enriching l = let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l])) let maybe_declare_manual_implicits local ref ?enriching l = @@ -743,7 +742,7 @@ let set_implicits local ref l = compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let extract_impargs_data impls = -- cgit v1.2.3 From 4e760a40f22e2d76a3d246b225d290eb5d15e9e8 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Mon, 6 May 2019 14:05:09 +0000 Subject: [Canonical structures] Some projections may not be canonical --- interp/constrextern.ml | 4 ++-- interp/constrintern.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'interp') diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e5bf52571c..bb66658a37 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -850,10 +850,10 @@ let rec extern inctx scopes vars r = | Some c :: q -> match locs with | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | (_, false) :: locs' -> + | { Recordops.pk_true_proj = false } :: locs' -> (* we don't want to print locals *) ip q locs' args acc - | (_, true) :: locs' -> + | { Recordops.pk_true_proj = true } :: locs' -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c0801067ce..f06493b374 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1368,7 +1368,7 @@ let sort_fields ~complete loc fields completer = let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch.") - | (_, regular) :: proj_kinds -> + | { Recordops.pk_true_proj = regular } :: proj_kinds -> (* "regular" is false when the field is defined by a let-in in the record declaration (its value is fixed from other fields). *) -- cgit v1.2.3 From d8d665f900ee92fac8f776031a9a6a0981a4ed2e Mon Sep 17 00:00:00 2001 From: Jasper Hugunin Date: Sun, 19 May 2019 01:38:59 -0700 Subject: Implicit Quantifiers recurse in continuation of let-in --- interp/implicit_quantifiers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'interp') diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index dffccf02fc..6277d874dd 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -281,7 +281,7 @@ let implicits_of_glob_constr ?(with_products=true) l = | _ -> () in [] | GLambda (na, bk, t, b) -> abs na bk b - | GLetIn (na, b, t, c) -> aux i b + | GLetIn (na, b, t, c) -> aux i c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) -- cgit v1.2.3 From b1a3ea4855b1e150b2e677a6d5466458893d6c60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 15 May 2019 18:47:22 +0200 Subject: Inverting the responsibility to define logically a constant in Declare. The code was intricate due to the special handling of side-effects, while it was sufficient to extrude the logical definition to make it clearer. We thus declare a constant in two parts, first purely kernel-related, then purely libobject-related. --- interp/declare.ml | 68 +++++++++++++++++++++++++++---------------------------- 1 file changed, 33 insertions(+), 35 deletions(-) (limited to 'interp') diff --git a/interp/declare.ml b/interp/declare.ml index 76b4bab2ce..9640ea26a6 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -36,9 +36,8 @@ type internal_flag = (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : global_declaration option; - (** [None] when the declaration is a side-effect and has already been defined - in the global environment. *) + cst_decl : Cooking.recipe option; + (** Non-empty only when rebuilding a constant after a section *) cst_kind : logical_kind; cst_locl : bool; } @@ -65,21 +64,21 @@ let open_constant i ((sp,kn), obj) = let exists_name id = variable_exists id || Global.exists_objlabel (Label.of_id id) -let check_exists sp = - let id = basename sp in +let check_exists id = if exists_name id then alreadydeclared (Id.print id ++ str " already exists") let cache_constant ((sp,kn), obj) = + (* Invariant: the constant must exist in the logical environment, except when + redefining it when exiting a section. See [discharge_constant]. *) let id = basename sp in let kn' = match obj.cst_decl with | None -> if Global.exists_objlabel (Label.of_id (basename sp)) then Constant.make1 kn - else CErrors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp) ++ str".") - | Some decl -> - let () = check_exists sp in - Global.add_constant ~in_section:(Lib.sections_are_opened ()) id decl + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") + | Some r -> + Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -93,7 +92,9 @@ let discharge_constant ((sp, kn), obj) = let modlist = replacement_context () in let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in let abstract = (named_of_variable_context hyps, subst, uctx) in - let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in + let new_decl = { from; info = { Opaqueproof.modlist; abstract } } in + (* This is a hack: when leaving a section, we lose the constant definition, so + we have to store it in the libobject to be able to retrieve it after. *) Some { obj with cst_decl = Some new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) @@ -121,27 +122,22 @@ let update_tables c = declare_constant_implicits c; Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) -let register_side_effect (c, role) = +let register_constant kn kind local = let o = inConstant { cst_decl = None; - cst_kind = IsProof Theorem; - cst_locl = false; + cst_kind = kind; + cst_locl = local; } in - let id = Label.to_id (Constant.label c) in - ignore(add_leaf id o); - update_tables c; + let id = Label.to_id (Constant.label kn) in + let _ = add_leaf id o in + update_tables kn + +let register_side_effect (c, role) = + let () = register_constant c (IsProof Theorem) false in match role with | Subproof -> () | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] -let declare_constant_common id cst = - let o = inConstant cst in - let _, kn as oname = add_leaf id o in - pull_to_head oname; - let c = Global.constant_of_delta_kn kn in - update_tables c; - c - let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = @@ -153,7 +149,8 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = +let define_constant ?(export_seff=false) id cd = + (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false | Polymorphic_entry _ -> true @@ -165,20 +162,21 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e export_seff || not de.const_entry_opaque || is_poly de -> - (* This globally defines the side-effects in the environment. We mark - exported constants as being side-effect not to redeclare them at - caching time. *) + (* This globally defines the side-effects in the environment. *) let de, export = Global.export_private_constants ~in_section de in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in + let kn = Global.add_constant ~in_section id decl in + kn, export + +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = + let () = check_exists id in + let kn, export = define_constant ~export_seff id cd in + (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in - let cst = { - cst_decl = Some decl; - cst_kind = kind; - cst_locl = local; - } in - declare_constant_common id cst + let () = register_constant kn kind local in + kn let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) @@ -297,7 +295,7 @@ let open_inductive i ((sp,kn),mie) = let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in - List.iter check_exists (List.map fst names); + List.iter check_exists (List.map (fun p -> basename (fst p)) names); let id = basename sp in let kn' = Global.add_mind id mie in assert (MutInd.equal kn' (MutInd.make1 kn)); -- cgit v1.2.3 From 93aa8aad110a2839d16dce53af12f0728b59ed2a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 14 May 2019 20:27:24 +0200 Subject: Merge the definition of constants and private constants in the API. --- interp/declare.ml | 17 ++++++++++++----- interp/declare.mli | 3 +++ 2 files changed, 15 insertions(+), 5 deletions(-) (limited to 'interp') diff --git a/interp/declare.ml b/interp/declare.ml index 9640ea26a6..29da49f29d 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -78,7 +78,8 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") | Some r -> - Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) + let kn, _ = Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in + kn in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); @@ -149,7 +150,7 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let define_constant ?(export_seff=false) id cd = +let define_constant ?role ?(export_seff=false) id cd = (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false @@ -167,17 +168,23 @@ let define_constant ?(export_seff=false) id cd = export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in - let kn = Global.add_constant ~in_section id decl in - kn, export + let kn, eff = Global.add_constant ?role ~in_section id decl in + kn, eff, export let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = let () = check_exists id in - let kn, export = define_constant ~export_seff id cd in + let kn, _eff, export = define_constant ~export_seff id cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn +let declare_private_constant ~role ?(internal=UserIndividualRequest) ?(local = false) id (cd, kind) = + let kn, eff, export = define_constant ~role id cd in + let () = assert (List.is_empty export) in + let () = register_constant kn kind local in + kn, eff + let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) id ?types (body,univs) = diff --git a/interp/declare.mli b/interp/declare.mli index 8f1e73c88c..2ffde31fc0 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -55,6 +55,9 @@ val definition_entry : ?fix_exn:Future.fix_exn -> val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t +val declare_private_constant : + role:side_effect_role -> ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> Constant.t * Safe_typing.private_constants + val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> ?local:bool -> Id.t -> ?types:constr -> -- cgit v1.2.3 From 27468ae02bbbf018743d53a9db49efa34b6d6a3e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 16 May 2019 00:02:54 +0200 Subject: Ensure statically that declarations built by Term_typing are direct. This removes a lot of cruft breaking the opaque proof abstraction in Safe_typing and similar. --- interp/declare.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'interp') diff --git a/interp/declare.ml b/interp/declare.ml index 29da49f29d..7ee7ecb5e8 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -78,8 +78,7 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") | Some r -> - let kn, _ = Global.add_constant ~in_section:(Lib.sections_are_opened ()) id (GlobalRecipe r) in - kn + Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); -- cgit v1.2.3