aboutsummaryrefslogtreecommitdiff
path: root/interp/constrextern.ml
diff options
context:
space:
mode:
Diffstat (limited to 'interp/constrextern.ml')
-rw-r--r--interp/constrextern.ml71
1 files changed, 49 insertions, 22 deletions
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index dd8a48b85e..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
@@ -94,8 +108,8 @@ let is_record indsp =
let encode_record r =
let indsp = global_inductive r in
if not (is_record indsp) then
- user_err_loc (loc_of_reference r,"encode_record",
- str "This type is not a structure type.");
+ user_err ~loc:(loc_of_reference r) ~hdr:"encode_record"
+ (str "This type is not a structure type.");
indsp
module PrintingRecordRecord =
@@ -598,6 +612,14 @@ let extern_optimal_prim_token scopes r r' =
| _ -> raise No_match
(**********************************************************************)
+(* mapping decl *)
+
+let extended_glob_local_binder_of_decl loc = function
+ | (p,bk,None,t) -> GLocalAssum (loc,p,bk,t)
+ | (p,bk,Some x,GHole (_, _, Misctypes.IntroAnonymous, None)) -> GLocalDef (loc,p,bk,x,None)
+ | (p,bk,Some x,t) -> GLocalDef (loc,p,bk,x,Some t)
+
+(**********************************************************************)
(* mapping glob_constr to constr_expr *)
let extern_glob_sort = function
@@ -650,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
@@ -692,8 +714,9 @@ let rec extern inctx scopes vars r =
explicitize loc inctx [] (None,sub_extern false scopes vars f)
(List.map (fun c -> lazy (sub_extern true scopes vars c)) args))
- | GLetIn (loc,na,t,c) ->
- CLetIn (loc,(loc,na),sub_extern false scopes vars t,
+ | GLetIn (loc,na,b,t,c) ->
+ CLetIn (loc,(loc,na),sub_extern false scopes vars b,
+ Option.map (extern_typ scopes vars) t,
extern inctx scopes (add_vname vars na) c)
| GProd (loc,na,bk,t,c) ->
@@ -756,7 +779,7 @@ let rec extern inctx scopes vars r =
let listdecl =
Array.mapi (fun i fi ->
let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
- let bl = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) bl in
+ let bl = List.map (extended_glob_local_binder_of_decl loc) bl in
let (assums,ids,bl) = extern_local_binder scopes vars bl in
let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in
let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in
@@ -773,7 +796,7 @@ let rec extern inctx scopes vars r =
| GCoFix n ->
let listdecl =
Array.mapi (fun i fi ->
- let bl = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) blv.(i) in
+ let bl = List.map (extended_glob_local_binder_of_decl loc) blv.(i) in
let (_,ids,bl) = extern_local_binder scopes vars bl in
let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in
let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in
@@ -817,33 +840,32 @@ and factorize_lambda inctx scopes vars na bk aty c =
and extern_local_binder scopes vars = function
[] -> ([],[],[])
- | (Inl na,bk,Some bd,ty)::l ->
+ | GLocalDef (_,na,bk,bd,ty)::l ->
let (assums,ids,l) =
extern_local_binder scopes (name_fold Id.Set.add na vars) l in
(assums,na::ids,
- LocalRawDef((Loc.ghost,na), extern false scopes vars bd) :: l)
+ CLocalDef((Loc.ghost,na), extern false scopes vars bd,
+ Option.map (extern false scopes vars) ty) :: l)
- | (Inl na,bk,None,ty)::l ->
+ | GLocalAssum (_,na,bk,ty)::l ->
let ty = extern_typ scopes vars ty in
(match extern_local_binder scopes (name_fold Id.Set.add na vars) l with
- (assums,ids,LocalRawAssum(nal,k,ty')::l)
+ (assums,ids,CLocalAssum(nal,k,ty')::l)
when constr_expr_eq ty ty' &&
match na with Name id -> not (occur_var_constr_expr id ty')
| _ -> true ->
(na::assums,na::ids,
- LocalRawAssum((Loc.ghost,na)::nal,k,ty')::l)
+ CLocalAssum((Loc.ghost,na)::nal,k,ty')::l)
| (assums,ids,l) ->
(na::assums,na::ids,
- LocalRawAssum([(Loc.ghost,na)],Default bk,ty) :: l))
-
- | (Inr p,bk,Some bd,ty)::l -> assert false
+ CLocalAssum([(Loc.ghost,na)],Default bk,ty) :: l))
- | (Inr p,bk,None,ty)::l ->
+ | GLocalPattern (_,(p,_),_,bk,ty)::l ->
let ty =
if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in
let p = extern_cases_pattern vars p in
let (assums,ids,l) = extern_local_binder scopes vars l in
- (assums,ids, LocalPattern(Loc.ghost,p,ty) :: l)
+ (assums,ids, CLocalPattern(Loc.ghost,p,ty) :: l)
and extern_eqn inctx scopes vars (loc,ids,pl,c) =
(loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl],
@@ -953,6 +975,7 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t =
(* Not "goal_concl_style" means do alpha-conversion avoiding only *)
(* those goal/section/rel variables that occurs in the subterm under *)
(* consideration; see namegen.ml for further details *)
+ let t = EConstr.of_constr t in
let avoid = if goal_concl_style then ids_of_context env else [] in
let r = Detyping.detype ~lax:lax goal_concl_style avoid env sigma t in
let vars = vars_of_env env in
@@ -965,6 +988,7 @@ let extern_constr ?(lax=false) goal_concl_style env sigma t =
extern_constr_gen lax goal_concl_style None env sigma t
let extern_type goal_concl_style env sigma t =
+ let t = EConstr.of_constr t in
let avoid = if goal_concl_style then ids_of_context env else [] in
let r = Detyping.detype goal_concl_style avoid env sigma t in
extern_glob_type (vars_of_env env) r
@@ -1015,8 +1039,9 @@ let rec glob_of_pat env sigma = function
List.map (glob_of_pat env sigma) args)
| PProd (na,t,c) ->
GProd (loc,na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c)
- | PLetIn (na,t,c) ->
- GLetIn (loc,na,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c)
+ | PLetIn (na,b,t,c) ->
+ GLetIn (loc,na,glob_of_pat env sigma b, Option.map (glob_of_pat env sigma) t,
+ glob_of_pat (na::env) sigma c)
| PLambda (na,t,c) ->
GLambda (loc,na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c)
| PIf (c,b1,b2) ->
@@ -1042,15 +1067,17 @@ let rec glob_of_pat env sigma = function
| _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive")
in
GCases (loc,RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat)
- | PFix f -> Detyping.detype_names false [] env (Global.env()) sigma (mkFix f) (** FIXME bad env *)
- | PCoFix c -> Detyping.detype_names false [] env (Global.env()) sigma (mkCoFix c)
+ | PFix f -> Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f)) (** FIXME bad env *)
+ | PCoFix c -> Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))
| PSort s -> GSort (loc,s)
let extern_constr_pattern env sigma pat =
extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat)
let extern_rel_context where env sigma sign =
+ let sign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) sign in
+ let where = Option.map EConstr.of_constr where in
let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in
let vars = vars_of_env env in
- let a = List.map (fun (p,bk,x,t) -> (Inl p,bk,x,t)) a in
+ let a = List.map (extended_glob_local_binder_of_decl Loc.ghost) a in
pi3 (extern_local_binder (None,[]) vars a)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 00:51:25 +0000