aboutsummaryrefslogtreecommitdiff
path: root/interp
diff options
context:
space:
mode:
Diffstat (limited to 'interp')
-rw-r--r--interp/constrexpr_ops.ml88
-rw-r--r--interp/constrexpr_ops.mli12
-rw-r--r--interp/constrextern.ml16
-rw-r--r--interp/constrintern.ml8
-rw-r--r--interp/constrintern.mli1
-rw-r--r--interp/coqlib.mli2
-rw-r--r--interp/notation.ml1
-rw-r--r--interp/notation_ops.ml4
-rw-r--r--interp/stdarg.ml2
-rw-r--r--interp/stdarg.mli1
-rw-r--r--interp/syntax_def.ml2
-rw-r--r--interp/topconstr.ml11
12 files changed, 62 insertions, 86 deletions
diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml
index 53c97f6b6b..a592b4cff8 100644
--- a/interp/constrexpr_ops.ml
+++ b/interp/constrexpr_ops.ml
@@ -303,83 +303,51 @@ let add_name_in_env env n =
let (fresh_var, fresh_var_hook) = Hook.make ~default:(fun _ _ -> assert false) ()
-let expand_pattern_binders mkC bl c =
- let rec loop bl c =
+let expand_binders mkC loc bl c =
+ let rec loop loc bl c =
match bl with
- | [] -> ([], [], c)
+ | [] -> ([], c)
| b :: bl ->
- let (env, bl, c) = loop bl c in
match b with
- | CLocalDef (n, _, _) ->
+ | CLocalDef ((loc1,_) as n, oty, b) ->
+ let env, c = loop (Loc.merge loc1 loc) bl c in
let env = add_name_in_env env n in
- (env, b :: bl, c)
- | CLocalAssum (nl, _, _) ->
+ (env, CLetIn (loc,n,oty,b,c))
+ | CLocalAssum ((loc1,_)::_ as nl, bk, t) ->
+ let env, c = loop (Loc.merge loc1 loc) bl c in
let env = List.fold_left add_name_in_env env nl in
- (env, b :: bl, c)
- | CLocalPattern (loc, p, ty) ->
+ (env, mkC loc (nl,bk,t) c)
+ | CLocalAssum ([],_,_) -> loop loc bl c
+ | CLocalPattern (loc1, p, ty) ->
+ let env, c = loop (Loc.merge loc1 loc) bl c in
let ni = Hook.get fresh_var env c in
- let id = (loc, Name ni) in
- let b =
- CLocalAssum
- ([id], Default Explicit,
- match ty with
+ let id = (loc1, Name ni) in
+ let ty = match ty with
| Some ty -> ty
- | None -> CHole (loc, None, IntroAnonymous, None))
+ | None -> CHole (loc1, None, IntroAnonymous, None)
in
- let e = CRef (Libnames.Ident (loc, ni), None) in
+ let e = CRef (Libnames.Ident (loc1, ni), None) in
let c =
CCases
(loc, LetPatternStyle, None, [(e,None,None)],
- [(loc, [(loc,[p])], mkC loc bl c)])
+ [(loc1, [(loc1,[p])], c)])
in
- (ni :: env, [b], c)
+ (ni :: env, mkC loc ([id],Default Explicit,ty) c)
in
- let (_, bl, c) = loop bl c in
- (bl, c)
+ let (_, c) = loop loc bl c in
+ c
let mkCProdN loc bll c =
- let rec loop loc bll c =
- match bll with
- | CLocalAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
- CProdN (loc,[idl,bk,t],loop (Loc.merge loc1 loc) bll c)
- | CLocalDef ((loc1,_) as id,b,t) :: bll ->
- CLetIn (loc,id,b,t,loop (Loc.merge loc1 loc) bll c)
- | [] -> c
- | CLocalAssum ([],_,_) :: bll -> loop loc bll c
- | CLocalPattern (loc,p,ty) :: bll -> assert false
- in
- let (bll, c) = expand_pattern_binders loop bll c in
- loop loc bll c
+ let mk loc b c = CProdN (loc,[b],c) in
+ expand_binders mk loc bll c
let mkCLambdaN loc bll c =
- let rec loop loc bll c =
- match bll with
- | CLocalAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
- CLambdaN (loc,[idl,bk,t],loop (Loc.merge loc1 loc) bll c)
- | CLocalDef ((loc1,_) as id,b,t) :: bll ->
- CLetIn (loc,id,b,t,loop (Loc.merge loc1 loc) bll c)
- | [] -> c
- | CLocalAssum ([],_,_) :: bll -> loop loc bll c
- | CLocalPattern (loc,p,ty) :: bll -> assert false
- in
- let (bll, c) = expand_pattern_binders loop bll c in
- loop loc bll c
-
-let rec abstract_constr_expr c = function
- | [] -> c
- | CLocalDef (x,b,t)::bl -> mkLetInC(x,b,t,abstract_constr_expr c bl)
- | CLocalAssum (idl,bk,t)::bl ->
- List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl
- (abstract_constr_expr c bl)
- | CLocalPattern _::_ -> assert false
-
-let rec prod_constr_expr c = function
- | [] -> c
- | CLocalDef (x,b,t)::bl -> mkLetInC(x,b,t,prod_constr_expr c bl)
- | CLocalAssum (idl,bk,t)::bl ->
- List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl
- (prod_constr_expr c bl)
- | CLocalPattern _::_ -> assert false
+ let mk loc b c = CLambdaN (loc,[b],c) in
+ expand_binders mk loc bll c
+
+(* Deprecated *)
+let abstract_constr_expr c bl = mkCLambdaN (local_binders_loc bl) bl c
+let prod_constr_expr c bl = mkCProdN (local_binders_loc bl) bl c
let coerce_reference_to_id = function
| Ident (_,id) -> id
diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli
index 45e3a19bc8..f6d97e107d 100644
--- a/interp/constrexpr_ops.mli
+++ b/interp/constrexpr_ops.mli
@@ -49,19 +49,19 @@ val mkLambdaC : Name.t located list * binder_kind * constr_expr * constr_expr ->
val mkLetInC : Name.t located * constr_expr * constr_expr option * constr_expr -> constr_expr
val mkProdC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr
-val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr
-val prod_constr_expr : constr_expr -> local_binder_expr list -> constr_expr
-
val mkCLambdaN : Loc.t -> local_binder_expr list -> constr_expr -> constr_expr
(** Same as [abstract_constr_expr], with location *)
val mkCProdN : Loc.t -> local_binder_expr list -> constr_expr -> constr_expr
(** Same as [prod_constr_expr], with location *)
+(** @deprecated variant of mkCLambdaN *)
+val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr
+
+(** @deprecated variant of mkCProdN *)
+val prod_constr_expr : constr_expr -> local_binder_expr list -> constr_expr
+
val fresh_var_hook : (Names.Id.t list -> Constrexpr.constr_expr -> Names.Id.t) Hook.t
-val expand_pattern_binders :
- (Loc.t -> local_binder_expr list -> constr_expr -> constr_expr) ->
- local_binder_expr list -> constr_expr -> local_binder_expr list * constr_expr
(** {6 Destructors}*)
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index f272d219aa..59b8b4e5b9 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -85,6 +85,20 @@ let without_specific_symbols l f =
(**********************************************************************)
(* Control printing of records *)
+(* Set Record Printing flag *)
+let record_print = ref true
+
+let _ =
+ let open Goptions in
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "record printing";
+ optkey = ["Printing";"Records"];
+ optread = (fun () -> !record_print);
+ optwrite = (fun b -> record_print := b) }
+
+
let is_record indsp =
try
let _ = Recordops.lookup_structure indsp in
@@ -658,7 +672,7 @@ let rec extern inctx scopes vars r =
()
else if PrintingConstructor.active (fst cstrsp) then
raise Exit
- else if not !Flags.record_print then
+ else if not !record_print then
raise Exit;
let projs = struc.Recordops.s_PROJ in
let locals = struc.Recordops.s_PROJKIND in
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index d75487ecf3..3f99a3c7c0 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -855,9 +855,9 @@ let intern_qualid loc qid intern env lvar us args =
| Some _, GApp (loc, GRef (loc', ref, None), arg) ->
GApp (loc, GRef (loc', ref, us), arg)
| Some _, _ ->
- user_err ~loc (str "Notation " ++ pr_qualid qid ++
- str " cannot have a universe instance, its expanded head
- does not start with a reference")
+ user_err ~loc (str "Notation " ++ pr_qualid qid
+ ++ str " cannot have a universe instance,"
+ ++ str " its expanded head does not start with a reference")
in
c, projapp, args2
@@ -2045,8 +2045,6 @@ let interp_binder_evars env evdref na t =
let t' = locate_if_hole (loc_of_glob_constr t) na t in
understand_tcc_evars env evdref ~expected_type:IsType t'
-open Environ
-
let my_intern_constr env lvar acc c =
internalize env acc false lvar c
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index 758d4e650b..fdd50c6a1e 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -18,7 +18,6 @@ open Constrexpr
open Notation_term
open Pretyping
open Misctypes
-open Decl_kinds
(** Translation from front abstract syntax of term to untyped terms (glob_constr) *)
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index 5ba26d8286..1facb47e1e 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.mli
@@ -19,7 +19,7 @@ open Util
(** [find_reference caller_message [dir;subdir;...] s] returns a global
reference to the name dir.subdir.(...).s; the corresponding module
must have been required or in the process of being compiled so that
- it must be used lazyly; it raises an anomaly with the given message
+ it must be used lazily; it raises an anomaly with the given message
if not found *)
type message = string
diff --git a/interp/notation.ml b/interp/notation.ml
index 90ac7f7296..6aa6f54c05 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -22,7 +22,6 @@ open Glob_ops
open Ppextend
open Context.Named.Declaration
-module NamedDecl = Context.Named.Declaration
(*i*)
(*s A scope is a set of notations; it includes
diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml
index 8b4fadb5a0..d08fb107be 100644
--- a/interp/notation_ops.ml
+++ b/interp/notation_ops.ml
@@ -1141,10 +1141,6 @@ let term_of_binder = function
| Name id -> GVar (Loc.ghost,id)
| Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)
-type glob_decl2 =
- (name, cases_pattern) Util.union * Decl_kinds.binding_kind *
- glob_constr option * glob_constr
-
let match_notation_constr u c (metas,pat) =
let terms,binders,termlists,binderlists =
match_ false u ([],[]) metas ([],[],[],[]) c pat in
diff --git a/interp/stdarg.ml b/interp/stdarg.ml
index 341ff5662c..5920b0d508 100644
--- a/interp/stdarg.ml
+++ b/interp/stdarg.ml
@@ -6,9 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Loc
open Misctypes
-open Tactypes
open Genarg
open Geninterp
diff --git a/interp/stdarg.mli b/interp/stdarg.mli
index 113fe40ba7..ac40a23281 100644
--- a/interp/stdarg.mli
+++ b/interp/stdarg.mli
@@ -10,7 +10,6 @@
open Loc
open Names
-open Term
open EConstr
open Libnames
open Globnames
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index c3f4c4f302..ed7b0b70d4 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -106,5 +106,3 @@ let search_syntactic_definition kn =
let def = out_pat pat in
verbose_compat kn def v;
def
-
-open Goptions
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 89e04b69d2..e05be65fb0 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -58,7 +58,9 @@ let rec cases_pattern_fold_names f a = function
| CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat
| CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a
| CPatPrim _ | CPatAtom _ -> a
- | CPatCast _ -> assert false
+ | CPatCast (loc,_,_) ->
+ CErrors.user_err ~loc ~hdr:"cases_pattern_fold_names"
+ (Pp.strbrk "Casts are not supported here.")
let ids_of_pattern =
cases_pattern_fold_names Id.Set.add Id.Set.empty
@@ -176,7 +178,12 @@ let split_at_annot bl na =
in
(List.rev ans, CLocalAssum (r, k, t) :: rest)
end
- | CLocalDef _ as x :: rest -> aux (x :: acc) rest
+ | CLocalDef ((_,na),_,_) as x :: rest ->
+ if Name.equal (Name id) na then
+ user_err ~loc
+ (Nameops.pr_id id ++ str" must be a proper parameter and not a local definition.")
+ else
+ aux (x :: acc) rest
| CLocalPattern (loc,_,_) :: rest ->
Loc.raise ~loc (Stream.Error "pattern with quote not allowed after fix")
| [] ->
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-08 04:23:39 +0000