aboutsummaryrefslogtreecommitdiff
path: root/interp/constrextern.ml
diff options
context:
space:
mode:
Diffstat (limited to 'interp/constrextern.ml')
-rw-r--r--interp/constrextern.ml70
1 files changed, 52 insertions, 18 deletions
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 19444988b9..c613effcd3 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -14,10 +14,10 @@ open CErrors
open Util
open Names
open Nameops
-open Constr
open Termops
open Libnames
open Globnames
+open Namegen
open Impargs
open CAst
open Constrexpr
@@ -29,7 +29,6 @@ open Pattern
open Nametab
open Notation
open Detyping
-open Misctypes
open Decl_kinds
module NamedDecl = Context.Named.Declaration
@@ -479,7 +478,8 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function
if is_inactive_rule keyrule then raise No_match;
let loc = t.loc in
match DAst.get t with
- | PatCstr (cstr,_,na) ->
+ | PatCstr (cstr,args,na) ->
+ let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in
let p = apply_notation_to_pattern ?loc (ConstructRef cstr)
(match_notation_constr_cases_pattern t pat) allscopes vars keyrule in
insert_pat_alias ?loc p na
@@ -590,11 +590,17 @@ let explicitize inctx impl (cf,f) args =
let expl () =
match ip with
| Some i ->
- if not (List.is_empty impl) && is_status_implicit (List.nth impl (i-1)) then
- raise Expl
+ (* Careful: It is possible to have declared implicits ending
+ before the principal argument *)
+ let is_impl =
+ try is_status_implicit (List.nth impl (i-1))
+ with Failure _ -> false
+ in
+ if is_impl
+ then raise Expl
else
let (args1,args2) = List.chop i args in
- let (impl1,impl2) = if List.is_empty impl then [],[] else List.chop i impl in
+ let (impl1,impl2) = try List.chop i impl with Failure _ -> impl, [] in
let args1 = exprec 1 (args1,impl1) in
let args2 = exprec (i+1) (args2,impl2) in
let ip = Some (List.length args1) in
@@ -714,7 +720,7 @@ let extended_glob_local_binder_of_decl loc = function
| (p,bk,None,t) -> GLocalAssum (p,bk,t)
| (p,bk,Some x, t) ->
match DAst.get t with
- | GHole (_, Misctypes.IntroAnonymous, None) -> GLocalDef (p,bk,x,None)
+ | GHole (_, IntroAnonymous, None) -> GLocalDef (p,bk,x,None)
| _ -> GLocalDef (p,bk,x,Some t)
let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u)
@@ -749,13 +755,13 @@ let rec extern inctx scopes vars r =
| GVar id -> CRef (make ?loc @@ Ident id,None)
- | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, Misctypes.IntroAnonymous, None)
+ | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None)
| GEvar (n,l) ->
extern_evar n (List.map (on_snd (extern false scopes vars)) l)
| GPatVar kind ->
- if !print_meta_as_hole then CHole (None, Misctypes.IntroAnonymous, None) else
+ if !print_meta_as_hole then CHole (None, IntroAnonymous, None) else
(match kind with
| Evar_kinds.SecondOrderPatVar n -> CPatVar n
| Evar_kinds.FirstOrderPatVar n -> CEvar (n,[]))
@@ -911,7 +917,7 @@ let rec extern inctx scopes vars r =
| GCast (c, c') ->
CCast (sub_extern true scopes vars c,
- Miscops.map_cast_type (extern_typ scopes vars) c')
+ map_cast_type (extern_typ scopes vars) c')
| GProj (p, c) ->
let pr = extern_reference ?loc Id.Set.empty (ConstRef (Projection.constant p)) in
CProj (pr, sub_extern inctx scopes vars c)
@@ -925,7 +931,7 @@ and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
and factorize_prod scopes vars na bk aty c =
let store, get = set_temporary_memory () in
match na, DAst.get c with
- | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns))
+ | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns))
when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 ->
(match get () with
| [{CAst.v=(ids,disj_of_patl,b)}] ->
@@ -953,7 +959,7 @@ and factorize_prod scopes vars na bk aty c =
and factorize_lambda inctx scopes vars na bk aty c =
let store, get = set_temporary_memory () in
match na, DAst.get c with
- | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns))
+ | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns))
when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 ->
(match get () with
| [{CAst.v=(ids,disj_of_patl,b)}] ->
@@ -1154,7 +1160,7 @@ let extern_closed_glob ?lax goal_concl_style env sigma t =
let any_any_branch =
(* | _ => _ *)
- CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None))
+ CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,IntroAnonymous,None))
let compute_displayed_name_in_pattern sigma avoid na c =
let open Namegen in
@@ -1178,7 +1184,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with
anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.")
with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in
GVar id
- | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None)
+ | PMeta None -> GHole (Evar_kinds.InternalHole, IntroAnonymous,None)
| PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n)
| PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None),
[glob_of_pat avoid env sigma c])
@@ -1203,7 +1209,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with
| PIf (c,b1,b2) ->
GIf (glob_of_pat avoid env sigma c, (Anonymous,None),
glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2)
- | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) ->
+ | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) ->
let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in
GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b)
| PCase (info,p,tm,bl) ->
@@ -1222,9 +1228,37 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with
return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p)
| _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.")
in
- GCases (RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat)
- | PFix f -> DAst.get (Detyping.detype_names false avoid env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *)
- | PCoFix c -> DAst.get (Detyping.detype_names false avoid env (Global.env()) sigma (EConstr.of_constr (mkCoFix c)))
+ GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat)
+ | PFix ((ln,i),(lna,tl,bl)) ->
+ let def_avoid, def_env, lfi =
+ Array.fold_left
+ (fun (avoid, env, l) na ->
+ let id = Namegen.next_name_away na avoid in
+ (Id.Set.add id avoid, Name id :: env, id::l))
+ (avoid, env, []) lna in
+ let n = Array.length tl in
+ let v = Array.map3
+ (fun c t i -> Detyping.share_pattern_names glob_of_pat (i+1) [] def_avoid def_env sigma c (Patternops.lift_pattern n t))
+ bl tl ln in
+ GRec(GFix (Array.map (fun i -> Some i, GStructRec) ln,i),Array.of_list (List.rev lfi),
+ Array.map (fun (bl,_,_) -> bl) v,
+ Array.map (fun (_,_,ty) -> ty) v,
+ Array.map (fun (_,bd,_) -> bd) v)
+ | PCoFix (ln,(lna,tl,bl)) ->
+ let def_avoid, def_env, lfi =
+ Array.fold_left
+ (fun (avoid, env, l) na ->
+ let id = Namegen.next_name_away na avoid in
+ (Id.Set.add id avoid, Name id :: env, id::l))
+ (avoid, env, []) lna in
+ let ntys = Array.length tl in
+ let v = Array.map2
+ (fun c t -> share_pattern_names glob_of_pat 0 [] def_avoid def_env sigma c (Patternops.lift_pattern ntys t))
+ bl tl in
+ GRec(GCoFix ln,Array.of_list (List.rev lfi),
+ Array.map (fun (bl,_,_) -> bl) v,
+ Array.map (fun (_,_,ty) -> ty) v,
+ Array.map (fun (_,bd,_) -> bd) v)
| PSort s -> GSort s
let extern_constr_pattern env sigma pat =
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 04:06:49 +0000