diff options
Diffstat (limited to 'interp')
| -rw-r--r-- | interp/constrexpr_ops.ml | 34 | ||||
| -rw-r--r-- | interp/constrexpr_ops.mli | 7 | ||||
| -rw-r--r-- | interp/constrintern.ml | 34 | ||||
| -rw-r--r-- | interp/constrintern.mli | 7 | ||||
| -rw-r--r-- | interp/modintern.ml | 2 |
5 files changed, 42 insertions, 42 deletions
diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8cc63c5d03..efc2a35b65 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -614,37 +614,3 @@ let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function | _ -> CErrors.user_err ?loc ~hdr:"coerce_to_cases_pattern_expr" (str "This expression should be coercible to a pattern.")) c - -(** Local universe and constraint declarations. *) - -let interp_univ_constraints env evd cstrs = - let interp (evd,cstrs) (u, d, u') = - let ul = Pretyping.interp_known_glob_level evd u in - let u'l = Pretyping.interp_known_glob_level evd u' in - let cstr = (ul,d,u'l) in - let cstrs' = Univ.Constraint.add cstr cstrs in - try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in - evd, cstrs' - with Univ.UniverseInconsistency e as exn -> - let _, info = Exninfo.capture exn in - CErrors.user_err ~hdr:"interp_constraint" ~info - (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) - in - List.fold_left interp (evd,Univ.Constraint.empty) cstrs - -let interp_univ_decl env decl = - let open UState in - let pl : lident list = decl.univdecl_instance in - let evd = Evd.from_ctx (UState.make_with_initial_binders ~lbound:(Environ.universes_lbound env) - (Environ.universes env) pl) in - let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in - let decl = { univdecl_instance = pl; - univdecl_extensible_instance = decl.univdecl_extensible_instance; - univdecl_constraints = cstrs; - univdecl_extensible_constraints = decl.univdecl_extensible_constraints } - in evd, decl - -let interp_univ_decl_opt env l = - match l with - | None -> Evd.from_env env, UState.default_univ_decl - | Some decl -> interp_univ_decl env decl diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index edf52c93e8..dfa51918d1 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -123,10 +123,3 @@ val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> notation - (** For cases pattern parsing errors *) val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a - -(** Local universe and constraint declarations. *) -val interp_univ_decl : Environ.env -> universe_decl_expr -> - Evd.evar_map * UState.universe_decl - -val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> - Evd.evar_map * UState.universe_decl diff --git a/interp/constrintern.ml b/interp/constrintern.ml index ecf2b951a2..06cf19b4f7 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2620,3 +2620,37 @@ let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env let int_env,bl = intern_context env impl_env params in let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) + + +(** Local universe and constraint declarations. *) + +let interp_univ_constraints env evd cstrs = + let interp (evd,cstrs) (u, d, u') = + let ul = Pretyping.interp_known_glob_level evd u in + let u'l = Pretyping.interp_known_glob_level evd u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e as exn -> + let _, info = Exninfo.capture exn in + CErrors.user_err ~hdr:"interp_constraint" ~info + (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open UState in + let binders : lident list = decl.univdecl_instance in + let evd = Evd.from_env ~binders env in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { univdecl_instance = binders; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + in evd, decl + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, UState.default_univ_decl + | Some decl -> interp_univ_decl env decl diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 11d756803f..9037ed5414 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -197,3 +197,10 @@ val get_asymmetric_patterns : unit -> bool val check_duplicate : ?loc:Loc.t -> (qualid * constr_expr) list -> unit (** Check that a list of record field definitions doesn't contain duplicates. *) + +(** Local universe and constraint declarations. *) +val interp_univ_decl : Environ.env -> universe_decl_expr -> + Evd.evar_map * UState.universe_decl + +val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> + Evd.evar_map * UState.universe_decl diff --git a/interp/modintern.ml b/interp/modintern.ml index 50f90ebea7..5f17d3e284 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -106,7 +106,7 @@ let transl_with_decl env base kind = function | CWith_Module ({CAst.v=fqid},qid) -> WithMod (fqid,lookup_module qid), Univ.ContextSet.empty | CWith_Definition ({CAst.v=fqid},udecl,c) -> - let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let sigma, udecl = interp_univ_decl_opt env udecl in let c, ectx = interp_constr env sigma c in let poly = lookup_polymorphism env base kind fqid in begin match UState.check_univ_decl ~poly ectx udecl with |