From b15e33515afef0d662d075201b5bcea5f760b6cc Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 30 Jan 2026 15:59:16 +0100 Subject: [PATCH 01/40] start adding indexed types --- src/ecAst.ml | 80 +++++++++++++++++------ src/ecAst.mli | 17 ++++- src/ecCoreFol.mli | 3 +- src/ecCoreSubst.ml | 31 +++++++-- src/ecFol.ml | 139 ++++++++++++++++++++++----------------- src/ecFol.mli | 2 +- src/ecInductive.ml | 19 +++--- src/ecSubst.ml | 78 +++++++++++++--------- src/ecTypes.ml | 157 +++++++++++++++++++++++++++++++-------------- src/ecTypes.mli | 26 +++++--- 10 files changed, 364 insertions(+), 188 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index aa9b6011ac..e7986162d1 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -54,9 +54,20 @@ and ty_node = | Tunivar of EcUid.uid | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * targs | Tfun of ty * ty +and tindex = + | TIVar of EcIdent.t + | TIConst of EcBigInt.zint + | TIAdd of tindex * tindex + | TIMul of tindex * tindex + +and targs = { + indices : tindex list; + types : ty list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -84,7 +95,7 @@ and expr_node = | Eint of BI.zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * targs (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -185,7 +196,7 @@ and f_node = | Flocal of EcIdent.t | Fpvar of prog_var * memory | Fglob of EcIdent.t * memory - | Fop of EcPath.path * ty list + | Fop of EcPath.path * targs | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -1054,10 +1065,41 @@ let pr_hash pr = (f_hash pr.pr_args) (Why3.Hashcons.combine (f_hash pr.pr_event.inv) (mem_hash pr.pr_event.m)) - (* ----------------------------------------------------------------- *) (* Hashconsing *) (* ----------------------------------------------------------------- *) +let rec tindex_equal (ti1 : tindex) (ti2 : tindex) : bool = + match ti1, ti2 with + | TIVar n1, TIVar n2 -> + EcIdent.id_equal n1 n2 + + | TIConst n1, TIConst n2 -> + EcBigInt.equal n1 n2 + + | TIAdd (l1, r1), TIAdd (l2, r2) + | TIMul (l1, r1), TIMul (l2, r2) -> + tindex_equal l1 l2 && tindex_equal r1 r2 + + | _, _ -> + false + +let targs_equal (ta1 : targs) (ta2 : targs) : bool = + List.all2 tindex_equal ta1.indices ta2.indices + && List.all2 ty_equal ta1.types ta2.types + +let targs_fv (ta : targs) = + List.fold_left + (fun ids ty -> fv_union ids (ty_fv ty)) + Mid.empty ta.types + +let tindex_hash (ti : tindex) = + Hashtbl.hash ti + +let targ_hash (init : int) (ta : targs) = + let aout = init in + let aout = Why3.Hashcons.combine_list ty_hash aout ta.types in + let aout = Why3.Hashcons.combine_list tindex_hash aout ta.indices in + aout module Hsty = Why3.Hashcons.Make (struct type t = ty @@ -1076,8 +1118,8 @@ module Hsty = Why3.Hashcons.Make (struct | Ttuple lt1, Ttuple lt2 -> List.all2 ty_equal lt1 lt2 - | Tconstr (p1, lt1), Tconstr (p2, lt2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lt1 lt2 + | Tconstr (p1, ta1), Tconstr (p2, ta2) -> + EcPath.p_equal p1 p2 && targs_equal ta1 ta2 | Tfun (d1, c1), Tfun (d2, c2)-> ty_equal d1 d2 && ty_equal c1 c2 @@ -1090,7 +1132,7 @@ module Hsty = Why3.Hashcons.Make (struct | Tunivar u -> u | Tvar id -> EcIdent.tag id | Ttuple tl -> Why3.Hashcons.combine_list ty_hash 0 tl - | Tconstr (p, tl) -> Why3.Hashcons.combine_list ty_hash p.p_tag tl + | Tconstr (p, ta) -> targ_hash p.p_tag ta | Tfun (t1, t2) -> Why3.Hashcons.combine (ty_hash t1) (ty_hash t2) let fv ty = @@ -1102,7 +1144,7 @@ module Hsty = Why3.Hashcons.Make (struct | Tunivar _ -> Mid.empty | Tvar _ -> Mid.empty (* FIXME: section *) | Ttuple tys -> union (fun a -> a.ty_fv) tys - | Tconstr (_, tys) -> union (fun a -> a.ty_fv) tys + | Tconstr (_, tas) -> targs_fv tas | Tfun (t1, t2) -> union (fun a -> a.ty_fv) [t1; t2] let tag n ty = { ty with ty_tag = n; ty_fv = fv ty.ty_node; } @@ -1127,9 +1169,8 @@ module Hexpr = Why3.Hashcons.Make (struct | Elocal x1, Elocal x2 -> EcIdent.id_equal x1 x2 | Evar x1, Evar x2 -> pv_equal x1 x2 - | Eop (p1, tys1), Eop (p2, tys2) -> - (EcPath.p_equal p1 p2) - && (List.all2 ty_equal tys1 tys2) + | Eop (p1, ta1), Eop (p2, ta2) -> + (EcPath.p_equal p1 p2) && targs_equal ta1 ta2 | Eapp (e1, es1), Eapp (e2, es2) -> (e_equal e1 e2) @@ -1172,9 +1213,8 @@ module Hexpr = Why3.Hashcons.Make (struct | Elocal x -> Hashtbl.hash x | Evar x -> pv_hash x - | Eop (p, tys) -> - Why3.Hashcons.combine_list ty_hash - (EcPath.p_hash p) tys + | Eop (p, ta) -> + targ_hash (EcPath.p_hash p) ta | Eapp (e, es) -> Why3.Hashcons.combine_list e_hash (e_hash e) es @@ -1211,7 +1251,7 @@ module Hexpr = Why3.Hashcons.Make (struct match e with | Eint _ -> Mid.empty - | Eop (_, tys) -> union (fun a -> a.ty_fv) tys + | Eop (_, ta) -> targs_fv ta | Evar v -> pv_fv v | Elocal id -> fv_singleton id | Eapp (e, es) -> union e_fv (e :: es) @@ -1262,8 +1302,8 @@ module Hsform = Why3.Hashcons.Make (struct | Fglob(mp1,m1), Fglob(mp2,m2) -> EcIdent.id_equal mp1 mp2 && EcIdent.id_equal m1 m2 - | Fop(p1,lty1), Fop(p2,lty2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lty1 lty2 + | Fop(p1,ta1), Fop(p2,ta2) -> + EcPath.p_equal p1 p2 && targs_equal ta1 ta2 | Fapp(f1,args1), Fapp(f2,args2) -> f_equal f1 f2 && List.all2 f_equal args1 args2 @@ -1317,8 +1357,8 @@ module Hsform = Why3.Hashcons.Make (struct | Fglob(mp, m) -> Why3.Hashcons.combine (EcIdent.id_hash mp) (EcIdent.id_hash m) - | Fop(p, lty) -> - Why3.Hashcons.combine_list ty_hash (EcPath.p_hash p) lty + | Fop(p, ta) -> + targ_hash (EcPath.p_hash p) ta | Fapp(f, args) -> Why3.Hashcons.combine_list f_hash (f_hash f) args @@ -1351,7 +1391,7 @@ module Hsform = Why3.Hashcons.Make (struct match f with | Fint _ -> Mid.empty - | Fop (_, tys) -> union (fun a -> a.ty_fv) tys + | Fop (_, ta) -> targs_fv ta | Fpvar (PVglob pv,m) -> EcPath.x_fv (fv_add m Mid.empty) pv | Fpvar (PVloc _,m) -> fv_add m Mid.empty | Fglob (mp,m) -> fv_add mp (fv_add m Mid.empty) diff --git a/src/ecAst.mli b/src/ecAst.mli index 6da2cff790..5524c56805 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -49,9 +49,20 @@ and ty_node = | Tunivar of EcUid.uid | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * targs | Tfun of ty * ty +and tindex = + | TIVar of EcIdent.t + | TIConst of EcBigInt.zint + | TIAdd of tindex * tindex + | TIMul of tindex * tindex + +and targs = { + indices : tindex list; + types : ty list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -79,7 +90,7 @@ and expr_node = | Eint of BI.zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * targs (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -180,7 +191,7 @@ and f_node = | Flocal of EcIdent.t | Fpvar of prog_var * memory | Fglob of EcIdent.t * memory - | Fop of EcPath.path * ty list + | Fop of EcPath.path * targs | Fapp of form * form list | Ftuple of form list | Fproj of form * int diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 0977a33a50..2787b1c9e5 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -93,7 +93,8 @@ val f_pvloc : variable -> memory -> ss_inv val f_glob : EcIdent.t -> memory -> ss_inv (* soft-constructors - common formulas constructors *) -val f_op : path -> EcTypes.ty list -> EcTypes.ty -> form +val f_op : path -> ?indices:tindex list -> ?tyargs:EcTypes.ty list -> EcTypes.ty -> form +val f_op_r : path -> targs -> EcTypes.ty -> form val f_app : form -> form list -> EcTypes.ty -> form val f_tuple : form list -> form val f_proj : form -> int -> EcTypes.ty -> form diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 161d7d3c7a..a929263bf9 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -181,6 +181,23 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s +(* -------------------------------------------------------------------- *) +let tindex_subst (s : f_subst) (ti : tindex) = + ti (* FIXME *) + +(* -------------------------------------------------------------------- *) +let targs_subst (s : f_subst) (ta : targs) : targs = + let indices = List.Smart.map (tindex_subst s) ta.indices in + let types = List.Smart.map (ty_subst s) ta.types in + + if indices == ta.indices && types == ta.types then + ta + else { indices; types } + +(* -------------------------------------------------------------------- *) +let targs_subst (s : f_subst) : targs -> targs = + if is_ty_subst_id s then identity else targs_subst s + (* -------------------------------------------------------------------- *) let is_e_subst_id (s : f_subst) = not s.fs_freshen @@ -255,10 +272,10 @@ let rec e_subst (s : f_subst) (e : expr) : expr = let ty' = ty_subst s e.e_ty in e_var pv' ty' - | Eop (p, tys) -> - let tys' = List.Smart.map (ty_subst s) tys in + | Eop (p, ta) -> + let ta' = targs_subst s ta in let ty' = ty_subst s e.e_ty in - e_op p tys' ty' + e_op_r p ta' ty' | Elet (lp, e1, e2) -> let e1' = e_subst s e1 in @@ -432,10 +449,10 @@ module Fsubst = struct f_local id ty' end - | Fop (p, tys) -> - let ty' = ty_subst s fp.f_ty in - let tys' = List.Smart.map (ty_subst s) tys in - f_op p tys' ty' + | Fop (p, ta) -> + let ty' = ty_subst s fp.f_ty in + let ta' = targs_subst s ta in + f_op_r p ta' ty' | Fpvar (pv, m) -> let pv' = pv_subst s pv in diff --git a/src/ecFol.ml b/src/ecFol.ml index 57322210d9..86f8fd9fa5 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -55,7 +55,7 @@ let ts_inv_eqglob mp1 ml mp2 mr = (* -------------------------------------------------------------------- *) let f_op_real_of_int = (* CORELIB *) - f_op CI.CI_Real.p_real_of_int [] (tfun tint treal) + f_op CI.CI_Real.p_real_of_int (tfun tint treal) let f_real_of_int f = f_app f_op_real_of_int [f] treal let f_rint n = f_real_of_int (f_int n) @@ -75,15 +75,15 @@ let destr_rint f = | _ -> destr_error "destr_rint" (* -------------------------------------------------------------------- *) -let fop_int_le = f_op CI.CI_Int .p_int_le [] (toarrow [tint ; tint ] tbool) -let fop_int_lt = f_op CI.CI_Int .p_int_lt [] (toarrow [tint ; tint ] tbool) -let fop_real_le = f_op CI.CI_Real.p_real_le [] (toarrow [treal; treal] tbool) -let fop_real_lt = f_op CI.CI_Real.p_real_lt [] (toarrow [treal; treal] tbool) -let fop_real_add = f_op CI.CI_Real.p_real_add [] (toarrow [treal; treal] treal) -let fop_real_opp = f_op CI.CI_Real.p_real_opp [] (toarrow [treal] treal) -let fop_real_mul = f_op CI.CI_Real.p_real_mul [] (toarrow [treal; treal] treal) -let fop_real_inv = f_op CI.CI_Real.p_real_inv [] (toarrow [treal] treal) -let fop_real_abs = f_op CI.CI_Real.p_real_abs [] (toarrow [treal] treal) +let fop_int_le = f_op CI.CI_Int .p_int_le (toarrow [tint ; tint ] tbool) +let fop_int_lt = f_op CI.CI_Int .p_int_lt (toarrow [tint ; tint ] tbool) +let fop_real_le = f_op CI.CI_Real.p_real_le (toarrow [treal; treal] tbool) +let fop_real_lt = f_op CI.CI_Real.p_real_lt (toarrow [treal; treal] tbool) +let fop_real_add = f_op CI.CI_Real.p_real_add (toarrow [treal; treal] treal) +let fop_real_opp = f_op CI.CI_Real.p_real_opp (toarrow [treal] treal) +let fop_real_mul = f_op CI.CI_Real.p_real_mul (toarrow [treal; treal] treal) +let fop_real_inv = f_op CI.CI_Real.p_real_inv (toarrow [treal] treal) +let fop_real_abs = f_op CI.CI_Real.p_real_abs (toarrow [treal] treal) let f_int_le f1 f2 = f_app fop_int_le [f1; f2] tbool let f_int_lt f1 f2 = f_app fop_int_lt [f1; f2] tbool @@ -119,25 +119,31 @@ let f_decimal (n, (l, f)) = else f_real_add (f_real_of_int (f_int n)) fct (* soft-constructor - xreal *) -let fop_xreal_le = f_op CI.CI_Xreal.p_xle [] (toarrow [txreal; txreal] tbool) +let fop_xreal_le = f_op CI.CI_Xreal.p_xle (toarrow [txreal; txreal] tbool) let fop_interp_ehoare_form = - f_op CI.CI_Xreal.p_interp_form [] (toarrow [tbool; txreal] txreal) + f_op CI.CI_Xreal.p_interp_form (toarrow [tbool; txreal] txreal) -let is_interp_ehoare_form_op (p, tys) = EcPath.p_equal p CI.CI_Xreal.p_interp_form && tys = [] +let is_interp_ehoare_form_op (p, ta) = + EcPath.p_equal p CI.CI_Xreal.p_interp_form + && List.is_empty ta.types + && List.is_empty ta.indices let fop_Ep ty = - f_op CI.CI_Xreal.p_Ep [ty] (toarrow [tdistr ty; toarrow [ty] txreal] txreal) + f_op + CI.CI_Xreal.p_Ep + ~tyargs:[ty] + (toarrow [tdistr ty; toarrow [ty] txreal] txreal) let f_xreal_le f1 f2 = f_app fop_xreal_le [f1; f2] tbool let f_interp_ehoare_form f1 f2 = f_app fop_interp_ehoare_form [f1; f2] txreal let f_Ep ty d f = f_app (fop_Ep ty) [d; f] txreal -let fop_concave_incr = f_op CI.CI_Xreal.p_concave_incr [] (tfun (tfun txreal txreal) tbool) +let fop_concave_incr = f_op CI.CI_Xreal.p_concave_incr (tfun (tfun txreal txreal) tbool) let f_concave_incr f = f_app fop_concave_incr [f] tbool -let f_op_rp2xr = f_op CI.CI_Xreal.p_rp [] (tfun trealp txreal) -let f_op_of_real = f_op CI.CI_Xreal.p_of_real [] (tfun treal trealp) +let f_op_rp2xr = f_op CI.CI_Xreal.p_rp (tfun trealp txreal) +let f_op_of_real = f_op CI.CI_Xreal.p_of_real (tfun treal trealp) let f_rp2xr f = f_app f_op_rp2xr [f] txreal let f_r2rp f = f_app f_op_of_real [f] trealp @@ -145,21 +151,22 @@ let f_r2xr f = f_rp2xr (f_r2rp f) let f_b2r b = f_if b f_r1 f_r0 let f_b2xr b = f_r2xr (f_b2r b) - -let f_xreal_inf = f_op CI.CI_Xreal.p_inf [] txreal +let f_xreal_inf = f_op CI.CI_Xreal.p_inf txreal (* -------------------------------------------------------------------- *) -let tmap aty bty = - tconstr CI.CI_Map.p_map [aty; bty] +let tmap (aty : ty) (bty : ty) = + tconstr ~tyargs:[aty; bty] ?indices:None CI.CI_Map.p_map -let fop_map_cst aty bty = - f_op CI.CI_Map.p_cst [aty; bty] (toarrow [bty] (tmap aty bty)) +let fop_map_cst (aty : ty) (bty : ty) = + f_op CI.CI_Map.p_cst ~tyargs:[aty; bty] + (toarrow [bty] (tmap aty bty)) let fop_map_get aty bty = - f_op CI.CI_Map.p_get [aty; bty] (toarrow [tmap aty bty; aty] bty) + f_op CI.CI_Map.p_get ~tyargs:[aty; bty] + (toarrow [tmap aty bty; aty] bty) let fop_map_set aty bty = - f_op CI.CI_Map.p_set [aty; bty] + f_op CI.CI_Map.p_set ~tyargs:[aty; bty] (toarrow [tmap aty bty; aty; bty] (tmap aty bty)) let f_map_cst aty f = @@ -172,59 +179,73 @@ let f_map_set m x e = f_app (fop_map_set x.f_ty e.f_ty) [m;x;e] (tmap x.f_ty e.f_ty) (* -------------------------------------------------------------------- *) -let f_predT ty = f_op CI.CI_Pred.p_predT [ty] (tcpred ty) -let fop_pred1 ty = f_op CI.CI_Pred.p_pred1 [ty] (toarrow [ty; ty] tbool) +let f_predT (ty : ty) = + f_op CI.CI_Pred.p_predT ~tyargs:[ty] (tcpred ty) + +let fop_pred1 (ty : ty) = + f_op CI.CI_Pred.p_pred1 ~tyargs:[ty] (tfun ty (tcpred ty)) + +let fop_support (ty : ty) = + f_op CI.CI_Distr.p_support ~tyargs:[ty] + (toarrow [tdistr ty; ty] tbool) + +let fop_mu (ty : ty) = + f_op CI.CI_Distr.p_mu ~tyargs:[ty] + (toarrow [tdistr ty; tcpred ty] treal) + +let fop_lossless (ty : ty) = + f_op CI.CI_Distr.p_lossless ~tyargs:[ty] + (toarrow [tdistr ty] tbool) + +let f_support (f1 : form) (f2 : form) = + f_app (fop_support f2.f_ty) [f1; f2] tbool -let fop_support ty = - f_op CI.CI_Distr.p_support [ty] (toarrow [tdistr ty; ty] tbool) -let fop_mu ty = - f_op CI.CI_Distr.p_mu [ty] (toarrow [tdistr ty; tcpred ty] treal) -let fop_lossless ty = - f_op CI.CI_Distr.p_lossless [ty] (toarrow [tdistr ty] tbool) +let f_in_supp (f1 : form) (f2 : form) = + f_support f2 f1 -let f_support f1 f2 = f_app (fop_support f2.f_ty) [f1; f2] tbool -let f_in_supp f1 f2 = f_support f2 f1 -let f_pred1 f1 = f_app (fop_pred1 f1.f_ty) [f1] (toarrow [f1.f_ty] tbool) +let f_pred1 (f1 : form) = + f_app (fop_pred1 f1.f_ty) [f1] (toarrow [f1.f_ty] tbool) -let f_mu_x f1 f2 = +let f_mu_x (f1 : form) (f2 : form) = f_app (fop_mu f2.f_ty) [f1; (f_pred1 f2)] treal -let proj_distr_ty env ty = +let proj_distr_ty (env : EcEnv.env) (ty : ty) = match (EcEnv.Ty.hnorm ty env).ty_node with - | Tconstr(_,lty) when List.length lty = 1 -> - List.hd lty + | Tconstr(p, { indices = []; types = [dom] }) + when EcPath.p_equal p EcCoreLib.CI_Distr.p_Distr -> + dom | _ -> assert false -let f_mu env f1 f2 = +let f_mu (env : EcEnv.env) (f1 : form) (f2 : form) = f_app (fop_mu (proj_distr_ty env f1.f_ty)) [f1; f2] treal -let f_weight ty d = +let f_weight (ty : ty) (d : form) = f_app (fop_mu ty) [d; f_predT ty] treal -let f_lossless ty d = +let f_lossless (ty : ty) (d : form) = f_app (fop_lossless ty) [d] tbool (* -------------------------------------------------------------------- *) -let fop_dunit ty = - f_op EcCoreLib.CI_Distr.p_dunit [ty] (tfun ty (tdistr ty)) +let fop_dunit (ty : ty) = + f_op EcCoreLib.CI_Distr.p_dunit ~tyargs:[ty] (tfun ty (tdistr ty)) -let f_dunit f = +let f_dunit (f : form) = f_app (fop_dunit f.f_ty) [f] (tdistr f.f_ty) (* -------------------------------------------------------------------- *) -let fop_dmap tya tyb = - f_op EcCoreLib.CI_Distr.p_dmap [tya; tyb] +let fop_dmap (tya : ty) (tyb : ty) = + f_op EcCoreLib.CI_Distr.p_dmap ~tyargs:[tya; tyb] (toarrow [tdistr tya; tfun tya tyb] (tdistr tyb)) -let f_dmap tya tyb d f = +let f_dmap (tya : ty) (tyb : ty) (d : form) (f : form) = f_app (fop_dmap tya tyb) [d; f] (tdistr tyb) (* -------------------------------------------------------------------- *) -let fop_dlet tya tyb = - f_op EcCoreLib.CI_Distr.p_dlet [tya; tyb] +let fop_dlet (tya : ty) (tyb : ty) = + f_op EcCoreLib.CI_Distr.p_dlet ~tyargs:[tya; tyb] (toarrow [tdistr tya; tfun tya (tdistr tyb)] (tdistr tyb)) -let f_dlet tya tyb d f = +let f_dlet (tya : ty) (tyb : ty) (d : form) (f : form) = f_app (fop_dlet tya tyb) [d; f] (tdistr tyb) (* -------------------------------------------------------------------- *) @@ -716,8 +737,8 @@ let rec f_iff_simpl f1 f2 = else if is_false f2 then f_not_simpl f1 else match f1.f_node, f2.f_node with - | Fapp ({f_node = Fop (op1, [])}, [f1]), - Fapp ({f_node = Fop (op2, [])}, [f2]) when + | Fapp ({f_node = Fop (op1, _)}, [f1]), + Fapp ({f_node = Fop (op2, _)}, [f2]) when (EcPath.p_equal op1 CI.CI_Bool.p_not && EcPath.p_equal op2 CI.CI_Bool.p_not) -> f_iff_simpl f1 f2 @@ -740,7 +761,7 @@ let rec f_eq_simpl f1 f2 = when f_equal op1 f_op_real_of_int && f_equal op2 f_op_real_of_int -> f_false - | Fop (op1, []), Fop (op2, []) when + | Fop (op1, _), Fop (op2, _) when (EcPath.p_equal op1 CI.CI_Bool.p_true && EcPath.p_equal op2 CI.CI_Bool.p_false ) || (EcPath.p_equal op2 CI.CI_Bool.p_true && @@ -854,7 +875,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (EcPath.path * ty list) * (form list) + | SFop of (EcPath.path * targs) * (form list) | SFhoareF of sHoareF | SFhoareS of sHoareS @@ -922,10 +943,10 @@ let int_of_form = | SFint x -> x - | SFop ((op, []), [a]) when op_kind op = Some `Int_opp -> + | SFop ((op, _), [a]) when op_kind op = Some `Int_opp -> BI.neg (doit a) - | SFop ((op, []), [a1; a2]) -> begin + | SFop ((op, _), [a1; a2]) -> begin match op_kind op with | Some `Int_add -> BI.add (doit a1) (doit a2) | Some `Int_mul -> BI.mul (doit a1) (doit a2) @@ -938,7 +959,7 @@ let int_of_form = let real_of_form f = match sform_of_form f with - | SFop ((op, []), [a]) -> + | SFop ((op, _), [a]) -> if EcPath.p_equal op CI.CI_Real.p_real_of_int then int_of_form a else None diff --git a/src/ecFol.mli b/src/ecFol.mli index 080a4d3dea..ab54996a92 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -226,7 +226,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (path * ty list) * (form list) + | SFop of (path * targs) * (form list) | SFhoareF of sHoareF | SFhoareS of sHoareS diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 81f3be80d8..ef0efc5c0f 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -39,7 +39,7 @@ let datatype_proj_path (p : EP.path) (x : symbol) = (* -------------------------------------------------------------------- *) let indsc_of_record (rc : record) = let targs = List.map tvar rc.rc_tparams in - let recty = tconstr rc.rc_path targs in + let recty = tconstr_r rc.rc_path targs in let recx = fresh_id_of_ty recty in let recfm = FL.f_local recx recty in let predty = tfun recty tbool in @@ -158,12 +158,13 @@ and check_positivity_ident fct p params ident ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_ident fct p params ident) tys | Tconstr (q, args) when EcPath.p_equal q p -> - if not (ty_params_compat args params) then + assert (List.is_empty args.indexes); + if not (ty_params_compat args.types params) then non_positive p (TypePositionRestriction ty) | Tconstr (q, args) -> let decl = fct q in - List.iter (check_positivity_ident fct p params ident) args; - List.combine args decl.tyd_params + List.iter (check_positivity_ident fct p params ident) args.types; + List.combine args.types decl.tyd_params |> List.filter_map (fun (arg, ident') -> if EcTypes.var_mem ident arg then Some ident' else None) |> List.iter (check_positivity_in_decl fct q decl) @@ -177,12 +178,14 @@ let rec check_positivity_path fct p ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_path fct p) tys | Tconstr (q, args) when EcPath.p_equal q p -> - if List.exists (occurs p) args then non_positive p (NonPositiveOcc ty) + assert (List.is_empty args.indexes); + if List.exists (occurs p) args.types then + non_positive p (NonPositiveOcc ty) | Tconstr (q, args) -> let decl = fct q in - List.iter (check_positivity_path fct p) args; - List.combine args decl.tyd_params - |> List.filter_map (fun (arg, ident) -> + List.iter (check_positivity_path fct p) args.types; + List.combine args.types decl.tyd_params + |> List.filter_map (fun (arg, ident)) -> if occurs p arg then Some ident else None) |> List.iter (check_positivity_in_decl fct q decl) | Tfun (from, to_) -> diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 9084b32812..826ba54590 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -149,6 +149,10 @@ let add_tyvar (s : subst) (x : EcIdent.t) (ty : ty) = let add_tyvars (s : subst) (xs : EcIdent.t list) (tys : ty list) = List.fold_left2 add_tyvar s xs tys +(* -------------------------------------------------------------------- *) +let subst_tindex (_s : subst) (ti : tindex) = + ti + (* -------------------------------------------------------------------- *) let rec subst_ty (s : subst) (ty : ty) = match ty.ty_node with @@ -162,17 +166,17 @@ let rec subst_ty (s : subst) (ty : ty) = Mid.find_def ty a s.sb_tyvar | Ttuple tys -> - ttuple (subst_tys s tys) + ttuple (List.map (subst_ty s) tys) - | Tconstr (p, tys) -> begin - let tys = subst_tys s tys in + | Tconstr (p, ta) -> begin + let ta = subst_targs s ta in match Mp.find_opt p s.sb_tydef with | None -> - tconstr (subst_path s p) tys + tconstr_r (subst_path s p) ta | Some (args, body) -> - let s = List.fold_left2 add_tyvar empty args tys in + let s = List.fold_left2 add_tyvar empty args ta.types in subst_ty s body end @@ -180,8 +184,10 @@ let rec subst_ty (s : subst) (ty : ty) = tfun (subst_ty s t1) (subst_ty s t2) (* -------------------------------------------------------------------- *) -and subst_tys (s : subst) (tys : ty list) = - List.map (subst_ty s) tys +and subst_targs (s : subst) (ta : targs) : targs = + let types = List.map (subst_ty s) ta.types in + let indices = List.map (subst_tindex s) ta.indices in + { types; indices; } (* -------------------------------------------------------------------- *) let add_module (s : subst) (x : EcIdent.t) (m : EcPath.mpath) = @@ -327,24 +333,24 @@ let rec subst_expr (s : subst) (e : expr) = | Evar pv -> e_var (subst_progvar s pv) (subst_ty s e.e_ty) - | Eapp ({ e_node = Eop (p, tys) }, args) when has_opdef s p -> - let tys = subst_tys s tys in + | Eapp ({ e_node = Eop (p, ta) }, args) when has_opdef s p -> + let ta = subst_targs s ta in let ty = subst_ty s e.e_ty in let body = oget (get_opdef s p) in let args = List.map (subst_expr s) args in - subst_eop ty tys args body + subst_eop ty ta args body - | Eop (p, tys) when has_opdef s p -> - let tys = subst_tys s tys in + | Eop (p, ta) when has_opdef s p -> + let ta = subst_targs s ta in let ty = subst_ty s e.e_ty in let body = oget (get_opdef s p) in - subst_eop ty tys [] body + subst_eop ty ta [] body - | Eop (p, tys) -> - let p = subst_path s p in - let tys = subst_tys s tys in - let ty = subst_ty s e.e_ty in - e_op p tys ty + | Eop (p, ta) -> + let p = subst_path s p in + let ta = subst_targs s ta in + let ty = subst_ty s e.e_ty in + e_op_r p ta ty | Elet (lp, e1, e2) -> let e1 = subst_expr s e1 in @@ -360,8 +366,13 @@ let rec subst_expr (s : subst) (e : expr) = | _ -> e_map (subst_ty s) (subst_expr s) e (* -------------------------------------------------------------------- *) -and subst_eop ety tys args (tyids, e) = - let s = add_tyvars empty tyids tys in +and subst_eop + (ety : ty) + (ta : targs) + (args : expr list) + ((tyids, e) : EcIdent.t list * expr) += + let s = add_tyvars empty tyids ta.types in let (s, args, e) = match e.e_node with @@ -510,24 +521,24 @@ let rec subst_form (s : subst) (f : form) = let m = subst_mem s m in (f_glob mp m).inv - | Fapp ({ f_node = Fop (p, tys) }, args) when has_def s p -> - let tys = subst_tys s tys in + | Fapp ({ f_node = Fop (p, ta) }, args) when has_def s p -> + let ta = subst_targs s ta in let ty = subst_ty s f.f_ty in let body = oget (get_def s p) in let args = List.map (subst_form s) args in - subst_fop ty tys args body + subst_fop ty ta args body - | Fop (p, tys) when has_def s p -> - let tys = subst_tys s tys in + | Fop (p, ta) when has_def s p -> + let ta = subst_targs s ta in let ty = subst_ty s f.f_ty in let body = oget (get_def s p) in - subst_fop ty tys [] body + subst_fop ty ta [] body - | Fop (p, tys) -> + | Fop (p, ta) -> let p = subst_path s p in - let tys = subst_tys s tys in + let ta = subst_targs s ta in let ty = subst_ty s f.f_ty in - f_op p tys ty + f_op_r p ta ty | FhoareF hf -> let hf_f = subst_xpath s hf.hf_f in @@ -614,8 +625,13 @@ let rec subst_form (s : subst) (f : form) = f_map (subst_ty s) (subst_form s) f (* -------------------------------------------------------------------- *) -and subst_fop fty tys args (tyids, f) = - let s = add_tyvars empty tyids tys in +and subst_fop + (fty : ty) + (ta : targs) + (args : form list) + ((tyids, f) : EcIdent.t list * form) += + let s = add_tyvars empty tyids ta.types in let (s, args, f) = match f.f_node with diff --git a/src/ecTypes.ml b/src/ecTypes.ml index bebd2087e2..ee196d1f03 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -16,10 +16,14 @@ let local_of_locality = function | `Declare -> `Local (* -------------------------------------------------------------------- *) -type ty = EcAst.ty +type ty = EcAst.ty type ty_node = EcAst.ty_node +type tindex = EcAst.tindex +type targs = EcAst.targs +type dom = ty list -type dom = ty list +let mk_targs ?(indices : tindex list = []) ?(types : ty list = []) () = + { indices; types; } let ty_equal = EcAst.ty_equal let ty_hash = EcAst.ty_hash @@ -36,7 +40,22 @@ module Sty = MSHty.S module Hty = MSHty.H (* -------------------------------------------------------------------- *) -let rec dump_ty ty = +let rec dump_tindex (ti : tindex) = + match ti with + | TIVar x -> + EcIdent.tostring_internal x + + | TIConst i -> + EcBigInt.to_string i + + | TIAdd (l, r) -> + Format.sprintf "(%s + %s)" (dump_tindex l) (dump_tindex r) + + | TIMul (l, r) -> + Format.sprintf "(%s + %s)" (dump_tindex l) (dump_tindex r) + +(* -------------------------------------------------------------------- *) +let rec dump_ty (ty : ty) = match ty.ty_node with | Tglob p -> EcIdent.tostring_internal p @@ -50,33 +69,48 @@ let rec dump_ty ty = | Ttuple tys -> Printf.sprintf "(%s)" (String.concat ", " (List.map dump_ty tys)) - | Tconstr (p, tys) -> - Printf.sprintf "%s[%s]" (EcPath.tostring p) - (String.concat ", " (List.map dump_ty tys)) + | Tconstr (p, ta) -> + let indices = List.map dump_tindex ta.indices in + let types = List.map dump_ty ta.types in + Printf.sprintf "%s[%s|%s]" (EcPath.tostring p) + (String.concat ", " indices) + (String.concat ", " types) | Tfun (t1, t2) -> Printf.sprintf "(%s) -> (%s)" (dump_ty t1) (dump_ty t2) (* -------------------------------------------------------------------- *) -let tuni uid = mk_ty (Tunivar uid) -let tvar id = mk_ty (Tvar id) -let tconstr p lt = mk_ty (Tconstr (p, lt)) -let tfun t1 t2 = mk_ty (Tfun (t1, t2)) -let tglob m = mk_ty (Tglob m) +let tuni (uid : EcUid.uid) = + mk_ty (Tunivar uid) + +let tvar (id : ident) = + mk_ty (Tvar id) + +let tconstr_r (p : path) (ta : targs) = + mk_ty (Tconstr (p, ta)) + +let tconstr ?(indices : tindex list option) ?(tyargs : ty list option) (p : path) = + tconstr_r p (mk_targs ?indices ?types:tyargs ()) + +let tfun (t1 : ty) (t2 : ty) = + mk_ty (Tfun (t1, t2)) + +let tglob (m : memory) = + mk_ty (Tglob m) (* -------------------------------------------------------------------- *) -let tunit = tconstr EcCoreLib.CI_Unit .p_unit [] -let tbool = tconstr EcCoreLib.CI_Bool .p_bool [] -let tint = tconstr EcCoreLib.CI_Int .p_int [] -let txint = tconstr EcCoreLib.CI_xint .p_xint [] - -let tdistr ty = tconstr EcCoreLib.CI_Distr.p_distr [ty] -let toption ty = tconstr EcCoreLib.CI_Option.p_option [ty] -let treal = tconstr EcCoreLib.CI_Real .p_real [] +let tunit = tconstr EcCoreLib.CI_Unit .p_unit +let tbool = tconstr EcCoreLib.CI_Bool .p_bool +let tint = tconstr EcCoreLib.CI_Int .p_int +let txint = tconstr EcCoreLib.CI_xint .p_xint + +let tdistr ty = tconstr ~tyargs:[ty] EcCoreLib.CI_Distr.p_distr +let toption ty = tconstr ~tyargs:[ty] EcCoreLib.CI_Option.p_option +let treal = tconstr EcCoreLib.CI_Real.p_real let tcpred ty = tfun ty tbool -let trealp = tconstr EcCoreLib.CI_Xreal.p_realp [] -let txreal = tconstr EcCoreLib.CI_Xreal.p_xreal [] +let trealp = tconstr EcCoreLib.CI_Xreal.p_realp +let txreal = tconstr EcCoreLib.CI_Xreal.p_xreal let ttuple lt = match lt with @@ -103,7 +137,7 @@ let rec tyfun_flat (ty : ty) = (* -------------------------------------------------------------------- *) let as_tdistr (ty : ty) = match ty.ty_node with - | Tconstr (p, [sty]) + | Tconstr (p, { indices = []; types = [sty] }) when EcPath.p_equal p EcCoreLib.CI_Distr.p_distr -> Some sty @@ -117,11 +151,13 @@ let ty_map f t = | Tglob _ | Tunivar _ | Tvar _ -> t | Ttuple lty -> - ttuple (List.Smart.map f lty) + ttuple (List.Smart.map f lty) - | Tconstr (p, lty) -> - let lty = List.Smart.map f lty in - tconstr p lty + | Tconstr (p, ta) -> + let ta = + { indices = ta.indices + ; types = List.Smart.map f ta.types } + in tconstr_r p ta | Tfun (t1, t2) -> tfun (f t1) (f t2) @@ -130,21 +166,21 @@ let ty_fold f s ty = match ty.ty_node with | Tglob _ | Tunivar _ | Tvar _ -> s | Ttuple lty -> List.fold_left f s lty - | Tconstr(_, lty) -> List.fold_left f s lty + | Tconstr (_, ta) -> List.fold_left f s ta.types | Tfun(t1,t2) -> f (f s t1) t2 let ty_sub_exists f t = match t.ty_node with | Tglob _ | Tunivar _ | Tvar _ -> false | Ttuple lty -> List.exists f lty - | Tconstr (_, lty) -> List.exists f lty + | Tconstr (_, ta) -> List.exists f ta.types | Tfun (t1, t2) -> f t1 || f t2 let ty_iter f t = match t.ty_node with | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple lty -> List.iter f lty - | Tconstr (_, lty) -> List.iter f lty + | Tconstr (_, ta) -> List.iter f ta.types | Tfun (t1,t2) -> f t1; f t2 exception FoundUnivar @@ -343,13 +379,34 @@ let eqt_equal = EcAst.eqt_equal (* -------------------------------------------------------------------- *) -let e_tt = mk_expr (Eop (EcCoreLib.CI_Unit.p_tt, [])) tunit -let e_int = fun i -> mk_expr (Eint i) tint -let e_local = fun x ty -> mk_expr (Elocal x) ty -let e_var = fun x ty -> mk_expr (Evar x) ty -let e_op = fun x targs ty -> mk_expr (Eop (x, targs)) ty -let e_let = fun pt e1 e2 -> mk_expr (Elet (pt, e1, e2)) e2.e_ty -let e_tuple = fun es -> +let e_int (i : BI.zint) = + mk_expr (Eint i) tint + +let e_local (x : memory) (ty : ty) = + mk_expr (Elocal x) ty + +let e_var (x : prog_var) (ty : ty) = + mk_expr (Evar x) ty + +let e_op_r (p : path) (ta : targs) (resty : ty) = + mk_expr (Eop (p, ta)) resty + + + let e_op + (p : path) + ?(indices : tindex list option) + ?(tyargs : ty list option) + (resty : ty) += + e_op_r p (mk_targs ?indices ?types:tyargs ()) resty + +let e_let (pt : lpattern) (e1 : expr) (e2 : expr) = + mk_expr (Elet (pt, e1, e2)) e2.e_ty + +let e_tt : expr = + e_op EcCoreLib.CI_Unit.p_tt tunit + +let e_tuple (es : expr list) = match es with | [] -> e_tt | [x] -> x @@ -390,8 +447,9 @@ let e_app x args ty = | Eapp(x', args') -> mk_expr (Eapp (x', (args'@args))) ty | _ -> mk_expr (Eapp (x, args)) ty -let e_app_op ?(tyargs=[]) op args ty = - e_app (e_op op tyargs (toarrow (List.map e_ty args) ty)) args ty +let e_app_op ?indices ?tyargs op args ty = + let arrowty = toarrow (List.map e_ty args) ty in + e_app (e_op op ?indices ?tyargs arrowty) args ty (* -------------------------------------------------------------------- *) module Reals : sig @@ -433,14 +491,13 @@ let e_decimal (n, (l, f)) = (* -------------------------------------------------------------------- *) let e_none (ty : ty) : expr = - e_op EcCoreLib.CI_Option.p_none [ty] (toption ty) + e_op ~tyargs:[ty] EcCoreLib.CI_Option.p_none (toption ty) let e_some ({ e_ty = ty } as e : expr) : expr = - let op = e_op EcCoreLib.CI_Option.p_some [ty] (tfun ty (toption ty)) in - e_app op [e] (toption ty) + e_app_op ~tyargs:[ty] EcCoreLib.CI_Option.p_some [e] (toption ty) let e_oget (e : expr) (ty : ty) : expr = - let op = e_op EcCoreLib.CI_Option.p_oget [ty] (tfun (toption ty) ty) in + let op = e_op ~tyargs:[ty] EcCoreLib.CI_Option.p_oget (tfun (toption ty) ty) in e_app op [e] ty (* -------------------------------------------------------------------- *) @@ -448,25 +505,27 @@ let e_map fty fe e = match e.e_node with | Eint _ | Elocal _ | Evar _ -> e - | Eop (p, tys) -> - let tys' = List.Smart.map fty tys in - let ty' = fty e.e_ty in - e_op p tys' ty' + | Eop (p, ta) -> + let ta' = + { indices = ta.indices + ; types = List.Smart.map fty ta.types } in + let ty' = fty e.e_ty in + e_op_r p ta' ty' | Eapp (e1, args) -> let e1' = fe e1 in let args' = List.Smart.map fe args in let ty' = fty e.e_ty in - e_app e1' args' ty' + e_app e1' args' ty' | Elet (lp, e1, e2) -> let e1' = fe e1 in let e2' = fe e2 in - e_let lp e1' e2' + e_let lp e1' e2' | Etuple le -> let le' = List.Smart.map fe le in - e_tuple le' + e_tuple le' | Eproj (e1, i) -> let e' = fe e1 in diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 95ee26bb3c..ce7bb091c9 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -13,9 +13,15 @@ type is_local = [ `Local | `Global ] val local_of_locality : locality -> is_local (* -------------------------------------------------------------------- *) -type ty = EcAst.ty +type ty = EcAst.ty type ty_node = EcAst.ty_node +type tindex = EcAst.tindex +type targs = EcAst.targs +(* -------------------------------------------------------------------- *) +val mk_targs : ?indices:tindex list -> ?tyargs:ty list -> unit -> targs + +(* -------------------------------------------------------------------- *) module Mty : Map.S with type key = ty module Sty : Set.S with module M = Map.MakeBase(Mty) module Hty : EcMaps.EHashtbl.S with type key = ty @@ -27,13 +33,14 @@ val dump_ty : ty -> string val ty_equal : ty -> ty -> bool val ty_hash : ty -> int -val tuni : EcUid.uid -> ty -val tvar : EcIdent.t -> ty -val ttuple : ty list -> ty -val tconstr : EcPath.path -> ty list -> ty -val tfun : ty -> ty -> ty -val tglob : EcIdent.t -> ty -val tpred : ty -> ty +val tuni : EcUid.uid -> ty +val tvar : EcIdent.t -> ty +val ttuple : ty list -> ty +val tconstr : EcPath.path -> ?indices:tindex list -> ?tyargs:ty list -> ty +val tconstr_r : EcPath.path -> targs -> ty +val tfun : ty -> ty -> ty +val tglob : EcIdent.t -> ty +val tpred : ty -> ty val ty_fv_and_tvar : ty -> int Mid.t @@ -173,7 +180,8 @@ val e_int : zint -> expr val e_decimal : zint * (int * zint) -> expr val e_local : EcIdent.t -> ty -> expr val e_var : prog_var -> ty -> expr -val e_op : EcPath.path -> ty list -> ty -> expr +val e_op : EcPath.path -> ?indices:tindex list -> ?tyargs:ty list -> ty -> expr +val e_op_r : EcPath.path -> targs -> ty -> expr val e_app : expr -> expr list -> ty -> expr val e_let : lpattern -> expr -> expr -> expr val e_tuple : expr list -> expr From c413f37af18c05407520225babbf382ae13e63c9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 4 Feb 2026 12:13:57 +0100 Subject: [PATCH 02/40] WIP --- src/ecAlgebra.ml | 2 +- src/ecAst.mli | 5 +- src/ecCoreFol.ml | 107 ++++++++++++++++++++++++++---------------- src/ecCoreFol.mli | 4 +- src/ecCoreSubst.ml | 2 +- src/ecCoreSubst.mli | 3 +- src/ecDecl.ml | 66 +++++++++++++++++--------- src/ecDecl.mli | 7 ++- src/ecEnv.mli | 4 +- src/ecProcSem.ml | 18 +++---- src/ecReduction.ml | 80 ++++++++++++++++++++----------- src/ecReduction.mli | 1 + src/ecTypes.mli | 4 +- src/ecUnify.ml | 10 ++-- src/phl/ecPhlWhile.ml | 4 +- 15 files changed, 200 insertions(+), 117 deletions(-) diff --git a/src/ecAlgebra.ml b/src/ecAlgebra.ml index 2cd7f1aa7f..153eb6cefe 100644 --- a/src/ecAlgebra.ml +++ b/src/ecAlgebra.ml @@ -75,7 +75,7 @@ type eq = form * form (* -------------------------------------------------------------------- *) let rapp r op args = let opty = toarrow (List.map f_ty args) r.r_type in - f_app (f_op op [] opty) args r.r_type + f_app (f_op op opty) args r.r_type let rzero r = rapp r r.r_zero [] let rone r = rapp r r.r_one [] diff --git a/src/ecAst.mli b/src/ecAst.mli index 5524c56805..c9de5f4aba 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -27,7 +27,6 @@ type quantif = type hoarecmp = FHle | FHeq | FHge (* -------------------------------------------------------------------- *) - type 'a use_restr = { ur_pos : 'a option; (* If not None, can use only element in this set. *) ur_neg : 'a; (* Cannot use element in this set. *) @@ -103,7 +102,6 @@ and ebinding = EcIdent.t * ty and ebindings = ebinding list (* -------------------------------------------------------------------- *) - and lvalue = | LvVar of (prog_var * ty) | LvTuple of (prog_var * ty) list @@ -420,6 +418,9 @@ type 'a equality = 'a -> 'a -> bool type 'a hash = 'a -> int type 'a fv = 'a -> int EcIdent.Mid.t +val tindex_equal : tindex equality +val targs_equal : targs equality + val ty_equal : ty equality val ty_hash : ty hash val ty_fv : ty fv diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 03dd1f64ec..125c3b0486 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -153,7 +153,16 @@ let mk_form = EcAst.mk_form let f_node { f_node = form } = form (* -------------------------------------------------------------------- *) -let f_op x tys ty = mk_form (Fop (x, tys)) ty +let f_op_r (p : EcPath.path) (ta : targs) (resty : ty) = + mk_form (Fop (p, ta)) resty + +let f_op + (p : EcPath.path) + ?(indices : tindex list option) + ?(tyargs : ty list option) + (resty : ty) += + f_op_r p (mk_targs ?indices ?types:tyargs ()) resty let f_app f args ty = let f, args' = @@ -167,19 +176,28 @@ let f_app f args ty = end else mk_form (Fapp (f, args')) ty (* -------------------------------------------------------------------- *) -let f_local x ty = mk_form (Flocal x) ty -let f_pvar x ty m = {m;inv=mk_form (Fpvar(x, m)) ty} -let f_pvloc v m = f_pvar (pv_loc v.v_name) v.v_type m +let f_local (x : EcIdent.t) (ty : ty) = + mk_form (Flocal x) ty + +let f_pvar (pv : prog_var) (ty : ty) (m : memory) : ss_inv = + { m; inv = mk_form (Fpvar (pv, m)) ty} + +let f_pvloc (v : variable) (m : memory) : ss_inv = + f_pvar (pv_loc v.v_name) v.v_type m -let f_pvarg ty m = f_pvar pv_arg ty m +let f_pvarg (ty : ty) (m : memory) : ss_inv = + f_pvar pv_arg ty m -let f_pvlocs vs menv = List.map (fun v -> f_pvloc v menv) vs -let f_glob m mem = {m=mem;inv=mk_form (Fglob (m, mem)) (tglob m)} +let f_pvlocs (vs : variable list) (m : memory) = + List.map (fun v -> f_pvloc v m) vs + +let f_glob (mid : EcIdent.t) (mem : memory) = + { m = mem; inv = mk_form (Fglob (mid, mem)) (tglob mid) } (* -------------------------------------------------------------------- *) -let f_tt = f_op EcCoreLib.CI_Unit.p_tt [] tunit -let f_true = f_op EcCoreLib.CI_Bool.p_true [] tbool -let f_false = f_op EcCoreLib.CI_Bool.p_false [] tbool +let f_tt = f_op EcCoreLib.CI_Unit.p_tt tunit +let f_true = f_op EcCoreLib.CI_Bool.p_true tbool +let f_false = f_op EcCoreLib.CI_Bool.p_false tbool let f_bool = fun b -> if b then f_true else f_false (* -------------------------------------------------------------------- *) @@ -218,13 +236,13 @@ let f_forall_mems bds f = let ty_fbool1 = toarrow (List.make 1 tbool) tbool let ty_fbool2 = toarrow (List.make 2 tbool) tbool -let fop_not = f_op EcCoreLib.CI_Bool.p_not [] ty_fbool1 -let fop_and = f_op EcCoreLib.CI_Bool.p_and [] ty_fbool2 -let fop_anda = f_op EcCoreLib.CI_Bool.p_anda [] ty_fbool2 -let fop_or = f_op EcCoreLib.CI_Bool.p_or [] ty_fbool2 -let fop_ora = f_op EcCoreLib.CI_Bool.p_ora [] ty_fbool2 -let fop_imp = f_op EcCoreLib.CI_Bool.p_imp [] ty_fbool2 -let fop_iff = f_op EcCoreLib.CI_Bool.p_iff [] ty_fbool2 +let fop_not = f_op EcCoreLib.CI_Bool.p_not ty_fbool1 +let fop_and = f_op EcCoreLib.CI_Bool.p_and ty_fbool2 +let fop_anda = f_op EcCoreLib.CI_Bool.p_anda ty_fbool2 +let fop_or = f_op EcCoreLib.CI_Bool.p_or ty_fbool2 +let fop_ora = f_op EcCoreLib.CI_Bool.p_ora ty_fbool2 +let fop_imp = f_op EcCoreLib.CI_Bool.p_imp ty_fbool2 +let fop_iff = f_op EcCoreLib.CI_Bool.p_iff ty_fbool2 let f_not f = f_app fop_not [f] tbool let f_and f1 f2 = f_app fop_and [f1; f2] tbool @@ -257,7 +275,9 @@ let f_oras fs = let f_imps = List.fold_right f_imp (* -------------------------------------------------------------------- *) -let fop_eq ty = f_op EcCoreLib.CI_Bool.p_eq [ty] (toarrow [ty; ty] tbool) +let fop_eq ty = + f_op EcCoreLib.CI_Bool.p_eq ~tyargs:[ty] + (toarrow [ty; ty] tbool) let f_eq f1 f2 = f_app (fop_eq f1.f_ty) [f1; f2] tbool @@ -343,13 +363,13 @@ let f_pr pr_mem pr_fun pr_args (pr_event: ss_inv) = f_pr_r { pr_mem; pr_fun; pr_args; pr_event; } (* -------------------------------------------------------------------- *) -let fop_int_opp = f_op EcCoreLib.CI_Int.p_int_opp [] (toarrow [tint] tint) -let fop_int_add = f_op EcCoreLib.CI_Int.p_int_add [] (toarrow [tint; tint] tint) -let fop_int_mul = f_op EcCoreLib.CI_Int.p_int_mul [] (toarrow [tint; tint] tint) -let fop_int_pow = f_op EcCoreLib.CI_Int.p_int_pow [] (toarrow [tint; tint] tint) +let fop_int_opp = f_op EcCoreLib.CI_Int.p_int_opp (toarrow [tint] tint) +let fop_int_add = f_op EcCoreLib.CI_Int.p_int_add (toarrow [tint; tint] tint) +let fop_int_mul = f_op EcCoreLib.CI_Int.p_int_mul (toarrow [tint; tint] tint) +let fop_int_pow = f_op EcCoreLib.CI_Int.p_int_pow (toarrow [tint; tint] tint) let fop_int_edivz = - f_op EcCoreLib.CI_Int.p_int_edivz [] + f_op EcCoreLib.CI_Int.p_int_edivz (toarrow [tint; tint] (ttuple [tint; tint])) let f_int_opp f = f_app fop_int_opp [f] tint @@ -372,14 +392,14 @@ let f_i1 = f_int BI.one let f_im1 = f_int_opp f_i1 (* -------------------------------------------------------------------- *) -let f_op_xopp = f_op EcCoreLib.CI_xint.p_xopp [] (toarrow [txint ] txint) -let f_op_xadd = f_op EcCoreLib.CI_xint.p_xadd [] (toarrow [txint; txint ] txint) -let f_op_xmul = f_op EcCoreLib.CI_xint.p_xmul [] (toarrow [txint; txint ] txint) +let f_op_xopp = f_op EcCoreLib.CI_xint.p_xopp (toarrow [txint ] txint) +let f_op_xadd = f_op EcCoreLib.CI_xint.p_xadd (toarrow [txint; txint ] txint) +let f_op_xmul = f_op EcCoreLib.CI_xint.p_xmul (toarrow [txint; txint ] txint) -let f_op_inf = f_op EcCoreLib.CI_xint.p_inf [] txint -let f_op_N = f_op EcCoreLib.CI_xint.p_N [] (toarrow [tint ] txint) -let f_op_is_inf = f_op EcCoreLib.CI_xint.p_is_inf [] (toarrow [txint] tbool) -let f_op_is_int = f_op EcCoreLib.CI_xint.p_is_int [] (toarrow [txint] tbool) +let f_op_inf = f_op EcCoreLib.CI_xint.p_inf txint +let f_op_N = f_op EcCoreLib.CI_xint.p_N (toarrow [tint ] txint) +let f_op_is_inf = f_op EcCoreLib.CI_xint.p_is_inf (toarrow [txint] tbool) +let f_op_is_int = f_op EcCoreLib.CI_xint.p_is_int (toarrow [txint] tbool) let f_is_inf f = f_app f_op_is_inf [f] tbool let f_is_int f = f_app f_op_is_int [f] tbool @@ -408,11 +428,14 @@ let f_xmuli_simpl f1 f2 = (* -------------------------------------------------------------------- *) let f_none (ty : ty) : form = - f_op EcCoreLib.CI_Option.p_none [ty] (toption ty) + f_op EcCoreLib.CI_Option.p_none ~tyargs:[ty] (toption ty) let f_some ({ f_ty = ty } as f : form) : form = - let op = f_op EcCoreLib.CI_Option.p_some [ty] (tfun ty (toption ty)) in - f_app op [f] (toption ty) + let op = + f_op EcCoreLib.CI_Option.p_some ~tyargs:[ty] + (tfun ty (toption ty)) + in + f_app op [f] (toption ty) (* -------------------------------------------------------------------- *) let f_map gt g fp = @@ -453,10 +476,12 @@ let f_map gt g fp = let ty' = gt fp.f_ty in (f_pvar id ty' s).inv - | Fop (p, tys) -> - let tys' = List.Smart.map gt tys in - let ty' = gt fp.f_ty in - f_op p tys' ty' + | Fop (p, ta) -> + let ta' = + { indices = ta.indices + ; types = List.Smart.map gt ta.types } in + let ty' = gt fp.f_ty in + f_op_r p ta' ty' | Fapp (f, fs) -> let f' = g f in @@ -943,8 +968,8 @@ let rec form_of_expr_r ?m (e : expr) = | Some m -> (f_pvar pv e.e_ty m).inv end - | Eop (op, tys) -> - f_op op tys e.e_ty + | Eop (op, ta) -> + f_op_r op ta e.e_ty | Eapp (ef, es) -> f_app (form_of_expr_r ?m ef) (List.map (form_of_expr_r ?m) es) e.e_ty @@ -989,7 +1014,7 @@ let expr_of_ss_inv f = | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, ta) -> e_op_r p ta fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty @@ -1031,7 +1056,7 @@ let expr_of_form f = | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, ta) -> e_op_r p ta fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 2787b1c9e5..71c223c057 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -237,13 +237,13 @@ val destr_forall1 : form -> ident * gty * form val destr_exists1 : form -> ident * gty * form val destr_lambda1 : form -> ident * gty * form -val destr_op : form -> EcPath.path * ty list +val destr_op : form -> EcPath.path * targs val destr_local : form -> EcIdent.t val destr_pvar : form -> prog_var * memory val destr_proj : form -> form * int val destr_tuple : form -> form list val destr_app : form -> form * form list -val destr_op_app : form -> (EcPath.path * ty list) * form list +val destr_op_app : form -> (EcPath.path * targs) * form list val destr_not : form -> form val destr_nots : form -> bool * form val destr_and : form -> form * form diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index a929263bf9..e2e248c0a4 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -182,7 +182,7 @@ let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s (* -------------------------------------------------------------------- *) -let tindex_subst (s : f_subst) (ti : tindex) = +let tindex_subst (_ : f_subst) (ti : tindex) = ti (* FIXME *) (* -------------------------------------------------------------------- *) diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index f829b8d387..09e85e70e2 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -55,8 +55,9 @@ val add_elocal : (EcIdent.t * ty) subst_binder val add_elocals : (EcIdent.t * ty) list subst_binder val bind_elocal : f_subst -> EcIdent.t -> expr -> f_subst - (* -------------------------------------------------------------------- *) +val targs_subst : targs substitute + val ty_subst : ty substitute val e_subst : expr substitute val s_subst : stmt substitute diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 22d55c894f..e1189551db 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -11,9 +11,12 @@ module Ssym = EcSymbols.Ssym module CS = EcCoreSubst (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t -type ty_params = ty_param list -type ty_pctor = [ `Int of int | `Named of ty_params ] +type ty_params = { + idxvars : EcIdent.t list; + tyvars : EcIdent.t list; +} + +type ty_pctor = [ `Int of int | `Named of ty_params ] type ty_record = EcCoreFol.form * (EcSymbols.symbol * EcTypes.ty) list @@ -53,16 +56,19 @@ let tydecl_as_record (td : tydecl) = match td.tyd_type with Record (x, y) -> Some (x, y) | _ -> None (* -------------------------------------------------------------------- *) -let abs_tydecl ?(params = `Int 0) lc = - let params = +let abs_tydecl ?(params : ty_pctor = `Int 0) (lc : locality) = + let params : ty_params = match params with | `Named params -> params + | `Int n -> let fmt = fun x -> Printf.sprintf "'%s" x in - List.map - (fun x -> (EcIdent.create x)) - (EcUid.NameGen.bulk ~fmt n) + let tyvars = + List.map + (fun x -> EcIdent.create x) + (EcUid.NameGen.bulk ~fmt n) + in { tyvars; idxvars = []; } in { tyd_params = params; tyd_type = Abstract; tyd_loca = lc; } @@ -195,15 +201,24 @@ let is_prind op = | OB_pred (Some (PR_Ind _)) -> true | _ -> false -let gen_op ?(clinline = false) ?unfold ~opaque tparams ty kind lc = { - op_tparams = tparams; - op_ty = ty; - op_kind = kind; - op_loca = lc; - op_opaque = opaque; - op_clinline = clinline; - op_unfold = unfold; -} +let gen_op + ?(clinline : bool = false) + ?(unfold : int option) + ~(opaque : opopaque) + ~(locality : locality) + ~(typarams : typarams) + ~(idxparams : idxparams) + ~(resty : ty) + (kind : _) += + { op_params = tparams + ; op_ty = ty + ; op_kind = kind + ; op_loca = lc + ; op_opaque = opaque + ; op_clinline = clinline + ; op_unfold = unfold + } let mk_pred ?clinline ?unfold ~opaque tparams dom body lc = let kind = OB_pred body in @@ -213,9 +228,18 @@ let mk_pred ?clinline ?unfold ~opaque tparams dom body lc = let optransparent : opopaque = { smt = false; reduction = false; } -let mk_op ?clinline ?unfold ~opaque tparams ty body lc = - let kind = OB_oper body in - gen_op ?clinline ?unfold ~opaque tparams ty kind lc +let mk_op + ?(clinline : bool option) + ?(unfold : int option) + ~(opaque : opopaque) + ~(locality : locality) + ?(typarams : typarams) + ?(idxparams : idxparams) + ~(resty : ty) + (body : opbody option) += + gen_op + ?clinline ?unfold ~opaque ~locality ?typarams ?idxparams ~resty (OB_oper body) let mk_abbrev ?(ponly = false) tparams xs (codom, body) lc = let kind = { @@ -279,7 +303,7 @@ let axiomatized_op let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in let tyargs = List.map EcTypes.tvar axpm in - let op = f_op path tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in + let op = f_op path ~tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in let op = f_app op opargs axbd.f_ty in let axspec = f_forall args (f_eq op axbd) in diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 61a0851b02..8965253402 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -6,8 +6,11 @@ open EcTypes open EcCoreFol (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t -type ty_params = ty_param list +type ty_params = { + idxvars : EcIdent.t list; + tyvars : EcIdent.t list; +} + type ty_pctor = [ `Int of int | `Named of ty_params ] type ty_record = diff --git a/src/ecEnv.mli b/src/ecEnv.mli index eb5d331258..b69186e298 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -316,7 +316,7 @@ module Op : sig val bind : ?import:bool -> symbol -> operator -> env -> env val reducible : ?mode:redmode -> ?nargs:int -> env -> path -> bool - val reduce : ?mode:redmode -> ?nargs:int -> env -> path -> ty list -> form + val reduce : ?mode:redmode -> ?nargs:int -> env -> path -> targs -> form val is_projection : env -> path -> bool val is_record_ctor : env -> path -> bool @@ -350,7 +350,7 @@ module Ty : sig val bind : ?import:bool -> symbol -> t -> env -> env val defined : path -> env -> bool - val unfold : path -> EcTypes.ty list -> env -> EcTypes.ty + val unfold : path -> targs -> env -> EcTypes.ty val hnorm : EcTypes.ty -> env -> EcTypes.ty val decompose_fun : EcTypes.ty -> env -> EcTypes.dom * EcTypes.ty diff --git a/src/ecProcSem.ml b/src/ecProcSem.ml index 26df3e6228..389078973c 100644 --- a/src/ecProcSem.ml +++ b/src/ecProcSem.ml @@ -34,7 +34,7 @@ type mode = [`Det | `Distr] (* -------------------------------------------------------------------- *) (* FIXME: MOVE ME *) let eop_dunit (ty : ty) = - e_op EcCoreLib.CI_Distr.p_dunit [ty] (tfun ty (tdistr ty)) + e_op EcCoreLib.CI_Distr.p_dunit ~tyargs:[ty] (tfun ty (tdistr ty)) let e_dunit (e : expr) = e_app (eop_dunit e.e_ty) [e] (tdistr e.e_ty) @@ -181,7 +181,7 @@ let rec translate_i (env : senv) (cont : senv -> mode * expr) (i : instr) = let fd = oget (EcEnv.Fun.by_xpath_opt xp env.env) in let args = translate_e env (e_tuple args) in let op = EcPath.pqname (oget (EcPath.prefix p)) f in - let op = e_op op [] (tfun fd.f_sig.fs_arg fd.f_sig.fs_ret) in + let op = e_op op (tfun fd.f_sig.fs_arg fd.f_sig.fs_ret) in let op = e_app op [args] fd.f_sig.fs_ret in let lv = translate_lv env' lv in @@ -232,7 +232,7 @@ and translate_forloop (env : senv) (cont : senv -> mode * expr) (s : stmt) = raise SemNotSupported else begin match ic.e_node with - | Eapp ({ e_node = Eop (op, []) }, [{ e_node = Evar (PVloc y') }; { e_node = Eint inc }]) + | Eapp ({ e_node = Eop (op, _) }, [{ e_node = Evar (PVloc y') }; { e_node = Eint inc }]) when y = y' && EcBigInt.lt EcBigInt.zero inc && EcPath.p_equal op EcCoreLib.CI_Int.p_int_add @@ -245,7 +245,7 @@ and translate_forloop (env : senv) (cont : senv -> mode * expr) (s : stmt) = if BI.gt inc BI.one then begin let mx = e_app - (e_op EcCoreLib.CI_Int.p_int_mul [] (toarrow [tint; tint] tint)) + (e_op EcCoreLib.CI_Int.p_int_mul (toarrow [tint; tint] tint)) [e_int inc; e_var (pv_loc x) tint] tint in let subst = EcPV.Mpv.add env.env (pv_loc x) mx EcPV.Mpv.empty in EcPV.Mpv.issubst env.env subst body @@ -253,7 +253,7 @@ and translate_forloop (env : senv) (cont : senv -> mode * expr) (s : stmt) = let bd = match c.e_node with - | Eapp ({ e_node = Eop (op, []) }, [{ e_node = Evar (PVloc y) }; bd]) + | Eapp ({ e_node = Eop (op, _) }, [{ e_node = Evar (PVloc y) }; bd]) when x = y && EcPath.p_equal op EcCoreLib.CI_Int.p_int_lt -> bd | _ -> raise SemNotSupported in @@ -361,12 +361,12 @@ and translate_forloop (env : senv) (cont : senv -> mode * expr) (s : stmt) = List.map (fun (z, zty) -> match Msym.find_opt z env.subst with - | None -> e_op EcCoreLib.CI_Witness.p_witness [zty] zty + | None -> e_op EcCoreLib.CI_Witness.p_witness ~tyargs:[zty] zty | Some z -> e_local z zty) wr in let args = e_tuple args in let cmode, c = translate_s env' cont (stmt s_tail) in - let aout = e_op EcCoreLib.CI_Int.p_iteri [aty] in + let aout = e_op EcCoreLib.CI_Int.p_iteri ~tyargs:[aty] in let aout = aout (toarrow [tint; (toarrow [tint; aty] aty); aty] aty) in let aout = e_app aout [niter; body; args] aty in (cmode, e_let lv aout c) @@ -376,12 +376,12 @@ and translate_forloop (env : senv) (cont : senv -> mode * expr) (s : stmt) = List.map (fun (z, zty) -> match Msym.find_opt z env.subst with - | None -> e_op EcCoreLib.CI_Witness.p_witness [zty] zty + | None -> e_op EcCoreLib.CI_Witness.p_witness ~tyargs:[zty] zty | Some z -> e_local z zty) wr in let args = e_tuple args in let cmode, c = translate_s env' cont (stmt s_tail) in - let aout = e_op EcCoreLib.CI_Distr.p_dfold [aty] in + let aout = e_op EcCoreLib.CI_Distr.p_dfold ~tyargs:[aty] in let aout = aout (toarrow [toarrow [tint; aty] (tdistr aty); aty; tint] (tdistr aty)) in let aout = e_app aout [body; args; niter] (tdistr aty) in diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 3131af8403..7e8335c368 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -22,10 +22,26 @@ type 'a eqntest = env -> ?norm:bool -> 'a -> 'a -> bool type 'a eqantest = env -> ?alpha:(EcIdent.t * ty) Mid.t -> ?norm:bool -> 'a -> 'a -> bool module EqTest_base = struct - let rec for_type env t1 t2 = + (* ------------------------------------------------------------------ *) + let rec for_targs (env : EcEnv.env) (ta1 : targs) (ta2 : targs) = + let exception NotEqual in + + try + (* FIXME: compare indices *) + if List.compare_lengths ta1.types ta2.types <> 0 then + raise NotEqual; + if List.compare_lengths ta1.indices ta2.indices <> 0 then + raise NotEqual; + if not (List.all2 (for_type env) ta1.types ta2.types) then + raise NotEqual; + true + + with NotEqual -> false + + and for_type (env : EcEnv.env) (t1 : ty) (t2 : ty) = ty_equal t1 t2 || for_type_r env t1 t2 - and for_type_r env t1 t2 = + and for_type_r (env : EcEnv.env) (t1 : ty) (t2 : ty) = match t1.ty_node, t2.ty_node with | Tunivar uid1, Tunivar uid2 -> EcUid.uid_equal uid1 uid2 @@ -40,14 +56,12 @@ module EqTest_base = struct | Tglob m1, Tglob m2 -> EcIdent.id_equal m1 m2 - | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if - List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 + | Tconstr (p1, ta1), Tconstr (p2, ta2) when EcPath.p_equal p1 p2 -> + if for_targs env ta1 ta2 then true else if Ty.defined p1 env - then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) + then for_type env (Ty.unfold p1 ta1 env) (Ty.unfold p2 ta2 env) else false | Tconstr(p1,lt1), _ when Ty.defined p1 env -> @@ -136,8 +150,8 @@ module EqTest_base = struct | Evar p1, Evar p2 -> for_pv env ~norm p1 p2 - | Eop(o1,ty1), Eop(o2,ty2) -> - p_equal o1 o2 && List.all2 (for_type env) ty1 ty2 + | Eop(o1,ta1), Eop(o2,ta2) -> + p_equal o1 o2 && for_targs env ta1 ta2 | Equant(q1,b1,e1), Equant(q2,b2,e2) when eqt_equal q1 q2 -> let alpha = check_bindings env alpha b1 b2 in @@ -406,7 +420,10 @@ exception NotConv let ensure b = if b then () else raise NotConv -let check_ty env subst ty1 ty2 = +let check_targs (env : EcEnv.env) (subst : f_subst) (ta1 : targs) (ta2 : targs) = + ensure (EqTest_base.for_targs env ta1 (targs_subst subst ta2)) + +let check_ty (env : EcEnv.env) (subst : f_subst) (ty1 : ty) (ty2 : ty) = ensure (EqTest_base.for_type env ty1 (ty_subst subst ty2)) let add_local (env, subst) (x1, ty1) (x2, ty2) = @@ -537,8 +554,8 @@ let is_alpha_eq ?(subst=Fsubst.f_subst_id) hyps f1 f2 = check_mem subst mem1 mem2; check_mod subst m1 m2 - | Fop(p1, ty1), Fop(p2, ty2) when EcPath.p_equal p1 p2 -> - List.iter2 (check_ty env subst) ty1 ty2 + | Fop(p1, ta1), Fop(p2, ta2) when EcPath.p_equal p1 p2 -> + check_targs env subst ta1 ta2 | Fapp(f1',args1), Fapp(f2',args2) when List.length args1 = List.length args2 -> @@ -698,14 +715,20 @@ let reduce_local ri hyps x = then try LDecl.unfold x hyps with NotReducible -> raise nohead else raise nohead -let reduce_op ri env nargs p tys = +let reduce_op + (ri : reduction_info) + (env : EcEnv.env) + (nargs : int) + (p : EcPath.path) + (ta : targs) += match ri.delta_p p with | `No -> raise nohead | #Op.redmode as mode -> try - Op.reduce ~mode ~nargs env p tys + Op.reduce ~mode ~nargs env p ta with NotReducible -> raise nohead let is_record env f = @@ -766,13 +789,15 @@ let reduce_user_gen simplify ri env hyps f = let rec doit f ptn = match destr_app f, ptn with - | ({ f_node = Fop (p, tys) }, args), R.Rule (`Op (p', tys'), args') + | ({ f_node = Fop (p, ta) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> + assert (List.is_empty ta.indices); + let tys' = List.map (Tvar.subst tvi) tys' in begin - try List.iter2 (EcUnify.unify env ue) tys tys' + try List.iter2 (EcUnify.unify env ue) ta.types tys' with EcUnify.UnificationFailure _ -> raise NotReducible end; List.iter2 doit args args' @@ -879,11 +904,11 @@ let reduce_logic ri env hyps f p args = then f_false else f_ands (List.map2 f_eq args1 args2) - | (Fop (p1, tys1), args1), (Fop (p2, tys2), args2) + | (Fop (p1, ta1), args1), (Fop (p2, ta2), args2) when EcPath.p_equal p1 p2 && EcEnv.Op.is_record_ctor env p1 && EcEnv.Op.is_record_ctor env p2 - && List.for_all2 (EqTest_i.for_type env) tys1 tys2 -> + && EqTest_i.for_targs env ta1 ta2 -> f_ands (List.map2 f_eq args1 args2) @@ -906,11 +931,11 @@ let reduce_logic ri env hyps f p args = (* -------------------------------------------------------------------- *) let reduce_delta ri env _hyps f = match f.f_node with - | Fop (p, tys) when ri.delta_p p <> `No -> - reduce_op ri env 0 p tys + | Fop (p, ta) when ri.delta_p p <> `No -> + reduce_op ri env 0 p ta - | Fapp ({ f_node = Fop (p, tys) }, args) when ri.delta_p p <> `No -> - let op = reduce_op ri env (List.length args) p tys in + | Fapp ({ f_node = Fop (p, ta) }, args) when ri.delta_p p <> `No -> + let op = reduce_op ri env (List.length args) p ta in f_app_simpl op args f.f_ty | _ -> raise nohead @@ -1063,8 +1088,7 @@ let reduce_head simplify ri env hyps f = let body = EcFol.form_of_expr body in (* FIXME subst-refact can we do both subst in once *) - let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + let body = Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1448,8 +1472,8 @@ let rec conv ri env f1 f2 stk = | exception NotConv -> force_head ri env f1 f2 stk end - | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 && List.all2 (EqTest_i.for_type env) ty1 ty2 -> + | Fop(p1, ta1), Fop(p2,ta2) + when EcPath.p_equal p1 p2 && EqTest_i.for_targs env ta1 ta2 -> conv_next ri env f1 stk | Fapp(f1', args1), Fapp(f2', args2) @@ -1742,8 +1766,8 @@ module User = struct let rule = let rec rule (f : form) : EcTheory.rule_pattern = match EcFol.destr_app f with - | { f_node = Fop (p, tys) }, args -> - R.Rule (`Op (p, tys), List.map rule args) + | { f_node = Fop (p, ta) }, args when List.is_empty ta.indices -> (* FIXME *) + R.Rule (`Op (p, ta.types), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fproj (target, i) }, [] -> diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 27dea22f8d..1f468b5b2e 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -19,6 +19,7 @@ type 'a eqantest = env -> ?alpha:(EcIdent.t * ty) Mid.t -> ?norm:bool -> 'a -> ' module EqTest : sig val for_type_exn : env -> ty -> ty -> unit + val for_targs : targs eqtest val for_type : ty eqtest val for_pv : prog_var eqntest val for_lv : lvalue eqntest diff --git a/src/ecTypes.mli b/src/ecTypes.mli index ce7bb091c9..18b5799819 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -19,7 +19,7 @@ type tindex = EcAst.tindex type targs = EcAst.targs (* -------------------------------------------------------------------- *) -val mk_targs : ?indices:tindex list -> ?tyargs:ty list -> unit -> targs +val mk_targs : ?indices:tindex list -> ?types:ty list -> unit -> targs (* -------------------------------------------------------------------- *) module Mty : Map.S with type key = ty @@ -36,7 +36,7 @@ val ty_hash : ty -> int val tuni : EcUid.uid -> ty val tvar : EcIdent.t -> ty val ttuple : ty list -> ty -val tconstr : EcPath.path -> ?indices:tindex list -> ?tyargs:ty list -> ty +val tconstr : ?indices:tindex list -> ?tyargs:ty list -> EcPath.path -> ty val tconstr_r : EcPath.path -> targs -> ty val tfun : ty -> ty -> ty val tglob : EcIdent.t -> ty diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 0fff10aa6f..3b54922716 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -142,9 +142,13 @@ let unify_core (env : EcEnv.env) (uf : UF.t) pb = Queue.push (`TyUni (t1, t1')) pb; Queue.push (`TyUni (t2, t2')) pb - | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if List.length lt1 <> List.length lt2 then failure (); - List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 + | Tconstr (p1, ta1), Tconstr (p2, ta2) when EcPath.p_equal p1 p2 -> + if List.all2 tindex_equal ta1.indices ta2.indices then + failure (); (* FIXME *) + if List.length ta1.types <> List.length ta2.types then failure (); + List.iter2 + (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) + ta1.types ta2.types | Tconstr (p, lt), _ when EcEnv.Ty.defined p env -> Queue.push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) pb diff --git a/src/phl/ecPhlWhile.ml b/src/phl/ecPhlWhile.ml index c54b43ea49..d36ccdffdf 100644 --- a/src/phl/ecPhlWhile.ml +++ b/src/phl/ecPhlWhile.ml @@ -358,7 +358,7 @@ module LossLess = struct | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, ta) -> e_op_r p ta fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty @@ -599,7 +599,7 @@ let process_while side winfos tc = let process_async_while (winfos : EP.async_while_info) tc = let e_and e1 e2 = let p = EcCoreLib.CI_Bool.p_and in - e_app (e_op p [] (toarrow [tbool; tbool] tbool)) [e1; e2] tbool + e_app (e_op p (toarrow [tbool; tbool] tbool)) [e1; e2] tbool in let { EP.asw_inv = inv ; From a23243cee2fb17aa7f07ef6c89bad66d6be884e1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 19 Apr 2026 19:15:03 +0200 Subject: [PATCH 03/40] =?UTF-8?q?indexed-types:=20phase=200=20=E2=80=94=20?= =?UTF-8?q?restore=20the=20build?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Mechanical migration of every call site to the new ty_params = {idxvars; tyvars} record and targs = {indices; types} record introduced in b15e33515. Repairs the broken gen_op/mk_op bodies in ecDecl and the syntax error in ecInductive (c413f37af WIP). No semantic change: indices are uniformly empty, tyvars carry the existing behaviour. Phase-0 design choices and the rest of the roadmap are documented in memory.md. --- memory.md | 176 ++++++++++++++++++++++++++++++++++++++++ src/ecAlgTactic.ml | 2 +- src/ecCallbyValue.ml | 6 +- src/ecDecl.ml | 48 ++++------- src/ecEnv.ml | 38 ++++----- src/ecHiGoal.ml | 8 +- src/ecHiInductive.ml | 6 +- src/ecInductive.ml | 31 +++---- src/ecLowGoal.ml | 8 +- src/ecMatching.ml | 4 +- src/ecPV.ml | 4 +- src/ecPrinting.ml | 59 +++++++------- src/ecProofTerm.ml | 6 +- src/ecProofTyping.ml | 1 + src/ecReduction.ml | 8 +- src/ecScope.ml | 53 ++++++------ src/ecSearch.ml | 2 +- src/ecSection.ml | 91 ++++++++++++--------- src/ecSmt.ml | 30 ++++--- src/ecSubst.ml | 9 +- src/ecThCloning.ml | 4 +- src/ecTheoryReplay.ml | 78 +++++++++--------- src/ecTyping.ml | 53 ++++++------ src/ecUnify.ml | 12 +-- src/phl/ecPhlCond.ml | 12 +-- src/phl/ecPhlFel.ml | 8 +- src/phl/ecPhlLoopTx.ml | 2 +- src/phl/ecPhlPrRw.ml | 6 +- src/phl/ecPhlRCond.ml | 8 +- src/phl/ecPhlRwEquiv.ml | 2 +- 30 files changed, 483 insertions(+), 292 deletions(-) create mode 100644 memory.md diff --git a/memory.md b/memory.md new file mode 100644 index 0000000000..927066f960 --- /dev/null +++ b/memory.md @@ -0,0 +1,176 @@ +# Indexed-types branch — work-in-progress notes + +This file tracks ongoing decisions and progress on the `indexed-types` +branch. The end goal is to add integer-indexed types to EasyCrypt: +types parametrised by both type variables and integer indices, with a +small index language and decidable equality on indices. + +## Confirmed design decisions + +- **`tindex` grammar.** `TIVar | TIConst zint | TIAdd | TIMul` + ([src/ecAst.ml:60-64](src/ecAst.ml#L60-L64)). No `TINeg`/`TISub`; + surface syntax must reject subtraction. +- **Indices are non-negative integers (ℕ).** `TIConst` should be + guarded against negative `zint`. +- **Equality is decided by polynomial normal form.** Normalize to + sorted sum-of-monomials with `EcBigInt` coefficients (all ≥ 1), then + compare structurally. No SMT. +- **`TIVar` shares the term-level identifier namespace with `int` + formula vars.** A substitution `n ↦ φ` is required at construction + time to have `φ` representable as a `tindex` — i.e. + `tindex_of_form φ` must succeed. `tindex_subst` may then + `Option.get` the conversion. +- **Indices appear on every polymorphic declaration:** tydecls, + operators (incl. predicates / abbreviations / notations), + axioms / lemmas. Not modules. +- **No constraint annotations in the MVP.** `'a vec[n-3]` is not + expressible (no subtraction); `'a vec[0]` is allowed and just + useless. +- **SMT export: punted.** Block proof obligations touching indexed + types until a later phase. + +## Phase 0 — Stop the bleeding (DONE) + +Goal: clean `dune build` with the existing `targs` / +`ty_params = {idxvars; tyvars}` data model, without changing semantics. + +### What changed + +- [src/ecInductive.ml](src/ecInductive.ml) — fixed the stray `)` + syntax error at line 188; renamed `args.indexes` → `args.indices`; + threaded `tyd_params.tyvars`; switched constructor calls to keyword + form (`tconstr ~tyargs`, `f_op ~tyargs`). +- [src/ecDecl.ml](src/ecDecl.ml) — restored `gen_op` / `mk_op` bodies + to match the existing mli (the WIP rewrite referenced unbound names + `tparams` / `ty` / `lc` / `op_params`); threaded `tparams.tyvars` in + `ty_instantiate` and `axiomatized_op`; `ax_tparams` now wraps a + `ty_params` record. +- [src/ecUnify.ml](src/ecUnify.ml) — `UniEnv.create` / `opentvi` / + `subst_tv` / `tparams` now consume / produce `ty_params` records + (extracting `.tyvars` internally; `ue_decl` still stores the tyvar + list). +- [src/ecEnv.ml](src/ecEnv.ml) — `Op.reduce`, `Ax.instantiate`, + `Ty.unfold`, `Ty.scheme_of_ty`, `Ty.get_top_decl` thread + `targs.types` / `tyvars` correctly; algebra instances and TC-op + helpers wrap empty `ty_params`. +- Mechanical migration across + [src/ecCallbyValue.ml](src/ecCallbyValue.ml), + [src/ecReduction.ml](src/ecReduction.ml), + [src/ecMatching.ml](src/ecMatching.ml), + [src/ecPV.ml](src/ecPV.ml), + [src/ecHiInductive.ml](src/ecHiInductive.ml), + [src/ecHiGoal.ml](src/ecHiGoal.ml), + [src/ecLowGoal.ml](src/ecLowGoal.ml), + [src/ecProofTyping.ml](src/ecProofTyping.ml), + [src/ecProofTerm.ml](src/ecProofTerm.ml), + [src/ecSearch.ml](src/ecSearch.ml), + [src/ecTyping.ml](src/ecTyping.ml), + [src/ecScope.ml](src/ecScope.ml), + [src/ecTheoryReplay.ml](src/ecTheoryReplay.ml), + [src/ecAlgTactic.ml](src/ecAlgTactic.ml), + [src/ecSection.ml](src/ecSection.ml), + [src/ecSubst.ml](src/ecSubst.ml), + [src/ecSmt.ml](src/ecSmt.ml), + [src/ecPrinting.ml](src/ecPrinting.ml), + [src/ecThCloning.ml](src/ecThCloning.ml), and several + [src/phl/](src/phl/) modules: + - `tyd_params` / `op_tparams` / `ax_tparams` → `.tyvars` + - `targs` consumers → `.types` / `.indices` + - positional `tconstr p tys` / `e_op p tys` / `f_op p tys` → + keyword form (`~tyargs:` / `~indices:`) + - `[]` placeholders for `ty_params` → `{idxvars=[]; tyvars=[]}` + +### Notable Phase-0 design choices + +- Kept `ue_decl : EcIdent.t list` inside `ecUnify` (only tyvars), + wrapping into `ty_params` at the boundary. +- Several places that consume `targs` for type comparison currently + `assert (List.is_empty tys.indices)` (e.g. `ecMatching`, + `ecCallbyValue`, `ecReduction`'s rule patterns, `ecSmt`) — explicit + panics where Phase 1 will replace with proper polynomial-equality + logic. +- SMT translation now hard-asserts no indices (per the SMT-punt + decision); a cleaner user-facing error belongs to Phase 5. + +## Roadmap (remaining phases) + +### Phase 1 — Polynomial normal form & equality +1. Add a `tindex` normalisation (sorted sum-of-monomials with + `EcBigInt` coefficients ≥ 1) and hashcons canonical forms. +2. Make `tindex_equal` compare canonical forms; replace the + `Hashtbl.hash` `tindex_hash` (structurally wrong once + `1+2 ≡ 2+1`). +3. Replace the `(* FIXME *)` in + [src/ecUnify.ml:146](src/ecUnify.ml#L146) (note: polarity also + bugged today: `if all2 ... then failure ()` is inverted) and the + `(* FIXME: compare indices *)` in `EcReduction.for_targs` + ([src/ecReduction.ml:25-39](src/ecReduction.ml#L25-L39)). +4. Decide whether indices participate in `EcUnify.UF` for inference — + probably needed only if Phase 3 lets users elide indices. + +### Phase 2 — Substitution & FV +1. Add `tindex_of_form : form -> tindex option` recognising + `Fint n (n≥0)`, `Flocal id (ty=int)`, `Fapp(p_int_add, [a;b])`, + `Fapp(p_int_mul, [a;b])`. Returns `None` on anything else. +2. Implement `tindex_subst` in + [src/ecCoreSubst.ml:185](src/ecCoreSubst.ml#L185) and + [src/ecSubst.ml:153](src/ecSubst.ml#L153): for `TIVar id`, look up + `fs_loc`/`fs_v`; if a binding exists, `tindex_of_form` it and + `Option.get` (panic if the substitution invariant is violated). + Re-normalise at the root. +3. Patch `targs_fv` in [src/ecAst.ml:1090](src/ecAst.ml#L1090) and + `Hsty.fv` in [src/ecAst.ml:1147](src/ecAst.ml#L1147) to fold over + `indices` (currently they only walk `types`, so + `Tconstr (p, {indices=[TIVar n]; types=[]})` reports empty fv — + wrong). +4. Audit smart-equality fast paths in `targs_subst`: `==` survives + normalisation only when nothing changed *and* the input was already + canonical. + +### Phase 3 — Parser & typing +1. Concrete syntax for *binders*: propose `type ['n 'm] 'a vec`, + `op f ['n] ('a) (xs : 'a vec['n]) : …`, `axiom ['n] foo : …`. + Bracket order should match `dump_ty`'s `[indices|types]`. +2. Concrete syntax for *applications*: `'a vec[n+1]`. +3. `EcTyping`: parse index expressions through a restricted grammar — + only `+`, `*`, non-negative literals, identifiers bound as indices. + Reject subtraction, division, calls. +4. Resolution: when `n` is in scope as both an index binder and an int + term variable (shared namespace), an occurrence in an index + position becomes `TIVar n`, in a term position becomes + `Flocal n` — disambiguated by syntactic position. +5. Cloning (`EcThCloning`, `EcSubst`): index parameters get + instantiated alongside type parameters during clone-with. + +### Phase 4 — Theories & smoke tests +1. Add a focused `.ec` test exercising: + - declaration of an indexed type and indexed op + - polynomial-equality path: `concat (concat a b) c : vec[(n+m)+k]` + unifies with `vec[n+(m+k)]` + - cloning with index instantiation +2. Recommend leaving `theories/Array.ec` etc. untouched for the first + landing. + +### Phase 5 — SMT gating +Replace the `assert (List.is_empty tys.indices)` calls in +[src/ecSmt.ml](src/ecSmt.ml) with a clean "indexed types not yet +supported by SMT" error. + +### Phase 6 — Polish +1. Pretty-printer for indices in `EcPrinting` (canonical form). +2. Reduction error messages should print both normalised indices on + mismatch. +3. `CHANGELOG`. + +## Critical path & open risks + +- Phases 0 → 1 → 2 are sequential; the rest can branch. +- **Risk:** the shared-namespace invariant (Phase 2 step 2) is + enforced by panic. If any existing pass binds an int-typed local to + a non-polynomial formula and that local later appears in a `tindex` + context, EasyCrypt will crash mid-proof. Worth a tactical audit of + `f_bind_local` / `f_subst_local` callers before merging. +- **Open:** index unification variables (Phase 1 step 4) — if the + parser always demands an explicit index, you can defer this + indefinitely. If you want `vec[]` inference, it's needed before + Phase 3 is usable. diff --git a/src/ecAlgTactic.ml b/src/ecAlgTactic.ml index f926a7ff3b..cf1ff5ef4a 100644 --- a/src/ecAlgTactic.ml +++ b/src/ecAlgTactic.ml @@ -123,7 +123,7 @@ module Axioms = struct let for1 axname = let ax = EcEnv.Ax.by_path (EcPath.pqname tmod axname) env in - assert (ax.ax_tparams = [] && is_axiom ax.ax_kind); + assert (ax.ax_tparams.tyvars = [] && ax.ax_tparams.idxvars = [] && is_axiom ax.ax_kind); (axname, EcSubst.subst_form subst ax.ax_spec) in List.map for1 axs diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 482205ec88..cffc677efb 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -217,7 +217,7 @@ and betared st s bd f args = (* -------------------------------------------------------------------- *) and try_reduce_record_projection - (st : state) ((p, _tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, _tys) : EcPath.path * targs) (args : args) = let exception Bailout in @@ -245,7 +245,7 @@ and try_reduce_record_projection (* -------------------------------------------------------------------- *) and try_reduce_fixdef - (st : state) ((p, tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, tys) : EcPath.path * targs) (args : args) = let exception Bailout in @@ -300,7 +300,7 @@ and try_reduce_fixdef let body = EcFol.form_of_expr body in let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + Tvar.f_subst ~freshen:true op.EcDecl.op_tparams.tyvars tys.types body in Some (cbv st subst body (Args.create ty eargs)) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index e1189551db..9b29e6cba0 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -75,7 +75,7 @@ let abs_tydecl ?(params : ty_pctor = `Int 0) (lc : locality) = (* -------------------------------------------------------------------- *) let ty_instantiate (params : ty_params) (args : ty list) (ty : ty) = - let subst = CS.Tvar.init params args in + let subst = CS.Tvar.init params.tyvars args in CS.Tvar.subst subst ty (* -------------------------------------------------------------------- *) @@ -201,24 +201,15 @@ let is_prind op = | OB_pred (Some (PR_Ind _)) -> true | _ -> false -let gen_op - ?(clinline : bool = false) - ?(unfold : int option) - ~(opaque : opopaque) - ~(locality : locality) - ~(typarams : typarams) - ~(idxparams : idxparams) - ~(resty : ty) - (kind : _) -= - { op_params = tparams - ; op_ty = ty - ; op_kind = kind - ; op_loca = lc - ; op_opaque = opaque - ; op_clinline = clinline - ; op_unfold = unfold - } +let gen_op ?(clinline = false) ?unfold ~opaque tparams ty kind lc = { + op_tparams = tparams; + op_ty = ty; + op_kind = kind; + op_loca = lc; + op_opaque = opaque; + op_clinline = clinline; + op_unfold = unfold; +} let mk_pred ?clinline ?unfold ~opaque tparams dom body lc = let kind = OB_pred body in @@ -228,18 +219,9 @@ let mk_pred ?clinline ?unfold ~opaque tparams dom body lc = let optransparent : opopaque = { smt = false; reduction = false; } -let mk_op - ?(clinline : bool option) - ?(unfold : int option) - ~(opaque : opopaque) - ~(locality : locality) - ?(typarams : typarams) - ?(idxparams : idxparams) - ~(resty : ty) - (body : opbody option) -= - gen_op - ?clinline ?unfold ~opaque ~locality ?typarams ?idxparams ~resty (OB_oper body) +let mk_op ?clinline ?unfold ~opaque tparams ty body lc = + let kind = OB_oper body in + gen_op ?clinline ?unfold ~opaque tparams ty kind lc let mk_abbrev ?(ponly = false) tparams xs (codom, body) lc = let kind = { @@ -287,7 +269,7 @@ let axiomatized_op : axiom = let axbd, axpm = - let bdpm = tparams in + let bdpm = tparams.tyvars in let axpm = List.map EcIdent.fresh bdpm in (CS.Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) axbd, axpm) @@ -307,7 +289,7 @@ let axiomatized_op let op = f_app op opargs axbd.f_ty in let axspec = f_forall args (f_eq op axbd) in - { ax_tparams = axpm; + { ax_tparams = { idxvars = []; tyvars = axpm }; ax_spec = axspec; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 6950cfc3b3..7cfdc22020 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -788,9 +788,9 @@ module MC = struct let cs = dtype.tydt_ctors in let schelim = dtype.tydt_schelim in let schcase = dtype.tydt_schcase in - let params = List.map tvar tyd.tyd_params in + let params = List.map tvar tyd.tyd_params.tyvars in let for1 i (c, aty) = - let aty = EcTypes.toarrow aty (tconstr mypath params) in + let aty = EcTypes.toarrow aty (tconstr ~tyargs:params mypath) in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let cop = mk_op ~opaque:optransparent (fst aty) (snd aty) @@ -829,11 +829,11 @@ module MC = struct ) mc projs | Record (scheme, fields) -> - let params = List.map tvar tyd.tyd_params in + let params = List.map tvar tyd.tyd_params.tyvars in let nfields = List.length fields in let cfields = let for1 i (f, aty) = - let aty = EcTypes.tfun (tconstr mypath params) aty in + let aty = EcTypes.tfun (tconstr ~tyargs:params mypath) aty in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let fop = mk_op ~opaque:optransparent (fst aty) (snd aty) (Some (OP_Proj (mypath, i, nfields))) loca in @@ -854,7 +854,7 @@ module MC = struct let stname = Printf.sprintf "mk_%s" x in let stop = - let stty = toarrow (List.map snd fields) (tconstr mypath params) in + let stty = toarrow (List.map snd fields) (tconstr ~tyargs:params mypath) in let stty = EcSubst.freshen_type (tyd.tyd_params, stty) in mk_op ~opaque:optransparent (fst stty) (snd stty) (Some (OP_Record mypath)) loca in @@ -911,7 +911,7 @@ module MC = struct let opname = EcIdent.name opid in let optype = EcSubst.subst_ty tsubst optype in let opdecl = - mk_op ~opaque:optransparent [(self)] + mk_op ~opaque:optransparent { idxvars = []; tyvars = [self] } optype (Some OP_TC) loca in (opid, xpath opname, optype, opdecl) in @@ -921,7 +921,7 @@ module MC = struct let fsubst = List.fold_left (fun s (x, xp, xty, _) -> - let fop = EcCoreFol.f_op xp [tvar self] xty in + let fop = EcCoreFol.f_op xp ~tyargs:[tvar self] xty in EcSubst.add_flocal s x fop) tsubst operators @@ -931,7 +931,7 @@ module MC = struct List.map (fun (x, ax) -> let ax = EcSubst.subst_form fsubst ax in - (x, { ax_tparams = [(self)]; + (x, { ax_tparams = { idxvars = []; tyvars = [self] }; ax_spec = ax; ax_kind = `Lemma; ax_loca = loca; @@ -2536,11 +2536,11 @@ module Ty = struct | Some { tyd_type = Concrete _ } -> true | _ -> false - let unfold (name : EcPath.path) (args : EcTypes.ty list) (env : env) = + let unfold (name : EcPath.path) (args : EcAst.targs) (env : env) = match by_path_opt name env with | Some ({ tyd_type = Concrete body } as tyd) -> Tvar.subst - (Tvar.init tyd.tyd_params args) + (Tvar.init tyd.tyd_params.tyvars args.types) body | _ -> raise (LookupFailure (`Path name)) @@ -2584,14 +2584,14 @@ module Ty = struct | Datatype _, `Case -> basename ^ "_case" | _, _ -> assert false in - Some (EcPath.pqoname prefix basename, tys) + Some (EcPath.pqoname prefix basename, tys.types) | _ -> None end | _ -> None let get_top_decl (ty : ty) (env : env) = match (ty_hnorm ty env).ty_node with - | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys) + | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys.types) | _ -> None let rebind name ty env = @@ -2697,9 +2697,9 @@ module Op = struct with NotReducible -> false else false - let reduce ?mode ?nargs env p tys = + let reduce ?mode ?nargs env p (tys : EcAst.targs) = let op, f = core_reduce ?mode ?nargs env p in - Tvar.f_subst ~freshen:true op.op_tparams tys f + Tvar.f_subst ~freshen:true op.op_tparams.tyvars tys.types f let is_projection env p = try EcDecl.is_proj (by_path p env) @@ -2792,7 +2792,7 @@ module Ax = struct let instantiate p tys env = match by_path_opt p env with | Some ({ ax_spec = f } as ax) -> - Tvar.f_subst ~freshen:true ax.ax_tparams tys f + Tvar.f_subst ~freshen:true ax.ax_tparams.tyvars tys f | _ -> raise (LookupFailure (`Path p)) let iter ?name f (env : env) = @@ -2807,15 +2807,15 @@ module Algebra = struct let bind_ring ty cr env = assert (Mid.is_empty ty.ty_fv); { env with env_tci = - TypeClass.bind_instance ([], ty) (`Ring cr) env.env_tci } + TypeClass.bind_instance ({ EcDecl.idxvars = []; tyvars = [] }, ty) (`Ring cr) env.env_tci } let bind_field ty cr env = assert (Mid.is_empty ty.ty_fv); { env with env_tci = - TypeClass.bind_instance ([], ty) (`Field cr) env.env_tci } + TypeClass.bind_instance ({ EcDecl.idxvars = []; tyvars = [] }, ty) (`Field cr) env.env_tci } - let add_ring ty cr lc env = TypeClass.add_instance ([], ty) (`Ring cr) lc env - let add_field ty cr lc env = TypeClass.add_instance ([], ty) (`Field cr) lc env + let add_ring ty cr lc env = TypeClass.add_instance ({ EcDecl.idxvars = []; tyvars = [] }, ty) (`Ring cr) lc env + let add_field ty cr lc env = TypeClass.add_instance ({ EcDecl.idxvars = []; tyvars = [] }, ty) (`Field cr) lc env end (* -------------------------------------------------------------------- *) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index 8a5ebb0a77..4d0a5523e2 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -491,7 +491,7 @@ let process_exacttype qs (tc : tcenv1) = in let tys = List.map (fun a -> EcTypes.tvar a) - (EcEnv.LDecl.tohyps hyps).h_tvar in + (EcEnv.LDecl.tohyps hyps).h_tvar.tyvars in let pt = ptglobal ~tys p in try @@ -643,9 +643,9 @@ let process_delta ~und_delta ?target (s, o, p) tc = match op.EcDecl.op_kind with | EcDecl.OB_oper (Some (EcDecl.OP_Plain f)) -> - (snd p, op.EcDecl.op_tparams, f, args, Some (fst p)) + ((snd p).types, op.EcDecl.op_tparams.tyvars, f, args, Some (fst p)) | EcDecl.OB_pred (Some (EcDecl.PR_Plain f)) -> - (snd p, op.EcDecl.op_tparams, f, args, Some (fst p)) + ((snd p).types, op.EcDecl.op_tparams.tyvars, f, args, Some (fst p)) | _ -> tc_error !!tc "the operator cannot be unfolded" end @@ -700,7 +700,7 @@ let process_delta ~und_delta ?target (s, o, p) tc = match sform_of_form fp with | SFop ((_, tvi), []) -> begin (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true tparams tvi body in + let body = Tvar.f_subst ~freshen:true tparams tvi.types body in let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body with EcEnv.NotReducible -> body diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 45edcdcc7e..11a1e99c93 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -131,11 +131,11 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tdecl = EcEnv.Ty.by_path_opt tname env0 |> odfl (EcDecl.abs_tydecl ~params:(`Named tparams) lc) in - let tyinst = ty_instantiate tdecl.tyd_params targs in + let tyinst = ty_instantiate tdecl.tyd_params targs.types in match tdecl.tyd_type with | Abstract -> - List.exists isempty targs + List.exists isempty targs.types | Concrete ty -> isempty_1 [ tyinst ty ] @@ -402,7 +402,7 @@ let trans_matchfix let codom = ty_subst ts codom in let opexpr = EcPath.pqname (EcEnv.root env) name in let args = List.map (snd_map (ty_subst ts)) args in - let opexpr = e_op opexpr (List.map tvar tparams) + let opexpr = e_op opexpr ~tyargs:(List.map tvar tparams.tyvars) (toarrow (List.map snd args) codom) in let ebsubst = bind_elocal ts opname opexpr diff --git a/src/ecInductive.ml b/src/ecInductive.ml index ef0efc5c0f..7bae492668 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -38,15 +38,15 @@ let datatype_proj_path (p : EP.path) (x : symbol) = (* -------------------------------------------------------------------- *) let indsc_of_record (rc : record) = - let targs = List.map tvar rc.rc_tparams in - let recty = tconstr_r rc.rc_path targs in + let tyargs = List.map tvar rc.rc_tparams.tyvars in + let recty = tconstr_r rc.rc_path (mk_targs ~types:tyargs ()) in let recx = fresh_id_of_ty recty in let recfm = FL.f_local recx recty in let predty = tfun recty tbool in let predx = EcIdent.create "P" in let pred = FL.f_local predx predty in let ctor = record_ctor_path rc.rc_path in - let ctor = FL.f_op ctor targs (toarrow (List.map snd rc.rc_fields) recty) in + let ctor = FL.f_op ctor ~tyargs (toarrow (List.map snd rc.rc_fields) recty) in let prem = let ids = List.map (fun (_, fty) -> (fresh_id_of_ty fty, fty)) rc.rc_fields in let vars = List.map (fun (x, xty) -> FL.f_local x xty) ids in @@ -138,7 +138,7 @@ let ty_params_compat = declaration [decl] (with name [p]). This function provide error context in case the check fails. *) let rec check_positivity_in_decl fct p decl ident = - let check x () = check_positivity_ident fct p decl.tyd_params ident x + let check x () = check_positivity_ident fct p decl.tyd_params.tyvars ident x and iter l f = List.iter f l in match decl.tyd_type with @@ -158,13 +158,13 @@ and check_positivity_ident fct p params ident ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_ident fct p params ident) tys | Tconstr (q, args) when EcPath.p_equal q p -> - assert (List.is_empty args.indexes); + assert (List.is_empty args.indices); if not (ty_params_compat args.types params) then non_positive p (TypePositionRestriction ty) | Tconstr (q, args) -> let decl = fct q in List.iter (check_positivity_ident fct p params ident) args.types; - List.combine args.types decl.tyd_params + List.combine args.types decl.tyd_params.tyvars |> List.filter_map (fun (arg, ident') -> if EcTypes.var_mem ident arg then Some ident' else None) |> List.iter (check_positivity_in_decl fct q decl) @@ -178,14 +178,14 @@ let rec check_positivity_path fct p ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_path fct p) tys | Tconstr (q, args) when EcPath.p_equal q p -> - assert (List.is_empty args.indexes); + assert (List.is_empty args.indices); if List.exists (occurs p) args.types then non_positive p (NonPositiveOcc ty) | Tconstr (q, args) -> let decl = fct q in List.iter (check_positivity_path fct p) args.types; - List.combine args.types decl.tyd_params - |> List.filter_map (fun (arg, ident)) -> + List.combine args.types decl.tyd_params.tyvars + |> List.filter_map (fun (arg, ident) -> if occurs p arg then Some ident else None) |> List.iter (check_positivity_in_decl fct q decl) | Tfun (from, to_) -> @@ -226,11 +226,12 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = |> omap (FL.f_forall [x, GTty ty1]) and schemec mode (targs, p) pred (ctor, tys) = - let indty = tconstr p (List.map tvar targs) in + let tyargs = List.map tvar targs.tyvars in + let indty = tconstr ~tyargs p in let xs = List.map (fun xty -> (fresh_id_of_ty xty, xty)) tys in let cargs = List.map (fun (x, xty) -> FL.f_local x xty) xs in let ctor = EcPath.pqoname (EcPath.prefix tpath) ctor in - let ctor = FL.f_op ctor (List.map tvar targs) (toarrow tys indty) in + let ctor = FL.f_op ctor ~tyargs (toarrow tys indty) in let form = FL.f_app pred [FL.f_app ctor cargs indty] tbool in let form = match mode with @@ -250,7 +251,7 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = form and scheme mode (targs, p) ctors = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr ~tyargs:(List.map tvar targs.tyvars) p in let indx = fresh_id_of_ty indty in let indfm = FL.f_local indx indty in let predty = tfun indty tbool in @@ -267,7 +268,7 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = (* -------------------------------------------------------------------- *) let datatype_projectors (tpath, tparams, { tydt_ctors = ctors }) = - let thety = tconstr tpath (List.map tvar tparams) in + let thety = tconstr ~tyargs:(List.map tvar tparams.tyvars) tpath in let do1 i (cname, cty) = let thv = EcIdent.create "the" in @@ -381,7 +382,7 @@ let indsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = FL.f_forall ctor.prc_bds px in - let sc = FL.f_op p (List.map tvar pr.ip_tparams) prty in + let sc = FL.f_op p ~tyargs:(List.map tvar pr.ip_tparams.tyvars) prty in let sc = FL.f_imp (FL.f_app sc prag tbool) pred in let sc = FL.f_imps (List.map for1 pri.pri_ctors) sc in let sc = FL.f_forall [predx, FL.gtty tbool] sc in @@ -394,7 +395,7 @@ let introsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = let bds = List.map (snd_map FL.gtty) pri.pri_args in let clty = toarrow (List.map snd pri.pri_args) tbool in let clag = (List.map (curry FL.f_local) pri.pri_args) in - let cl = FL.f_op p (List.map tvar pr.ip_tparams) clty in + let cl = FL.f_op p ~tyargs:(List.map tvar pr.ip_tparams.tyvars) clty in let cl = FL.f_app cl clag tbool in let for1 ctor = diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 14e2e72f66..360ff21b64 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -1504,7 +1504,7 @@ let t_elim_prind_r ?reduce ?accept (_mode : [`Case | `Ind]) tc = | _ -> raise InvalidGoalShape - in t_apply_s p tv ~args:(args @ [f2]) ~sk tc + in t_apply_s p tv.types ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1659,7 +1659,7 @@ let t_split_prind ?reduce (tc : tcenv1) = | None -> raise InvalidGoalShape | Some (x, sk) -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s p tv.types ~args ~sk tc in t_lazy_match ?reduce t_split_r tc @@ -1679,10 +1679,10 @@ let t_or_intro_prind ?reduce (side : side) (tc : tcenv1) = match EcInductive.prind_is_iso_ors pri with | Some ((x, sk), _) when side = `Left -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s p tv.types ~args ~sk tc | Some (_, (x, sk)) when side = `Right -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s p tv.types ~args ~sk tc | _ -> raise InvalidGoalShape in t_lazy_match ?reduce t_split_r tc diff --git a/src/ecMatching.ml b/src/ecMatching.ml index b84d8d4302..76fe087247 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -681,7 +681,9 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | Fop (op1, tys1), Fop (op2, tys2) -> begin if not (EcPath.p_equal op1 op2) then failure (); - try List.iter2 (EcUnify.unify env ue) tys1 tys2 + (* Phase 0: indices not yet supported here *) + assert (List.is_empty tys1.indices && List.is_empty tys2.indices); + try List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecPV.ml b/src/ecPV.ml index 6d5c5bd5e1..b721c72aec 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -863,7 +863,7 @@ module Mpv2 = struct when EcIdent.id_equal ml m1 && EcIdent.id_equal mr m2 -> add_glob env (EcPath.mident mp1) (EcPath.mident mp2) eqs | Fop(op1,tys1), Fop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + EcReduction.EqTest.for_targs env tys1 tys2 -> eqs | Fapp(f1,a1), Fapp(f2,a2) -> List.fold_left2 (add_eq local) eqs (f1::a1) (f2::a2) | Ftuple es1, Ftuple es2 -> @@ -962,7 +962,7 @@ module Mpv2 = struct I postpone this for latter *) | Eop(op1,tys1), Eop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + EcReduction.EqTest.for_targs env tys1 tys2 -> eqs | Eapp(f1,a1), Eapp(f2,a2) -> List.fold_left2 (add_eqs_loc env local) eqs (f1::a1) (f2::a2) | Elet(lp1,a1,b1), Elet(lp2,a2,b2) -> diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 4c100ca9c2..a6c91d6ecc 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -810,7 +810,8 @@ let rec pp_type_r (pp_paren (pp_list ",@ " subpp)) xs (pp_tyname ppe) name in - maybe_paren outer t_prio_name pp fmt (name, tyargs) + (* Phase 0: indices not yet pretty-printed *) + maybe_paren outer t_prio_name pp fmt (name, tyargs.types) end | Tfun (t1, t2) -> @@ -1494,7 +1495,7 @@ let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) (opprec : else l_l f2 e_bin_prio_rop4 | Fapp ({f_node = Fop (op, tys)}, [f1; f2]) -> (let (_, opname) = - PPEnv.op_symb ppe op (Some (`Form, tys, (List.map t_ty [f1; f2], None))) in + PPEnv.op_symb ppe op (Some (`Form, tys.types, (List.map t_ty [f1; f2], None))) in match priority_of_binop opname with | None -> None | Some opprec' -> @@ -1663,7 +1664,7 @@ and try_pp_chained_orderings match match_pp_notations ~filter:(fun (p, _) -> is_ordering_op p) ppe f with | Some ((op, (tvi, _)), ue, ev, ov, [i1; i2]) -> begin let ti = Tvar.subst ov in - let tvi = List.map (ti |- tvar) tvi in + let tvi = List.map (ti |- tvar) tvi.tyvars in let sb = EcMatching.MEV.assubst ue ev ppe.ppe_env in let i1 = Fsubst.f_subst sb i1 in let i2 = Fsubst.f_subst sb i2 in @@ -1674,7 +1675,7 @@ and try_pp_chained_orderings | _ -> begin match sform_of_form f with | SFop ((op, tvi), [i1; i2]) when is_ordering_op op -> - (op, tvi), (i1, i2) + (op, tvi.types), (i1, i2) | _ -> raise Bailout end in @@ -1754,7 +1755,7 @@ and match_pp_notations let ev = MEV.of_idents (List.map fst nt.ont_args) `Form in let ue = EcUnify.UniEnv.create None in let ov = EcUnify.UniEnv.opentvi ue tv None in - let hy = EcEnv.LDecl.init ppe.PPEnv.ppe_env [] in + let hy = EcEnv.LDecl.init ppe.PPEnv.ppe_env { idxvars = []; tyvars = [] } in let bd = match (EcEnv.Memory.get_active_ss ppe.PPEnv.ppe_env) with | None -> form_of_expr nt.ont_body | Some m -> (ss_inv_of_expr m nt.ont_body).inv in @@ -1802,9 +1803,9 @@ and try_pp_notations | Some ((p, (tv, nt)), ue, ev, ov, eargs) -> let ti = Tvar.subst ov in let rty = ti nt.ont_resty in - let tv = List.map (ti |- tvar) tv in + let tv = List.map (ti |- tvar) tv.tyvars in let args = List.map (curry f_local |- snd_map ti) nt.ont_args in - let f = f_op p tv (toarrow tv rty) in + let f = f_op p ~tyargs:tv (toarrow tv rty) in let f = f_app f args rty in let f = Fsubst.f_subst (EcMatching.MEV.assubst ue ev ppe.ppe_env) f in let f = f_app f eargs f.f_ty in @@ -1909,7 +1910,7 @@ and pp_form_core_r pp_let ~fv:f2.f_fv ppe pp_form_r outer fmt (lp, f1, f2) | Fop (op, tvi) -> - pp_opapp ppe outer fmt (op, tvi, []) + pp_opapp ppe outer fmt (op, tvi.types, []) | Fapp ({f_node = Fop (op, _)}, [{f_node = Fapp ({f_node = Fop (op', tys)}, [f1; f2])}]) @@ -1917,10 +1918,10 @@ and pp_form_core_r && EcPath.p_equal op' EcCoreLib.CI_Bool.p_eq -> let negop = EcPath.pqoname (EcPath.prefix op') "<>" in - pp_opapp ppe outer fmt (negop, tys, [f1; f2]) + pp_opapp ppe outer fmt (negop, tys.types, [f1; f2]) | Fapp ({f_node = Fop (p, tys)}, args) -> - pp_opapp ppe outer fmt (p, tys, args) + pp_opapp ppe outer fmt (p, tys.types, args) | Fapp (e, args) -> pp_app ppe ~pp_first:pp_form_r ~pp_sub:pp_form_r outer fmt (e, args) @@ -2263,11 +2264,11 @@ let pp_sform ppe fmt f = (* -------------------------------------------------------------------- *) let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = let ppe = PPEnv.enter_theory ppe (Option.get (EcPath.prefix x)) in - let ppe = PPEnv.add_locals ppe tyd.tyd_params in + let ppe = PPEnv.add_locals ppe tyd.tyd_params.tyvars in let name = P.basename x in let pp_prelude fmt = - match tyd.tyd_params with + match tyd.tyd_params.tyvars with | [] -> Format.fprintf fmt "type %s" name @@ -2307,7 +2308,7 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = Format.fprintf fmt "@[%a%t%t.@]" pp_locality tyd.tyd_loca pp_prelude pp_body (* -------------------------------------------------------------------- *) -let pp_tyvarannot (ppe : PPEnv.t) fmt (ids: ty_param list) = +let pp_tyvarannot (ppe : PPEnv.t) fmt (ids: EcIdent.t list) = match ids with | [] -> () | ids -> Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar ppe)) ids @@ -2389,7 +2390,7 @@ let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((nm, cp1) : CP.codepos) Format.fprintf fmt "%a%a" (pp_list "" pp_nm) nm (pp_codepos1 ppe) cp1 (* -------------------------------------------------------------------- *) -let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * ty_param list * ty * prbody option) = +let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * EcIdent.t list * ty * prbody option) = let ppe = PPEnv.add_locals ppe ts in let pp_body fmt = @@ -2534,7 +2535,7 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = (* -------------------------------------------------------------------- *) let pp_opdecl_nt (ppe : PPEnv.t) fmt - ((basename, ts, _ty, nt) : symbol * ty_param list * ty * notation) + ((basename, ts, _ty, nt) : symbol * EcIdent.t list * ty * notation) = let ppe = PPEnv.add_locals ppe ts in @@ -2573,18 +2574,18 @@ let pp_opdecl let pp_decl fmt op = match op.op_kind with | OB_oper i -> - pp_opdecl_op ppe fmt (P.basename x, op.op_tparams, op_ty op, i) + pp_opdecl_op ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) | OB_pred i -> - pp_opdecl_pr ppe fmt (P.basename x, op.op_tparams, op_ty op, i) + pp_opdecl_pr ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) | OB_nott i -> let ppe = { ppe with PPEnv.ppe_fb = Sp.add x ppe.PPEnv.ppe_fb } in - pp_opdecl_nt ppe fmt (P.basename x, op.op_tparams, op_ty op, i) + pp_opdecl_nt ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) in Format.fprintf fmt "@[%a%a%a@]" pp_locality op.op_loca pp_name x pp_decl op let pp_added_op (ppe : PPEnv.t) fmt op = - let ppe = PPEnv.add_locals ppe op.op_tparams in - match op.op_tparams with + let ppe = PPEnv.add_locals ppe op.op_tparams.tyvars in + match op.op_tparams.tyvars with | [] -> Format.fprintf fmt ": @[%a@]" (pp_type ppe) op.op_ty | ts -> @@ -2605,14 +2606,14 @@ let tags_of_axkind = function | `Lemma -> [] let pp_axiom ?(long=false) (ppe : PPEnv.t) fmt (x, ax) = - let ppe = PPEnv.add_locals ppe ax.ax_tparams in + let ppe = PPEnv.add_locals ppe ax.ax_tparams.tyvars in let basename = P.basename x in let pp_spec fmt = pp_form ppe fmt ax.ax_spec and pp_name fmt = - match ax.ax_tparams with + match ax.ax_tparams.tyvars with | [] -> Format.fprintf fmt "%s" basename | ts -> Format.fprintf fmt "%s %a" basename (pp_tyvarannot ppe) ts @@ -3219,14 +3220,14 @@ module PPGoal = struct in (ppe, (id, pdk)) let pp_goal1 ?(pphyps = true) ?prpo ?(idx) (ppe : PPEnv.t) fmt (hyps, concl) = - let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar in + let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.tyvars in let ppe, pps = List.map_fold pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in idx |> oiter (Format.fprintf fmt "Goal #%d@\n"); if pphyps then begin begin - match hyps.EcBaseLogic.h_tvar with + match hyps.EcBaseLogic.h_tvar.tyvars with | [] -> Format.fprintf fmt "Type variables: @\n\n%!" | tv -> Format.fprintf fmt "Type variables: %a@\n\n%!" @@ -3265,12 +3266,12 @@ end (* -------------------------------------------------------------------- *) let pp_hyps (ppe : PPEnv.t) fmt hyps = let hyps = EcEnv.LDecl.tohyps hyps in - let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar in + let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.tyvars in let ppe, pps = List.map_fold PPGoal.pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in - begin match hyps.EcBaseLogic.h_tvar with + begin match hyps.EcBaseLogic.h_tvar.tyvars with | [] -> Format.fprintf fmt "Type variables: @\n\n%!" | tv -> Format.fprintf fmt "Type variables: %a@\n\n%!" @@ -3423,7 +3424,7 @@ let rec pp_instr_r (ppe : PPEnv.t) fmt i = let pp_branch fmt ((vars, s), (cname, _)) = let ptn = EcTypes.toarrow (List.snd vars) e.e_ty in - let ptn = f_op (EcPath.pqoname (EcPath.prefix p) cname) typ ptn in + let ptn = f_op (EcPath.pqoname (EcPath.prefix p) cname) ~tyargs:typ ptn in let ptn = f_app ptn (List.map (fun (x, ty) -> f_local x ty) vars) e.e_ty in Format.fprintf fmt "| %a => @[%a@]@ " @@ -3579,7 +3580,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = EcSymbols.pp_qsymbol (PPEnv.th_symb ppe p) | EcTheory.Th_instance ((typ, ty), tc, lc) -> begin - let ppe = PPEnv.add_locals ppe typ in (* FIXME *) + let ppe = PPEnv.add_locals ppe typ.tyvars in (* FIXME *) match tc with | (`Ring _ | `Field _) as tc -> begin @@ -3619,7 +3620,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = "%ainstance %s with [%a] %a@\n@[ %a@]" pp_locality lc name - (pp_paren (pp_list ",@ " (pp_tyvar ppe))) typ + (pp_paren (pp_list ",@ " (pp_tyvar ppe))) typ.tyvars (pp_type ppe) ty (pp_list "@\n" (fun fmt (name, op) -> diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 9055f24629..d296cf4857 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -225,7 +225,7 @@ let pt_of_uglobal_r ptenv p = (* FIXME: TC HOOK *) let fs = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in let ax = Fsubst.f_subst_tvar ~freshen:true fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ in + let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ.tyvars in { ptev_env = ptenv; ptev_pt = ptglobal ~tys:typ p; @@ -448,7 +448,7 @@ let lookup_named_psymbol (hyps : LDecl.hyps) ~hastyp fp = match fp with | ([], x) when LDecl.hyp_exists x hyps && not hastyp -> let (x, fp) = LDecl.hyp_by_name x hyps in - Some (`Local x, ([], fp)) + Some (`Local x, ({ EcDecl.idxvars = []; tyvars = [] }, fp)) | _ -> match EcEnv.Ax.lookup_opt fp (LDecl.toenv hyps) with @@ -515,7 +515,7 @@ let process_named_pterm pe (tvi, fp) = (* FIXME: TC HOOK *) let fs = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in let ax = Fsubst.f_subst_tvar ~freshen:false fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ in + let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ.tyvars in (p, (typ, ax)) diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index d4375e60b6..48872f27b2 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -194,6 +194,7 @@ let tc1_process_Xhl_formula_xreal tc pf = (* FIXME: TC HOOK - check parameter constraints *) (* ------------------------------------------------------------------ *) let pf_check_tvi (pe : proofenv) (typ : EcDecl.ty_params) (tvi : tvar_inst option) = + let typ = typ.tyvars in match tvi with | None -> () diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 7e8335c368..2192769c24 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -1088,7 +1088,7 @@ let reduce_head simplify ri env hyps f = let body = EcFol.form_of_expr body in (* FIXME subst-refact can we do both subst in once *) - let body = Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + let body = Tvar.f_subst ~freshen:true op.EcDecl.op_tparams.tyvars tys.types body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1732,7 +1732,7 @@ module User = struct let compile ~opts ~prio (env : EcEnv.env) p = let simp = if opts.EcTheory.ur_delta then - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in fun f -> odfl f (h_red_opt delta hyps f) else fun f -> f in @@ -1804,7 +1804,7 @@ module User = struct in doit empty_cst rule in let s_bds = Sid.of_list (List.map fst bds) - and s_tybds = Sid.of_list ax.ax_tparams in + and s_tybds = Sid.of_list ax.ax_tparams.tyvars in (* Variables appearing in types and formulas are always, respectively, * type and formula variables. @@ -1870,7 +1870,7 @@ module EqTest = struct let f1 = convert e1 in let f2 = convert e2 in - is_conv (LDecl.init env []) f1 f2 + is_conv (LDecl.init env { idxvars = []; tyvars = [] }) f1 f2 end) let for_pv = fun env ?(norm = true) -> for_pv env ~norm diff --git a/src/ecScope.ml b/src/ecScope.ml index 77e85a23e0..98b830daa9 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1305,7 +1305,7 @@ module Op = struct let codom = TT.transty TT.tp_relax eenv ue pty in let _env, xs = TT.trans_binding eenv ue args in let opty = EcTypes.toarrow (List.map snd xs) codom in - let opabs = EcDecl.mk_op ~opaque:optransparent [] codom None lc in + let opabs = EcDecl.mk_op ~opaque:optransparent { idxvars = []; tyvars = [] } codom None lc in let openv = EcEnv.Op.bind (unloc op.po_name) opabs env in let openv = EcEnv.Var.bind_locals xs openv in let reft = TT.trans_prop openv ue reft in @@ -1384,8 +1384,8 @@ module Op = struct List.fold_left (fun scope (rname, xs, ax, codom) -> let ax = let opargs = List.map (fun (x, xty) -> e_local x xty) xs in - let opapp = List.map tvar tparams in - let opapp = e_app (e_op opname opapp ty) opargs codom in + let opapp = List.map tvar tparams.tyvars in + let opapp = e_app (e_op opname ~tyargs:opapp ty) opargs codom in let subst = EcSubst.add_opdef EcSubst.empty opname ([], opapp) in let ax = EcSubst.subst_form subst ax in @@ -1399,12 +1399,12 @@ module Op = struct in let ax, axpm = - let bdpm = tparams in + let bdpm = tparams.tyvars in let axpm = List.map EcIdent.fresh bdpm in (Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) ax, axpm) in let ax = - { ax_tparams = axpm; + { ax_tparams = { idxvars = []; tyvars = axpm }; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -1419,11 +1419,12 @@ module Op = struct hierror ~loc "multiple names are only allowed for non-refined abstract operators"; let addnew scope name = - let nparams = List.map EcIdent.fresh tparams in + let nparams = List.map EcIdent.fresh tparams.tyvars in let subst = Tvar.init - tparams + tparams.tyvars (List.map tvar nparams) in - let rop = EcDecl.mk_op ~opaque:optransparent nparams (Tvar.subst subst ty) None lc in + let nparams_p = { idxvars = []; tyvars = nparams } in + let rop = EcDecl.mk_op ~opaque:optransparent nparams_p (Tvar.subst subst ty) None lc in bind scope (unloc name, rop) in List.fold_left addnew scope op.po_aliases @@ -1439,8 +1440,8 @@ module Op = struct hierror "for tag %s, load Distr first" tag; let oppath = EcPath.pqname (path scope) (unloc op.po_name) in - let nparams = List.map EcIdent.fresh tyop.op_tparams in - let subst = Tvar.init tyop.op_tparams (List.map tvar nparams) in + let nparams = List.map EcIdent.fresh tyop.op_tparams.tyvars in + let subst = Tvar.init tyop.op_tparams.tyvars (List.map tvar nparams) in let ty = Tvar.subst subst tyop.op_ty in let aty, rty = EcTypes.tyfun_flat ty in @@ -1451,13 +1452,13 @@ module Op = struct in let bds = List.combine (List.map EcTypes.fresh_id_of_ty aty) aty in - let ax = EcFol.f_op oppath (List.map tvar nparams) ty in + let ax = EcFol.f_op oppath ~tyargs:(List.map tvar nparams) ty in let ax = EcFol.f_app ax (List.map (curry f_local) bds) rty in - let ax = EcFol.f_app (EcFol.f_op pred [dty] (tfun rty tbool)) [ax] tbool in + let ax = EcFol.f_app (EcFol.f_op pred ~tyargs:[dty] (tfun rty tbool)) [ax] tbool in let ax = EcFol.f_forall (List.map (snd_map gtty) bds) ax in let ax = - { ax_tparams = nparams; + { ax_tparams = { idxvars = []; tyvars = nparams }; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -1550,7 +1551,7 @@ module Op = struct let aout = f_lambda (List.map2 (fun (_, ty) x -> (x, GTty ty)) params ids) aout in let opdecl = EcDecl.{ - op_tparams = []; + op_tparams = { idxvars = []; tyvars = [] }; op_ty = aout.f_ty; op_kind = OB_oper (Some (OP_Plain aout)); op_loca = op.ppo_locality; @@ -1574,7 +1575,7 @@ module Op = struct let mu = let sem = f_app - (f_op oppath [] opdecl.op_ty) + (f_op oppath opdecl.op_ty) (List.map (fun (x, ty) -> f_local x ty) locs) (match mode with `Det -> sig_.fs_ret | `Distr -> tdistr sig_.fs_ret) in @@ -1599,7 +1600,7 @@ module Op = struct in let prax = EcDecl.{ - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = prax; ax_kind = `Lemma; ax_loca = op.ppo_locality; @@ -1627,13 +1628,13 @@ module Op = struct {m;inv=(f_eq res.inv (f_app - (f_op oppath [] opdecl.op_ty) + (f_op oppath opdecl.op_ty) (List.map (fun (x, ty) -> f_local x ty) locs) sig_.fs_ret))}) in let prax = EcDecl.{ - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = hax; ax_kind = `Lemma; ax_loca = op.ppo_locality; @@ -2268,7 +2269,7 @@ module Ty = struct let scope = let decl = EcDecl.{ - tyd_params = []; + tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Abstract; tyd_loca = `Global; (* FIXME:SUBTYPE *) } in bind scope (unloc subtype.pst_name, decl) in @@ -2363,7 +2364,7 @@ module Ty = struct let op = EcEnv.Op.by_path p env in let opty = Tvar.subst - (Tvar.init op.op_tparams tvi) + (Tvar.init op.op_tparams.tyvars tvi) op.op_ty in (p, opty) @@ -2411,7 +2412,7 @@ module Ty = struct (fun (x, req) -> if not (Mstr.mem x symbs) then let ax = { - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = req; ax_kind = `Lemma; ax_loca = lc; @@ -2426,7 +2427,7 @@ module Ty = struct let t = { pl_loc = pt.pl_loc; pl_desc = Pby (Some [t]) } in let t = { pt_core = t; pt_intros = []; } in let ax = { - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = f; ax_kind = `Lemma; ax_smt = false; @@ -2481,7 +2482,7 @@ module Ty = struct let uidmap = EcUnify.UniEnv.close ue in (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) in - if not (List.is_empty (fst ty)) then + if not (List.is_empty (fst ty).tyvars && List.is_empty (fst ty).idxvars) then hierror "ring instances cannot be polymorphic"; let symbols = EcAlgTactic.ring_symbols env kind (snd ty) in @@ -2499,7 +2500,7 @@ module Ty = struct { scope with sc_env = List.fold_left add (let item = - EcTheory.Th_instance (([], snd ty), `Ring cr, tci.pti_loca) in + EcTheory.Th_instance (({ idxvars = []; tyvars = [] }, snd ty), `Ring cr, tci.pti_loca) in let item = EcTheory.mkitem ~import item in EcSection.add_item item scope.sc_env) [p_zmod; p_ring; p_idomain] } @@ -2524,7 +2525,7 @@ module Ty = struct let uidmap = EcUnify.UniEnv.close ue in (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) in - if not (List.is_empty (fst ty)) then + if not (List.is_empty (fst ty).tyvars && List.is_empty (fst ty).idxvars) then hierror "field instances cannot be polymorphic"; let symbols = EcAlgTactic.field_symbols env (snd ty) in let symbols = check_tci_operators env ty tci.pti_ops symbols in @@ -2541,7 +2542,7 @@ module Ty = struct sc_env = List.fold_left add (let item = - EcTheory.Th_instance (([], snd ty), `Field cr, tci.pti_loca) in + EcTheory.Th_instance (({ idxvars = []; tyvars = [] }, snd ty), `Field cr, tci.pti_loca) in let item = EcTheory.mkitem ~import item in EcSection.add_item item scope.sc_env) [p_zmod; p_ring; p_idomain; p_field] } diff --git a/src/ecSearch.ml b/src/ecSearch.ml index 8a3621c271..3a8a97a8cb 100644 --- a/src/ecSearch.ml +++ b/src/ecSearch.ml @@ -29,7 +29,7 @@ let as_bypattern (search : search) = let match_ (env : EcEnv.env) (search : search list) f = let module E = struct exception MatchFound end in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in let mode = EcMatching.fmsearch in let opts = lazy (EcFol.f_ops f) in diff --git a/src/ecSection.ml b/src/ecSection.ml index 97ef2ea33d..2bce619787 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -158,7 +158,7 @@ and on_ty (aenv : aenv) (ty : ty) = | Tvar _ -> () | Tglob m -> aenv.cb (`Module (mident m)) | Ttuple tys -> List.iter (on_ty aenv) tys - | Tconstr (p, tys) -> on_tyname aenv p; List.iter (on_ty aenv) tys + | Tconstr (p, tys) -> on_tyname aenv p; List.iter (on_ty aenv) tys.types | Tfun (ty1, ty2) -> List.iter (on_ty aenv) [ty1; ty2] (* -------------------------------------------------------------------- *) @@ -198,7 +198,7 @@ and on_expr (aenv : aenv) (e : expr) = | Eop (p, tys) -> begin on_opname aenv p; - List.iter (on_ty aenv) tys; + List.iter (on_ty aenv) tys.types; end in on_ty aenv e.e_ty; fornode () @@ -276,7 +276,7 @@ and on_form (aenv : aenv) (f : EcFol.form) = | EcAst.Fop (p, tys) -> begin on_opname aenv p; - List.iter (on_ty aenv) tys; + List.iter (on_ty aenv) tys.types; end and on_hf (aenv : aenv) hf = @@ -646,17 +646,18 @@ let add_declared_mod to_gen id modty = } let add_declared_ty to_gen path tydecl = - assert (tydecl.tyd_params = []); + assert (tydecl.tyd_params.tyvars = [] && tydecl.tyd_params.idxvars = []); let name = "'" ^ basename path in let id = EcIdent.create name in { to_gen with - tg_params = to_gen.tg_params @ [id]; + tg_params = { to_gen.tg_params with + tyvars = to_gen.tg_params.tyvars @ [id] }; tg_subst = EcSubst.add_tydef to_gen.tg_subst path ([], tvar id); } let add_declared_op to_gen path opdecl = assert ( - opdecl.op_tparams = [] && + opdecl.op_tparams.tyvars = [] && opdecl.op_tparams.idxvars = [] && match opdecl.op_kind with | OB_oper None | OB_pred None -> true | _ -> false); @@ -677,7 +678,7 @@ let add_declared_op to_gen path opdecl = let rec aux fv e = let fv = EcIdent.fv_union fv (tvar_fv e.e_ty) in match e.e_node with - | Eop(_, tys) -> List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) fv tys + | Eop(_, tys) -> List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) fv tys.types | Equant(_,d,e) -> let fv = List.fold_left (fun fv (_,ty) -> EcIdent.fv_union fv (tvar_fv ty)) fv d in aux fv e @@ -699,7 +700,7 @@ and fv_and_tvar_f f = let rec aux f = fv := EcIdent.fv_union !fv (tvar_fv f.f_ty); match f.f_node with - | Fop(_, tys) -> fv := List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) !fv tys + | Fop(_, tys) -> fv := List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) !fv tys.types | Fquant(_, d, f) -> fv := List.fold_left (fun fv (_,gty) -> EcIdent.fv_union fv (gty_fv_and_tvar gty)) !fv d; aux f @@ -723,7 +724,7 @@ let tydecl_fv tyd = | Record (_f, l) -> List.fold_left (fun fv (_, ty) -> EcIdent.fv_union fv (ty_fv_and_tvar ty)) Mid.empty l in - List.fold_left (fun fv id -> Mid.remove id fv) fv tyd.tyd_params + List.fold_left (fun fv id -> Mid.remove id fv) fv tyd.tyd_params.tyvars let op_body_fv body ty = let fv = ty_fv_and_tvar ty in @@ -768,7 +769,7 @@ let notation_fv nota = EcIdent.fv_union (Mid.remove id fv) (ty_fv_and_tvar ty)) fv nota.ont_args let generalize_extra_ty to_gen fv = - List.filter (fun id -> Mid.mem id fv) to_gen.tg_params + List.filter (fun id -> Mid.mem id fv) to_gen.tg_params.tyvars let rec generalize_extra_args binds fv = match binds with @@ -803,10 +804,12 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let tydecl = EcSubst.subst_tydecl to_gen.tg_subst tydecl in let fv = tydecl_fv tydecl in let extra = generalize_extra_ty to_gen fv in - let tyd_params = extra @ tydecl.tyd_params in - let args = List.map tvar tyd_params in - let params = tydecl.tyd_params in - let tosubst = params, tconstr path args in + let tyd_params : ty_params = + { idxvars = tydecl.tyd_params.idxvars; + tyvars = extra @ tydecl.tyd_params.tyvars; } in + let args = List.map tvar tyd_params.tyvars in + let params = tydecl.tyd_params.tyvars in + let tosubst = params, tconstr ~tyargs:args path in let tg_subst, tyd_type = match tydecl.tyd_type with | Concrete _ | Abstract -> @@ -818,10 +821,10 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let tg_subst = EcSubst.add_tydef tg_subst path tosubst in let rsubst = ref subst in let rtg_subst = ref tg_subst in - let tin = tconstr path args in + let tin = tconstr ~tyargs:args path in let add_op (s, ty) = let p = pqname prefix s in - let tosubst = params, e_op p args (tfun tin ty) in + let tosubst = params, e_op p ~tyargs:args (tfun tin ty) in rsubst := EcSubst.add_opdef !rsubst p tosubst; rtg_subst := EcSubst.add_opdef !rtg_subst p tosubst; s, ty @@ -837,12 +840,12 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let subst_ty = EcSubst.subst_ty subst in let rsubst = ref subst in let rtg_subst = ref tg_subst in - let tout = tconstr path args in + let tout = tconstr ~tyargs:args path in let add_op (s,tys) = let tys = List.map subst_ty tys in let p = pqname prefix s in let pty = toarrow tys tout in - let tosubst = params, e_op p args pty in + let tosubst = params, e_op p ~tyargs:args pty in rsubst := EcSubst.add_opdef !rsubst p tosubst; rtg_subst := EcSubst.add_opdef !rtg_subst p tosubst ; s, tys in @@ -874,10 +877,12 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_oper None -> let fv = ty_fv_and_tvar operator.op_ty in let extra = generalize_extra_ty to_gen fv in - let tparams = extra @ operator.op_tparams in + let tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra @ operator.op_tparams.tyvars; } in let opty = operator.op_ty in - let args = List.map tvar tparams in - let tosubst = (operator.op_tparams, e_op path args opty) in + let args = List.map tvar tparams.tyvars in + let tosubst = (operator.op_tparams.tyvars, e_op path ~tyargs:args opty) in let tg_subst = EcSubst.add_opdef to_gen.tg_subst path tosubst in tg_subst, mk_op ~opaque:operator.op_opaque tparams opty None `Global @@ -885,10 +890,12 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_pred None -> let fv = ty_fv_and_tvar operator.op_ty in let extra = generalize_extra_ty to_gen fv in - let tparams = extra @ operator.op_tparams in + let tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra @ operator.op_tparams.tyvars; } in let opty = operator.op_ty in - let args = List.map tvar tparams in - let tosubst = (operator.op_tparams, f_op path args opty) in + let args = List.map tvar tparams.tyvars in + let tosubst = (operator.op_tparams.tyvars, f_op path ~tyargs:args opty) in let tg_subst = EcSubst.add_pddef to_gen.tg_subst path tosubst in tg_subst, mk_op ~opaque:operator.op_opaque tparams opty None `Global @@ -896,15 +903,17 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_oper (Some body) -> let fv = op_body_fv body operator.op_ty in let extra_t = generalize_extra_ty to_gen fv in - let tparams = extra_t @ operator.op_tparams in + let tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra_t @ operator.op_tparams.tyvars; } in let extra_a = generalize_extra_args to_gen.tg_binds fv in let opty = toarrow (List.map snd extra_a) operator.op_ty in - let t_args = List.map tvar tparams in - let eop = e_op path t_args opty in + let t_args = List.map tvar tparams.tyvars in + let eop = e_op path ~tyargs:t_args opty in let e = e_app eop (List.map (fun (id,ty) -> e_local id ty) extra_a) operator.op_ty in - let tosubst = (operator.op_tparams, e) in + let tosubst = (operator.op_tparams.tyvars, e) in let tg_subst = EcSubst.add_opdef to_gen.tg_subst path tosubst in let body = @@ -934,15 +943,17 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_pred (Some body) -> let fv = pr_body_fv body operator.op_ty in let extra_t = generalize_extra_ty to_gen fv in - let op_tparams = extra_t @ operator.op_tparams in + let op_tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra_t @ operator.op_tparams.tyvars; } in let extra_a = generalize_extra_args to_gen.tg_binds fv in let op_ty = toarrow (List.map snd extra_a) operator.op_ty in - let t_args = List.map tvar op_tparams in - let fop = f_op path t_args op_ty in + let t_args = List.map tvar op_tparams.tyvars in + let fop = f_op path ~tyargs:t_args op_ty in let f = f_app fop (List.map (fun (id,ty) -> f_local id ty) extra_a) operator.op_ty in - let tosubst = (operator.op_tparams, f) in + let tosubst = (operator.op_tparams.tyvars, f) in let tg_subst = EcSubst.add_pddef to_gen.tg_subst path tosubst in let body = @@ -965,7 +976,9 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_nott nott -> let fv = notation_fv nott in let extra_t = generalize_extra_ty to_gen fv in - let op_tparams = extra_t @ operator.op_tparams in + let op_tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra_t @ operator.op_tparams.tyvars; } in let extra_a = generalize_extra_args to_gen.tg_binds fv in let op_ty = toarrow (List.map snd extra_a) operator.op_ty in let nott = { nott with ont_args = extra_a @ nott.ont_args; } in @@ -1000,11 +1013,13 @@ let generalize_axiom to_gen prefix (name, ax) = generalize_extra_forall ~imply:true to_gen.tg_binds ax.ax_spec in let extra_t = generalize_extra_ty to_gen (fv_and_tvar_f ax_spec) in - let ax_tparams = extra_t @ ax.ax_tparams in + let ax_tparams : ty_params = + { idxvars = ax.ax_tparams.idxvars; + tyvars = extra_t @ ax.ax_tparams.tyvars; } in to_gen, Some (Th_axiom (name, {ax with ax_tparams; ax_spec})) | `Declare -> assert (is_axiom ax.ax_kind); - assert (ax.ax_tparams = []); + assert (ax.ax_tparams.tyvars = [] && ax.ax_tparams.idxvars = []); let to_gen = add_clear to_gen (`Ax path) in let to_gen = { to_gen with tg_binds = add_imp to_gen.tg_binds ax.ax_spec } in @@ -1158,8 +1173,8 @@ let check s scenv who b = let check_section scenv who = check "is only allowed in section" scenv who (scenv.sc_insec) -let check_polymorph scenv who typarams = - check "cannot be polymorphic" scenv who (typarams = []) +let check_polymorph scenv who (typarams : ty_params) = + check "cannot be polymorphic" scenv who (typarams.tyvars = [] && typarams.idxvars = []) let check_abstract = check "should be abstract" @@ -1486,7 +1501,7 @@ and generalize_lc_items (genenv : to_gen) (prefix : path) (items : sc_item list) let genenv_of_scenv (scenv : scenv) : to_gen = { tg_env = Option.get (scenv.sc_top) - ; tg_params = [] + ; tg_params = { idxvars = []; tyvars = [] } ; tg_binds = [] ; tg_subst = EcSubst.empty ; tg_clear = empty_locals } diff --git a/src/ecSmt.ml b/src/ecSmt.ml index fdc3d18f61..c7220c51e4 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -265,20 +265,20 @@ let wsnd genv arg = wproj_tuple genv arg 1 let trans_tv lenv id = oget (Mid.find_opt id lenv.le_tv) (* -------------------------------------------------------------------- *) -let lenv_of_tparams ts = - let trans_tv env (id : ty_param) = (* FIXME: TC HOOK *) +let lenv_of_tparams (ts : ty_params) = + let trans_tv env (id : EcIdent.t) = (* FIXME: TC HOOK *) let tv = WTy.create_tvsymbol (preid id) in { env with le_tv = Mid.add id (WTy.ty_var tv) env.le_tv }, tv in - List.map_fold trans_tv empty_lenv ts + List.map_fold trans_tv empty_lenv ts.tyvars -let lenv_of_tparams_for_hyp genv ts = - let trans_tv env (id : ty_param) = (* FIXME: TC HOOK *) +let lenv_of_tparams_for_hyp genv (ts : ty_params) = + let trans_tv env (id : EcIdent.t) = (* FIXME: TC HOOK *) let ts = WTy.create_tysymbol (preid id) [] WTy.NoDef in genv.te_task <- WTask.add_ty_decl genv.te_task ts; { env with le_tv = Mid.add id (WTy.ty_app ts []) env.le_tv }, ts in - List.map_fold trans_tv empty_lenv ts + List.map_fold trans_tv empty_lenv ts.tyvars (* -------------------------------------------------------------------- *) let instantiate tparams ~textra targs tres tys = @@ -375,8 +375,10 @@ let rec trans_ty ((genv, lenv) as env) ty = | Ttuple ts-> wty_tuple genv (trans_tys env ts) | Tconstr (p, tys) -> + (* Phase 0: indices not yet supported by SMT *) + assert (List.is_empty tys.indices); let id = trans_pty genv p in - WTy.ty_app id (trans_tys env tys) + WTy.ty_app id (trans_tys env tys.types) | Tfun (t1, t2) -> WTy.ty_func (trans_ty env t1) (trans_ty env t2) @@ -415,7 +417,7 @@ and trans_tydecl genv (p, tydecl) = Hp.add genv.te_ty p ts; - let wdom = tconstr p (List.map tvar tydecl.tyd_params) in + let wdom = tconstr ~tyargs:(List.map tvar tydecl.tyd_params.tyvars) p in let wdom = trans_ty (genv, lenv) wdom in let for_ctor (c, ctys) = @@ -434,7 +436,7 @@ and trans_tydecl genv (p, tydecl) = Hp.add genv.te_ty p ts; - let wdom = tconstr p (List.map tvar tydecl.tyd_params) in + let wdom = tconstr ~tyargs:(List.map tvar tydecl.tyd_params.tyvars) p in let wdom = trans_ty (genv, lenv) wdom in let for_field (fname, fty) = @@ -679,7 +681,7 @@ and trans_form ((genv, lenv) as env : tenv * lenv) (fp : form) = | Fop _ -> trans_app env fp [] (* Special case for `%r` *) - | Fapp({ f_node = Fop (p, [])}, [{f_node = Fint n}]) + | Fapp({ f_node = Fop (p, { indices = []; types = [] })}, [{f_node = Fint n}]) when p_equal p CI_Real.p_real_of_int -> WTerm.t_real_const (BI.to_why3 n) @@ -711,8 +713,10 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = trans_fun env bds body args | Fop (p, ts) -> + (* Phase 0: indices not yet supported by SMT *) + assert (List.is_empty ts.indices); let wop = trans_op genv p in - let tys = List.map (trans_ty (genv,lenv)) ts in + let tys = List.map (trans_ty (genv,lenv)) ts.types in apply_wop genv wop tys args | Flocal x when Hid.mem genv.te_lc x -> @@ -764,7 +768,7 @@ and trans_branch (genv, lenv) (p, _dty, tvs) (f, (cname, argsty)) = in let lenv, ws = trans_lvars genv lenv xs in - let wcty = trans_ty (genv, lenv) (tconstr p tvs) in + let wcty = trans_ty (genv, lenv) (tconstr ~tyargs:tvs p) in let ws = List.map WTerm.pat_var ws in let ws = WTerm.pat_app csymb ws wcty in let wf = trans_app (genv, lenv) f [] in @@ -1034,7 +1038,7 @@ and create_op ?(body = false) (genv : tenv) p = let lenv, wparams = lenv_of_tparams op.op_tparams in let dom, codom = EcEnv.Ty.signature genv.te_env op.op_ty in let textra = - List.filter (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op.op_ty))) op.op_tparams in + List.filter (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op.op_ty))) op.op_tparams.tyvars in let textra = List.map (fun tv -> trans_ty (genv,lenv) (tvar tv)) textra in let wdom = trans_tys (genv, lenv) dom in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 826ba54590..575265a72e 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -834,14 +834,15 @@ let subst_top_module (s : subst) (m : top_module_expr) = tme_loca = m.tme_loca; } (* -------------------------------------------------------------------- *) -let fresh_tparam (s : subst) (x : ty_param) = +let fresh_tparam (s : subst) (x : EcIdent.t) = let newx = EcIdent.fresh x in let s = add_tyvar s x (tvar newx) in (s, newx) (* -------------------------------------------------------------------- *) let fresh_tparams (s : subst) (tparams : ty_params) = - List.fold_left_map fresh_tparam s tparams + let s, tyvars = List.fold_left_map fresh_tparam s tparams.tyvars in + (s, { tparams with tyvars }) (* -------------------------------------------------------------------- *) let subst_genty (s : subst) (tparams, ty) = @@ -1111,12 +1112,12 @@ let init_tparams (params : (EcIdent.t * ty) list) : subst = (* -------------------------------------------------------------------- *) let open_oper op tys = - let s = List.combine op.op_tparams tys in + let s = List.combine op.op_tparams.tyvars tys in let s = init_tparams s in (subst_ty s op.op_ty, subst_op_kind s op.op_kind) let open_tydecl tyd tys = - let s = List.combine tyd.tyd_params tys in + let s = List.combine tyd.tyd_params.tyvars tys in let s = init_tparams s in subst_tydecl_body s tyd.tyd_type diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 5daaded83f..3c2a6093c4 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -267,7 +267,7 @@ end = struct let ntyargs = match fst tyd with | `BySyntax (tyargs, _) -> List.length tyargs - | `ByPath p -> List.length (EcEnv.Ty.by_path p oc.oc_env).tyd_params in + | `ByPath p -> List.length (EcEnv.Ty.by_path p oc.oc_env).tyd_params.tyvars in let { pl_loc = lc; pl_desc = ((nm, x) as name) } = name in @@ -276,7 +276,7 @@ end = struct | None -> clone_error oc.oc_env (CE_UnkOverride (OVK_Type, name)); | Some refty -> - if List.length refty.tyd_params <> ntyargs then + if List.length refty.tyd_params.tyvars <> ntyargs then clone_error oc.oc_env (CE_TypeArgMism (OVK_Type, name)) in let evc = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 92c8c2369f..fe35282d6f 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -84,8 +84,8 @@ module Compatible : sig val for_ty : EcEnv.env -> EcUnify.unienv - -> EcIdent.ident list * ty - -> EcIdent.ident list * ty + -> ty_params * ty + -> ty_params * ty -> unit val for_tydecl : tydecl comparator @@ -101,9 +101,9 @@ end = struct let check (b : bool) = if not b then raise CoreIncompatible - let for_tparams rtyvars ntyvars = - let rlen = List.length rtyvars - and nlen = List.length ntyvars in + let for_tparams (rtp : ty_params) (ntp : ty_params) = + let rlen = List.length rtp.tyvars + and nlen = List.length ntp.tyvars in if rlen <> nlen then raise (Incompatible (NotSameNumberOfTyParam (rlen, nlen))) @@ -124,7 +124,7 @@ end = struct let for_ty (env : EcEnv.env) (ue : EcUnify.unienv) (rtyvars, rty) (ntyvars, nty) = for_tparams rtyvars ntyvars; - let subst = CS.Tvar.init rtyvars (List.map tvar ntyvars) in + let subst = CS.Tvar.init rtyvars.tyvars (List.map tvar ntyvars.tyvars) in let rty = CS.Tvar.subst subst rty in try EcUnify.unify env ue rty nty @@ -165,11 +165,11 @@ end = struct | Record rec1, Record rec2 -> for_record hyps rec1 rec2 | _, Concrete { ty_node = Tconstr (p, tys) } -> - let ty_body2 = get_open_tydecl (toenv hyps) p tys in + let ty_body2 = get_open_tydecl (toenv hyps) p tys.types in tybody hyps ty_body1 ty_body2 | Concrete{ ty_node = Tconstr (p, tys) }, _ -> - let ty_body1 = get_open_tydecl (toenv hyps) p tys in + let ty_body1 = get_open_tydecl (toenv hyps) p tys.types in tybody hyps ty_body1 ty_body2 | _, _ -> raise CoreIncompatible @@ -180,7 +180,7 @@ end = struct for_tparams params tyd2.tyd_params; - let tparams = List.map tvar params in + let tparams = List.map tvar params.tyvars in let ty_body1 = tyd1.tyd_type in let ty_body2 = EcSubst.open_tydecl tyd2 tparams in @@ -228,7 +228,7 @@ end = struct let (env, s) = EcReduction.check_bindings CoreIncompatible (toenv hyps) s prc1.prc_bds prc2.prc_bds in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in check (List.compare_lengths prc1.prc_spec prc2.prc_spec = 0); let for_spec (f1 : form) (f2 : form) = check (EcReduction.is_conv hyps f1 (EcSubst.subst_form s f2)) in @@ -245,11 +245,11 @@ end = struct check (EcReduction.is_conv ~ri:ri_compatible hyps f1 f2) | OP_Plain { f_node = Fop (p, tys) }, _ -> - let ob1 = get_open_oper (toenv hyps) p tys in + let ob1 = get_open_oper (toenv hyps) p tys.types in for_oper hyps ob1 ob2 | _, OP_Plain { f_node = Fop (p, tys) } -> - let ob2 = get_open_oper (toenv hyps) p tys in + let ob2 = get_open_oper (toenv hyps) p tys.types in for_oper hyps ob1 ob2 | OP_Constr (p1, i1), OP_Constr (p2, i2) -> @@ -274,11 +274,11 @@ end = struct check (EcReduction.is_conv hyps f1 f2) | PR_Plain { f_node = Fop (p, tys) }, _ -> - let pb1 = get_open_pred (toenv hyps) p tys in + let pb1 = get_open_pred (toenv hyps) p tys.types in for_pred hyps pb1 pb2 | _, PR_Plain { f_node = Fop (p, tys) } -> - let pb2 = get_open_pred (toenv hyps) p tys in + let pb2 = get_open_pred (toenv hyps) p tys.types in for_pred hyps pb1 pb2 | PR_Ind pr1, PR_Ind pr2 -> @@ -297,7 +297,7 @@ end = struct for_tparams oper1.op_tparams oper2.op_tparams; let oty1, okind1 = oper1.op_ty, oper1.op_kind in - let tparams = List.map tvar params in + let tparams = List.map tvar params.tyvars in let oty2, okind2 = EcSubst.open_oper oper2 tparams in if not (EcReduction.EqTest.for_type env oty1 oty2) then @@ -426,10 +426,11 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd let nargs = List.map (fun x -> (EcIdent.create (unloc x))) nargs in - let ue = EcUnify.UniEnv.create (Some nargs) in + let nargs_p = { idxvars = []; tyvars = nargs } in + let ue = EcUnify.UniEnv.create (Some nargs_p) in let ntyd = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in let decl = - { tyd_params = nargs; + { tyd_params = nargs_p; tyd_type = Concrete ntyd; tyd_loca = otyd.tyd_loca; } @@ -438,8 +439,8 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `ByPath p -> begin match EcEnv.Ty.by_path_opt p env with | Some reftyd -> - let tyargs = List.map tvar reftyd.tyd_params in - let body = tconstr p tyargs in + let tyargs = List.map tvar reftyd.tyd_params.tyvars in + let body = tconstr ~tyargs p in let decl = { reftyd with tyd_type = Concrete body; } in (decl, body) @@ -447,9 +448,10 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd end | `Direct ty -> begin - assert (List.is_empty otyd.tyd_params); + assert (List.is_empty otyd.tyd_params.tyvars + && List.is_empty otyd.tyd_params.idxvars); let decl = - { tyd_params = []; + { tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Concrete ty; tyd_loca = otyd.tyd_loca; } @@ -465,7 +467,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `Inline _ -> let subst = EcSubst.add_tydef - subst (xpath ove x) (newtyd.tyd_params, body) in + subst (xpath ove x) (newtyd.tyd_params.tyvars, body) in let subst = (* FIXME: HACK *) @@ -473,10 +475,10 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | Datatype { tydt_ctors = octors }, Tconstr (np, _) -> begin match (EcEnv.Ty.by_path np env).tyd_type with | Datatype { tydt_ctors = _ } -> - let newtparams = newtyd.tyd_params in + let newtparams = newtyd.tyd_params.tyvars in let newtparams_ty = List.map tvar newtparams in - let newdtype = tconstr np newtparams_ty in - let tysubst = CS.Tvar.init otyd.tyd_params newtparams_ty in + let newdtype = tconstr ~tyargs:newtparams_ty np in + let tysubst = CS.Tvar.init otyd.tyd_params.tyvars newtparams_ty in List.fold_left (fun subst (name, tyargs) -> let np = EcPath.pqoname (EcPath.prefix np) name in @@ -486,7 +488,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd tyargs in EcSubst.add_opdef subst (xpath ove name) - (newtparams, e_op np newtparams_ty (toarrow newtyargs newdtype)) + (newtparams, e_op np ~tyargs:newtparams_ty (toarrow newtyargs newdtype)) ) subst octors | _ -> subst end @@ -572,13 +574,13 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = | `ByPath p -> begin match EcEnv.Op.by_path_opt p env with | Some ({ op_kind = OB_oper _ } as refop) -> - let tyargs = List.map tvar refop.op_tparams in + let tyargs = List.map tvar refop.op_tparams.tyvars in let body = if refop.op_clinline then (match refop.op_kind with | OB_oper (Some (OP_Plain body)) -> body | _ -> assert false) - else EcFol.f_op p tyargs refop.op_ty in + else EcFol.f_op p ~tyargs refop.op_ty in let decl = { refop with op_kind = OB_oper (Some (OP_Plain body)); @@ -589,13 +591,14 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = end | `Direct body -> - assert (List.is_empty refop.op_tparams); + assert (List.is_empty refop.op_tparams.tyvars + && List.is_empty refop.op_tparams.idxvars); let newop = mk_op ~opaque:optransparent ~clinline:(opmode <> `Alias) - [] body.f_ty (Some (OP_Plain body)) refop.op_loca in + { idxvars = []; tyvars = [] } body.f_ty (Some (OP_Plain body)) refop.op_loca in (newop, body) - + in match opmode with | `Alias -> @@ -609,7 +612,7 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = with EcFol.CannotTranslate -> clone_error env (CE_InlinedOpIsForm (snd ove.ovre_prefix, x)) in - let subst1 = (newop.op_tparams, body) in + let subst1 = (newop.op_tparams.tyvars, body) in let subst = EcSubst.add_opdef subst (xpath ove x) subst1 in (newop, subst, x, false) in @@ -699,13 +702,13 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = | `ByPath p -> begin match EcEnv.Op.by_path_opt p env with | Some ({ op_kind = OB_pred _ } as refop) -> - let tyargs = List.map tvar refop.op_tparams in + let tyargs = List.map tvar refop.op_tparams.tyvars in let body = if refop.op_clinline then (match refop.op_kind with | OB_pred (Some (PR_Plain body)) -> body | _ -> assert false) - else EcFol.f_op p tyargs refop.op_ty in + else EcFol.f_op p ~tyargs refop.op_ty in let newpr = { refop with op_kind = OB_pred (Some (PR_Plain body)); @@ -716,9 +719,10 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = end | `Direct body -> - assert (List.is_empty refpr.op_tparams); + assert (List.is_empty refpr.op_tparams.tyvars + && List.is_empty refpr.op_tparams.idxvars); let newpr = - { op_tparams = []; + { op_tparams = { idxvars = []; tyvars = [] }; op_ty = body.f_ty; op_kind = OB_pred (Some (PR_Plain body)); op_opaque = oopr.op_opaque; @@ -734,7 +738,7 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = (newpr, subst, x) | `Inline _ -> - let subst1 = (newpr.op_tparams, body) in + let subst1 = (newpr.op_tparams.tyvars, body) in let subst = EcSubst.add_pddef subst (xpath ove x) subst1 in (newpr, subst, x) diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 593b78b72d..0fc53ff65b 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -487,7 +487,7 @@ let transtyvars (env : EcEnv.env) (loc, tparams) = let for1 ({ pl_desc = x }) = (EcIdent.create x) in if not (List.is_unique (List.map unloc tparams)) then tyerror loc env DuplicatedTyVar; - List.map for1 tparams) + { EcDecl.idxvars = []; tyvars = List.map for1 tparams }) in EcUnify.UniEnv.create tparams @@ -1002,11 +1002,12 @@ let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = tyerror ty.pl_loc env (UnknownTypeName name) | Some (p, tydecl) -> - if tydecl.tyd_params <> [] then begin - let nargs = List.length tydecl.tyd_params in + let { tyvars; idxvars = _ } = tydecl.tyd_params in + if tyvars <> [] then begin + let nargs = List.length tyvars in tyerror ty.pl_loc env (InvalidTypeAppl (name, nargs, 0)) end; - tconstr p [] + tconstr p end | PTfun(ty1,ty2) -> @@ -1019,13 +1020,13 @@ let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = | Some (p, tydecl) -> let nargs = List.length tyargs in - let expected = List.length tydecl.tyd_params in + let expected = List.length tydecl.tyd_params.tyvars in if nargs <> expected then tyerror ty.pl_loc env (InvalidTypeAppl (name, expected, nargs)); let tyargs = transtys tp env ue tyargs in - tconstr p tyargs + tconstr ~tyargs p end | PTglob gp -> let mo,_ = trans_msymbol env gp in @@ -1035,7 +1036,7 @@ and transtys tp (env : EcEnv.env) ue tys = List.map (transty tp env ue) tys let transty_for_decl env ty = - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in transty tp_nothing env ue ty (* -------------------------------------------------------------------- *) @@ -1087,7 +1088,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in - let reccty = tconstr recp (List.map tvar recty.tyd_params) in + let reccty = tconstr ~tyargs:(List.map tvar recty.tyd_params.tyvars) recp in let reccty, rectvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in let fields = List.fold_left @@ -1227,9 +1228,9 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in - let reccty = tconstr recp (List.map tvar recty.tyd_params) in + let reccty = tconstr ~tyargs:(List.map tvar recty.tyd_params.tyvars) recp in let reccty, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let tysopn = Tvar.init recty.tyd_params rtvi in + let tysopn = Tvar.init recty.tyd_params.tyvars rtvi in let fields = List.fold_left @@ -1597,7 +1598,7 @@ let form_of_opselect in (f_lambda flam (Fsubst.f_subst subst body), args) | (`Op _ | `Lc _ | `Pv _) as sel -> let op = match sel with - | `Op (p, tys) -> f_op p tys ty + | `Op (p, tys) -> f_op p ~tyargs:tys ty | `Lc id -> f_local id ty | `Pv (me, pv) -> var_or_proj (fun x ty -> (f_pvar x ty (oget me)).inv) f_proj pv ty @@ -1625,7 +1626,7 @@ let i_asgn_lv (_loc : EcLocation.t) (_env : EcEnv.env) lv e = match lv with | Lval lv -> i_asgn (lv, e) | LvMap ((op,tys), x, ei, ty) -> - let op = e_op op tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in + let op = e_op op ~tyargs:tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in i_asgn (LvVar (x,ty), e_app op [e_var x ty; ei; e] ty) let i_rnd_lv loc env lv e = @@ -2085,7 +2086,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let eval_supdate env sup si = match sup with | Pups_add (s, after) -> - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let s = transstmt env ue s in let ts = Tuni.subst (UE.close ue) in if after then @@ -2106,7 +2107,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = (* Insert an if with condition `e` with body `tl` *) | Pupc_add (e, after) -> let loc = e.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e, ty = transexp env `InProc ue e in let ts = Tuni.subst (UE.close ue) in let ty = ty_subst ts ty in @@ -2119,7 +2120,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = (* Change the condition expression to `e` for a conditional instr `i` *) | Pupc_mod e -> begin let loc = e.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e, ty = transexp env `InProc ue e in let ts = Tuni.subst (UE.close ue) in let ty = ty_subst ts ty in @@ -2148,7 +2149,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = (* match e with | C a b c => b | ... ---> (a, b, c) <- oget (get_as_C e); b *) let typ, tydc, tyinst = oget (EcEnv.Ty.get_top_decl e.e_ty env) in - let tyinst = List.combine tydc.tyd_params tyinst in + let tyinst = List.combine tydc.tyd_params.tyvars tyinst in let indt = oget (EcDecl.tydecl_as_datatype tydc) in let cnames = List.fst indt.tydt_ctors in let r = List.assoc_opt cn (List.combine cnames bs) in @@ -2174,7 +2175,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let asgn = EcModules.lv_of_list pvs |> omap (fun lv -> let rty = ttuple (List.snd p) in let proj = EcInductive.datatype_proj_path typ cn in - let proj = e_op proj (List.snd tyinst) (tfun e.e_ty (toption rty)) in + let proj = e_op proj ~tyargs:(List.snd tyinst) (tfun e.e_ty (toption rty)) in let proj = e_app proj [e] (toption rty) in let proj = e_oget proj rty in i_asgn (lv, proj)) @@ -2221,7 +2222,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let ret = match fd.f_ret, pupdate_res with | Some e, Some e' -> let loc = e'.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e', ty = transexp env `InProc ue e' in unify_or_fail env ue loc ~expct:e.e_ty ty; let ts = Tuni.subst (UE.close ue) in @@ -2394,7 +2395,7 @@ and transstruct1 (env : EcEnv.env) (st : pstructure_item located) = [], items | Pst_fun (decl, body) -> begin - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let env = EcEnv.Fun.enter decl.pfd_name.pl_desc env in (* Type-check function parameters / check for dups *) @@ -2890,7 +2891,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let pt = trans_pattern env ps ue ppt in let ev = EcMatching.MEV.of_idents (Mid.keys !ps) `Form in let mode = EcMatching.fmrigid in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { EcDecl.idxvars = []; tyvars = [] } in let test (_ : int) f = try @@ -2957,7 +2958,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let pt = trans_pattern lenv ps ue ppt in let ev = EcMatching.MEV.of_idents (x :: Mid.keys !ps) `Form in let mode = EcMatching.fmrigid in - let hyps = EcEnv.LDecl.init lenv [] in + let hyps = EcEnv.LDecl.init lenv { EcDecl.idxvars = []; tyvars = [] } in let (ue, _, ev) = try EcMatching.f_match mode hyps (ue, ev) pt f @@ -2978,7 +2979,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let pt = trans_pattern lenv ps ue ppt in let ev = EcMatching.MEV.of_idents (xs @ Mid.keys !ps) `Form in let mode = EcMatching.fmrigid in - let hyps = EcEnv.LDecl.init lenv [] in + let hyps = EcEnv.LDecl.init lenv { EcDecl.idxvars = []; tyvars = [] } in let (ue, _, ev) = try EcMatching.f_match mode hyps (ue, ev) pt f @@ -3001,7 +3002,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let pt = trans_pattern env ps ue ppt in let ev = EcMatching.MEV.of_idents (Mid.keys !ps) `Form in let mode = EcMatching.fmrigid in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { EcDecl.idxvars = []; tyvars = [] } in let test target = try @@ -3386,12 +3387,12 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let (ctor, fields, (rtvi, reccty)) = let proj (recp, name, (rtvi, reccty), pty, arg) = let proj = EcPath.pqname recp name in - let proj = f_op proj rtvi (tfun reccty pty) in + let proj = f_op proj ~tyargs:rtvi (tfun reccty pty) in f_app proj [arg] pty in trans_record env ue ((fun f -> let f = transf env f in (f, f.f_ty)), proj) (f.pl_loc, b, fields) in - let ctor = f_op ctor rtvi (toarrow (List.map snd fields) reccty) in + let ctor = f_op ctor ~tyargs:rtvi (toarrow (List.map snd fields) reccty) in f_app ctor (List.map fst fields) reccty | PFproj (subf, x) -> begin @@ -3409,7 +3410,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let rty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (tfun subf.f_ty rty) pty with EcUnify.UnificationFailure _ -> assert false); - f_app (f_op op tvi pty) [subf] rty + f_app (f_op op ~tyargs:tvi pty) [subf] rty end | PFproji (psubf, i) -> begin diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 3b54922716..c620b6a937 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -238,7 +238,7 @@ module UniEnv = struct }; id end - let create (vd : EcIdent.t list option) = + let create (vd : ty_params option) = let ue = { ue_uf = UF.initial; ue_named = Mstr.empty; @@ -250,6 +250,7 @@ module UniEnv = struct match vd with | None -> ue | Some vd -> + let vd = vd.tyvars in let vdmap = List.map (fun x -> (EcIdent.name x, x)) vd in { ue with ue_named = Mstr.of_list vdmap; @@ -263,6 +264,7 @@ module UniEnv = struct ue := { !ue with ue_uf = uf }; uid let opentvi (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = + let params = params.tyvars in match tvi with | None -> List.fold_left @@ -285,7 +287,7 @@ module UniEnv = struct List.fold_left for1 Mid.empty params let subst_tv (subst : ty -> ty) (params : ty_params) = - List.map (fun tv -> subst (tvar tv)) params + List.map (fun tv -> subst (tvar tv)) params.tyvars let openty_r (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = let subst = f_subst_init ~tv:(opentvi ue params tvi) () in @@ -315,7 +317,7 @@ module UniEnv = struct subst_of_uf (!ue).ue_uf let tparams (ue : unienv) : ty_params = - List.rev (!ue).ue_decl + { idxvars = []; tyvars = List.rev (!ue).ue_decl } end (* -------------------------------------------------------------------- *) @@ -360,11 +362,11 @@ let select_op | Some (TVIunamed lt) -> let len = List.length lt in fun op -> - let tparams = op.D.op_tparams in + let tparams = op.D.op_tparams.tyvars in List.length tparams = len | Some (TVInamed ls) -> fun op -> - let tparams = List.map EcIdent.name op.D.op_tparams in + let tparams = List.map EcIdent.name op.D.op_tparams.tyvars in let tparams = Ssym.of_list tparams in List.for_all (fun (x, _) -> Msym.mem x tparams) ls diff --git a/src/phl/ecPhlCond.ml b/src/phl/ecPhlCond.ml index 86432d60e4..3559a5debb 100644 --- a/src/phl/ecPhlCond.ml +++ b/src/phl/ecPhlCond.ml @@ -271,8 +271,8 @@ let t_equiv_match_same_constr tc = let bhl = List.map (fst_map EcIdent.fresh) cl in let bhr = List.map (fst_map EcIdent.fresh) cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.inv.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.inv.f_ty) in + let copl = f_op cop ~tyargs:tyl (toarrow (List.snd cl) fl.inv.f_ty) in + let copr = f_op cop ~tyargs:tyr (toarrow (List.snd cr) fr.inv.f_ty) in let lhs = map_ts_inv1 (fun fl -> f_eq fl (f_app copl (List.map (curry f_local) bhl) fl.f_ty)) fl in let lhs = map_ts_inv1 (f_exists (List.map (snd_map gtty) bhl)) lhs in @@ -288,8 +288,8 @@ let t_equiv_match_same_constr tc = let sb, bhl = add_elocals sb cl in let sb, bhr = add_elocals sb cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.inv.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.inv.f_ty) in + let copl = f_op cop ~tyargs:tyl (toarrow (List.snd cl) fl.inv.f_ty) in + let copr = f_op cop ~tyargs:tyr (toarrow (List.snd cr) fr.inv.f_ty) in let f_ands_simpl' f = f_ands_simpl (List.tl f) (List.hd f) in let pre = map_ts_inv f_ands_simpl' [es_pr es; map_ts_inv1 (fun fl -> f_eq fl (f_app copl (List.map (curry f_local) bhl) fl.f_ty)) fl; @@ -352,8 +352,8 @@ let t_equiv_match_eq tc = sb cl cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.inv.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.inv.f_ty) in + let copl = f_op cop ~tyargs:tyl (toarrow (List.snd cl) fl.inv.f_ty) in + let copr = f_op cop ~tyargs:tyr (toarrow (List.snd cr) fr.inv.f_ty) in let f_ands_simpl' f = f_ands_simpl (List.tl f) (List.hd f) in let pre = map_ts_inv f_ands_simpl' [ es_pr es; map_ts_inv1 (fun fl -> f_eq fl (f_app copl (List.map (curry f_local) bh) fl.f_ty)) fl; diff --git a/src/phl/ecPhlFel.ml b/src/phl/ecPhlFel.ml index 8d4e44c347..3583746389 100644 --- a/src/phl/ecPhlFel.ml +++ b/src/phl/ecPhlFel.ml @@ -27,19 +27,19 @@ end = struct let tlist = let tlist = EcPath.fromqsymbol (p_List, "list") in - fun ty -> EcTypes.tconstr tlist [ty] + fun ty -> EcTypes.tconstr ~tyargs:[ty] tlist let range = let rg = EcPath.fromqsymbol (p_List @ ["Range"], "range") in - let rg = f_op rg [] (toarrow [tint; tint] (tlist tint)) in + let rg = f_op rg (toarrow [tint; tint] (tlist tint)) in fun m n -> f_app rg [m; n] (tlist tint) let felsum = let bgty = [tpred tint; tfun tint treal; tlist tint] in let bg = EcPath.fromqsymbol (p_BRA, "big") in - let bg = f_op bg [tint] (toarrow bgty treal) in + let bg = f_op bg ~tyargs:[tint] (toarrow bgty treal) in let prT = EcPath.fromqsymbol ([i_top; "Logic"], "predT") in - let prT = f_op prT [tint] (tpred tint) in + let prT = f_op prT ~tyargs:[tint] (tpred tint) in fun f (m, n) -> f_app bg [prT; f; range m n] treal let loaded (env : env) = diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index 434dece2ce..a86ed6d184 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -191,7 +191,7 @@ let splitwhile_stmt b (pf, _) me i = match i.i_node with | Swhile (e, sw) -> let op_ty = toarrow [tbool; tbool] tbool in - let op_and = e_op EcCoreLib.CI_Bool.p_and [] op_ty in + let op_and = e_op EcCoreLib.CI_Bool.p_and op_ty in let e = e_app op_and [e; b] tbool in (me, [i_while (e, sw); i]) diff --git a/src/phl/ecPhlPrRw.ml b/src/phl/ecPhlPrRw.ml index 0ce2bab37a..1eae1195a3 100644 --- a/src/phl/ecPhlPrRw.ml +++ b/src/phl/ecPhlPrRw.ml @@ -86,7 +86,7 @@ let pr_sum env pr = let prx = EcFol.f_app - (EcFol.f_op EcCoreLib.CI_Sum.p_sum [ xty ] + (EcFol.f_op EcCoreLib.CI_Sum.p_sum ~tyargs:[ xty ] (EcTypes.tfun (EcTypes.tfun xty EcTypes.treal) EcTypes.treal)) [ EcFol.f_lambda [ (x, GTty xty) ] prx ] EcTypes.treal @@ -112,7 +112,7 @@ let p_BRA_big = EcPath.fromqsymbol (p_BRA, "big") let destr_pr_has pr = let m = pr.pr_event.m in match pr.pr_event.inv.f_node with - | Fapp ({ f_node = Fop(op, [ty_elem]) }, [f_f; f_l]) -> + | Fapp ({ f_node = Fop(op, { indices = []; types = [ty_elem] }) }, [f_f; f_l]) -> if EcPath.p_equal p_list_has op then Some(ty_elem, {m;inv=f_f}, {m;inv=f_l}) else None @@ -132,7 +132,7 @@ let pr_has_le f_pr = let f_fsum = f_lambda [idx, GTty ty_elem] f_pr1 in let f_sum = (* FIXME: Ensure that `f_l` does not use its memory *) - f_app (f_op p_BRA_big [ty_elem] EcTypes.treal) [f_predT ty_elem; f_fsum; f_l.inv] EcTypes.treal in + f_app (f_op p_BRA_big ~tyargs:[ty_elem] EcTypes.treal) [f_predT ty_elem; f_fsum; f_l.inv] EcTypes.treal in f_real_le f_pr f_sum (* -------------------------------------------------------------------- *) diff --git a/src/phl/ecPhlRCond.ml b/src/phl/ecPhlRCond.ml index d45a50ede3..837d442d2f 100644 --- a/src/phl/ecPhlRCond.ml +++ b/src/phl/ecPhlRCond.ml @@ -138,7 +138,7 @@ module LowMatch = struct | Some (i, (cname, _cty)) -> let b = oget (List.nth_opt bs i) in let cname = EcPath.pqoname (EcPath.prefix typ) cname in - let tyinst = List.combine tydc.tyd_params tyinst in + let tyinst = List.combine tydc.tyd_params.tyvars tyinst in (e, ((typ, tyd, tyinst), cname), b) end @@ -167,7 +167,7 @@ module LowMatch = struct in (x, xty)) cvars in let vars = List.map (curry f_local) names in let cty = toarrow (List.snd names) f.inv.f_ty in - let po = f_op cname (List.snd tyinst) cty in + let po = f_op cname ~tyargs:(List.snd tyinst) cty in let po = f_app po vars f.inv.f_ty in map_ss_inv1 (f_exists (List.map (snd_map gtty) names)) (map_ss_inv2 f_eq f {m;inv=po}) in @@ -196,7 +196,7 @@ module LowMatch = struct let epr, asgn = if frame then begin let vars = List.map (fun (pv, ty) -> f_pvar pv ty (fst me)) pvs in - let epr = f_op cname (List.snd tyinst) f.inv.f_ty in + let epr = f_op cname ~tyargs:(List.snd tyinst) f.inv.f_ty in let epr = map_ss_inv ~m:f.m (fun vars -> f_app epr vars f.inv.f_ty) vars in Some (map_ss_inv2 f_eq f epr), [] end else begin @@ -205,7 +205,7 @@ module LowMatch = struct (* FIXME: factorize out *) let rty = ttuple (List.snd cvars) in let proj = EcInductive.datatype_proj_path typ (EcPath.basename cname) in - let proj = e_op proj (List.snd tyinst) (tfun e.e_ty (toption rty)) in + let proj = e_op proj ~tyargs:(List.snd tyinst) (tfun e.e_ty (toption rty)) in let proj = e_app proj [e] (toption rty) in let proj = e_oget proj rty in i_asgn (lv, proj)) in diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index 100d49e72d..86c845302e 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -141,7 +141,7 @@ let process_rewrite_equiv info tc = try let proc = EcEnv.Fun.by_xpath new_func env in let subenv = EcEnv.Memory.push_active_ss mem env in - let ue = EcUnify.UniEnv.create (Some []) in + let ue = EcUnify.UniEnv.create (Some { idxvars = []; tyvars = [] }) in let args, ret_ty = EcTyping.trans_args subenv ue (loc pargs) proc.f_sig (unloc pargs) in let res = omap (fun v -> EcTyping.transexpcast subenv `InProc ue ret_ty v) pres in let es = e_subst (Tuni.subst (EcUnify.UniEnv.close ue)) in From 80571867c8b24a228e61a3a6eace79b2cdf3c38e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 11:39:25 +0200 Subject: [PATCH 04/40] =?UTF-8?q?indexed-types:=20phase=201=20=E2=80=94=20?= =?UTF-8?q?polynomial=20normal=20form=20for=20tindex?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit tindex equality and hashing now go through a canonical sum-of-monomials normalisation, so n+1 and 1+n (and (n+m)^2 and n^2+2nm+m^2) are recognised as equal. Coefficients are EcBigInt with the natural-number invariant; canonical_const refuses negative TIConst. ecUnify now compares indices (with the previous polarity bug fixed) and ecReduction.for_targs no longer skips them. Memory.md updated with the Phase-1 deliverables and what was deferred (no TIUnivar / UF participation yet — gated on Phase 3 needs). --- memory.md | 54 +++++++++++++---- src/ecAst.ml | 147 ++++++++++++++++++++++++++++++++++++++++----- src/ecAst.mli | 1 + src/ecReduction.ml | 3 +- src/ecUnify.ml | 6 +- 5 files changed, 179 insertions(+), 32 deletions(-) diff --git a/memory.md b/memory.md index 927066f960..17abb33ce9 100644 --- a/memory.md +++ b/memory.md @@ -94,19 +94,47 @@ Goal: clean `dune build` with the existing `targs` / ## Roadmap (remaining phases) -### Phase 1 — Polynomial normal form & equality -1. Add a `tindex` normalisation (sorted sum-of-monomials with - `EcBigInt` coefficients ≥ 1) and hashcons canonical forms. -2. Make `tindex_equal` compare canonical forms; replace the - `Hashtbl.hash` `tindex_hash` (structurally wrong once - `1+2 ≡ 2+1`). -3. Replace the `(* FIXME *)` in - [src/ecUnify.ml:146](src/ecUnify.ml#L146) (note: polarity also - bugged today: `if all2 ... then failure ()` is inverted) and the - `(* FIXME: compare indices *)` in `EcReduction.for_targs` - ([src/ecReduction.ml:25-39](src/ecReduction.ml#L25-L39)). -4. Decide whether indices participate in `EcUnify.UF` for inference — - probably needed only if Phase 3 lets users elide indices. +### Phase 1 — Polynomial normal form & equality (DONE) + +#### What changed + +- [src/ecAst.ml](src/ecAst.ml) — added `tindex_canonical` record + (`{cn_konst : zint; cn_mons : (mono * zint) list}` with `mono = + (ident * exponent) list`), the helpers `mono_compare` / `mono_mul` + / `mons_normalize` / `canonical_const` / `canonical_var` / + `canonical_add` / `canonical_mul`, and the entry point + `tindex_canonicalize`. Coefficients are stored as `EcBigInt.zint` + with the invariants `cn_konst ≥ 0`, every `mons` coefficient ≥ 1, + `cn_mons` strictly sorted by `mono_compare`. `canonical_const` + guards against negative `TIConst` with `invalid_arg`. +- `tindex_equal` now does `(==)` first, then compares canonical + forms; `tindex_hash` hashes the canonical form so hashconsing of + `Tconstr` agrees with equality. +- `targs_equal` checks lengths before `List.all2` (previously could + raise `Invalid_argument`). +- [src/ecAst.mli](src/ecAst.mli) — exposed `tindex_hash`. +- [src/ecUnify.ml](src/ecUnify.ml) — fixed the inverted-polarity bug + in the unification of `Tconstr` arms (was `if all2 ... then + failure ()` instead of `if not all2`); now also length-checks + indices before iterating types. +- [src/ecReduction.ml](src/ecReduction.ml) — + `EqTest_base.for_targs` actually compares indices (previous FIXME). + +#### Verified + +Built `dune build`, then ran an ephemeral smoke executable (deleted +after success) covering: commutativity (`n+1 ≡ 1+n`), associativity +(`(n+m)+1 ≡ n+(m+1)`), distribution + constant folding +(`(n+1)·2 ≡ 2n+2`), monomials (`n·n`), binomial expansion +(`(n+m)² ≡ n²+2nm+m²`), inequality (`n ≢ n+1`, `2 ≢ 3`), and hash +consistency between equal canonical forms. + +#### Deferred from Phase 1 + +- Index unification variables (a `TIUnivar` constructor and + participation in `EcUnify.UF`) — only needed if Phase 3 lets users + elide indices at applications. Defer until parser work surfaces a + concrete need. ### Phase 2 — Substitution & FV 1. Add `tindex_of_form : form -> tindex option` recognising diff --git a/src/ecAst.ml b/src/ecAst.ml index e7986162d1..c920028e3c 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -1066,34 +1066,151 @@ let pr_hash pr = (Why3.Hashcons.combine (f_hash pr.pr_event.inv) (mem_hash pr.pr_event.m)) (* ----------------------------------------------------------------- *) -(* Hashconsing *) +(* tindex polynomial normal form *) +(* *) +(* A `tindex` is a polynomial expression over the natural numbers, *) +(* with grammar `TIVar | TIConst | TIAdd | TIMul`. We decide *) +(* equality up to commutativity / associativity / distributivity by *) +(* normalising to a canonical sum-of-monomials. *) (* ----------------------------------------------------------------- *) -let rec tindex_equal (ti1 : tindex) (ti2 : tindex) : bool = - match ti1, ti2 with - | TIVar n1, TIVar n2 -> - EcIdent.id_equal n1 n2 - | TIConst n1, TIConst n2 -> - EcBigInt.equal n1 n2 +(* A monomial is a sorted association list (ident, exponent) with + each exponent >= 1. The empty list represents the constant 1. *) +type tindex_mono = (EcIdent.t * int) list + +(* A polynomial in canonical form over the non-negative integers. + Invariants: + - cn_konst >= 0 + - cn_mons sorted strictly ascending by mono_compare + - every coefficient >= 1 + - the empty monomial [] does not appear in cn_mons (folded into cn_konst) *) +type tindex_canonical = { + cn_konst : EcBigInt.zint; + cn_mons : (tindex_mono * EcBigInt.zint) list; +} - | TIAdd (l1, r1), TIAdd (l2, r2) - | TIMul (l1, r1), TIMul (l2, r2) -> - tindex_equal l1 l2 && tindex_equal r1 r2 +let mono_compare : tindex_mono -> tindex_mono -> int = + let rec cmp m1 m2 = + match m1, m2 with + | [], [] -> 0 + | [], _ -> -1 + | _ , [] -> 1 + | (x1, e1) :: t1, (x2, e2) :: t2 -> + let c = EcIdent.id_compare x1 x2 in + if c <> 0 then c else + let c = Stdlib.compare (e1 : int) e2 in + if c <> 0 then c else cmp t1 t2 + in cmp + +(* Multiply two monomials: merge by ident, sum exponents. *) +let rec mono_mul (m1 : tindex_mono) (m2 : tindex_mono) : tindex_mono = + match m1, m2 with + | [], _ -> m2 + | _, [] -> m1 + | (x1, e1) :: t1, (x2, e2) :: t2 -> + let c = EcIdent.id_compare x1 x2 in + if c < 0 then (x1, e1) :: mono_mul t1 m2 + else if c > 0 then (x2, e2) :: mono_mul m1 t2 + else (x1, e1 + e2) :: mono_mul t1 t2 + +(* Normalise a list of (mono, coef) pairs: drop zero coefficients, + sort by monomial, merge duplicates by summing coefficients. *) +let mons_normalize (pairs : (tindex_mono * EcBigInt.zint) list) = + let pairs = + List.filter + (fun (_, c) -> not (EcBigInt.equal c EcBigInt.zero)) + pairs in + let pairs = + List.sort (fun (m1, _) (m2, _) -> mono_compare m1 m2) pairs in + let rec merge = function + | [] -> [] + | [x] -> [x] + | (m1, c1) :: ((m2, c2) :: t as rest) -> + if mono_compare m1 m2 = 0 then + merge ((m1, EcBigInt.add c1 c2) :: t) + else + (m1, c1) :: merge rest + in merge pairs + +let canonical_const (n : EcBigInt.zint) = + if EcBigInt.sign n < 0 then + invalid_arg "tindex: negative integer constant"; + { cn_konst = n; cn_mons = [] } + +let canonical_var (id : EcIdent.t) = + { cn_konst = EcBigInt.zero; + cn_mons = [([(id, 1)], EcBigInt.one)] } + +let canonical_add (p : tindex_canonical) (q : tindex_canonical) = + { cn_konst = EcBigInt.add p.cn_konst q.cn_konst; + cn_mons = mons_normalize (p.cn_mons @ q.cn_mons); } + +let canonical_mul (p : tindex_canonical) (q : tindex_canonical) = + let pk = p.cn_konst and qk = q.cn_konst in + let kp_qm = + if EcBigInt.equal pk EcBigInt.zero then [] + else List.map (fun (m, c) -> (m, EcBigInt.mul pk c)) q.cn_mons in + let kq_pm = + if EcBigInt.equal qk EcBigInt.zero then [] + else List.map (fun (m, c) -> (m, EcBigInt.mul qk c)) p.cn_mons in + let pm_qm = + List.concat_map + (fun (m1, c1) -> + List.map + (fun (m2, c2) -> (mono_mul m1 m2, EcBigInt.mul c1 c2)) + q.cn_mons) + p.cn_mons in + { cn_konst = EcBigInt.mul pk qk; + cn_mons = mons_normalize (kp_qm @ kq_pm @ pm_qm); } + +let rec tindex_canonicalize (ti : tindex) : tindex_canonical = + match ti with + | TIVar id -> canonical_var id + | TIConst n -> canonical_const n + | TIAdd (l, r) -> canonical_add (tindex_canonicalize l) (tindex_canonicalize r) + | TIMul (l, r) -> canonical_mul (tindex_canonicalize l) (tindex_canonicalize r) + +let canonical_equal (p : tindex_canonical) (q : tindex_canonical) = + EcBigInt.equal p.cn_konst q.cn_konst && + let rec eq m1 m2 = + match m1, m2 with + | [], [] -> true + | [], _ | _, [] -> false + | (k1, c1) :: t1, (k2, c2) :: t2 -> + mono_compare k1 k2 = 0 + && EcBigInt.equal c1 c2 + && eq t1 t2 + in eq p.cn_mons q.cn_mons + +let canonical_hash (p : tindex_canonical) = + let mono_hash (m : tindex_mono) = + Why3.Hashcons.combine_list + (fun (id, e) -> Why3.Hashcons.combine (EcIdent.id_hash id) e) + 0 m in + let pair_hash (m, c) = + Why3.Hashcons.combine (mono_hash m) (EcBigInt.hash c) in + Why3.Hashcons.combine_list pair_hash (EcBigInt.hash p.cn_konst) p.cn_mons - | _, _ -> - false +(* ----------------------------------------------------------------- *) +(* Hashconsing *) +(* ----------------------------------------------------------------- *) +let tindex_equal (ti1 : tindex) (ti2 : tindex) : bool = + ti1 == ti2 + || canonical_equal (tindex_canonicalize ti1) (tindex_canonicalize ti2) let targs_equal (ta1 : targs) (ta2 : targs) : bool = - List.all2 tindex_equal ta1.indices ta2.indices + List.compare_lengths ta1.indices ta2.indices = 0 + && List.compare_lengths ta1.types ta2.types = 0 + && List.all2 tindex_equal ta1.indices ta2.indices && List.all2 ty_equal ta1.types ta2.types - + let targs_fv (ta : targs) = List.fold_left (fun ids ty -> fv_union ids (ty_fv ty)) Mid.empty ta.types let tindex_hash (ti : tindex) = - Hashtbl.hash ti + canonical_hash (tindex_canonicalize ti) let targ_hash (init : int) (ta : targs) = let aout = init in diff --git a/src/ecAst.mli b/src/ecAst.mli index c9de5f4aba..617d77a103 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -419,6 +419,7 @@ type 'a hash = 'a -> int type 'a fv = 'a -> int EcIdent.Mid.t val tindex_equal : tindex equality +val tindex_hash : tindex hash val targs_equal : targs equality val ty_equal : ty equality diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 2192769c24..690606b3ac 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -27,11 +27,12 @@ module EqTest_base = struct let exception NotEqual in try - (* FIXME: compare indices *) if List.compare_lengths ta1.types ta2.types <> 0 then raise NotEqual; if List.compare_lengths ta1.indices ta2.indices <> 0 then raise NotEqual; + if not (List.all2 tindex_equal ta1.indices ta2.indices) then + raise NotEqual; if not (List.all2 (for_type env) ta1.types ta2.types) then raise NotEqual; true diff --git a/src/ecUnify.ml b/src/ecUnify.ml index c620b6a937..fb86a4f6f5 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -143,9 +143,9 @@ let unify_core (env : EcEnv.env) (uf : UF.t) pb = Queue.push (`TyUni (t2, t2')) pb | Tconstr (p1, ta1), Tconstr (p2, ta2) when EcPath.p_equal p1 p2 -> - if List.all2 tindex_equal ta1.indices ta2.indices then - failure (); (* FIXME *) - if List.length ta1.types <> List.length ta2.types then failure (); + if List.compare_lengths ta1.indices ta2.indices <> 0 then failure (); + if List.compare_lengths ta1.types ta2.types <> 0 then failure (); + if not (List.all2 tindex_equal ta1.indices ta2.indices) then failure (); List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) ta1.types ta2.types From e780cfe09e0db40dd2929c4c0d7fa640e639b4c5 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 11:53:42 +0200 Subject: [PATCH 05/40] =?UTF-8?q?indexed-types:=20phase=202=20=E2=80=94=20?= =?UTF-8?q?substitution=20and=20free=20variables?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit tindex_subst is no longer a no-op. It consults fs_loc / sb_flocal (indices share the formula-locals namespace), reinterprets the bound formula as a polynomial via the new tindex_of_form recogniser, and panics if the binding is non-polynomial. targs_fv (and so ty_fv on Tconstr) now folds over indices, so the per-formula short-circuits in Fsubst correctly fire for types with TIVar occurrences. is_ty_subst_id now also checks fs_loc emptiness — a formula substitution that touches an int-typed local can affect any type whose Tconstr carries a TIVar of that local. Cost is a wider substitution walk; correctness comes first here. memory.md updated with deliverables, design choices (no eager re-canonicalisation, fs_eloc not consulted), and the remaining risk (audit f_bind_local callers for the polynomial invariant). --- memory.md | 77 ++++++++++++++++++++++++++++++++++----------- src/ecAst.ml | 20 ++++++++++-- src/ecAst.mli | 2 ++ src/ecCoreFol.ml | 23 ++++++++++++++ src/ecCoreFol.mli | 5 +++ src/ecCoreSubst.ml | 35 +++++++++++++++++++-- src/ecCoreSubst.mli | 3 +- src/ecSubst.ml | 26 +++++++++++++-- 8 files changed, 165 insertions(+), 26 deletions(-) diff --git a/memory.md b/memory.md index 17abb33ce9..9970dbd222 100644 --- a/memory.md +++ b/memory.md @@ -136,24 +136,65 @@ consistency between equal canonical forms. elide indices at applications. Defer until parser work surfaces a concrete need. -### Phase 2 — Substitution & FV -1. Add `tindex_of_form : form -> tindex option` recognising - `Fint n (n≥0)`, `Flocal id (ty=int)`, `Fapp(p_int_add, [a;b])`, - `Fapp(p_int_mul, [a;b])`. Returns `None` on anything else. -2. Implement `tindex_subst` in - [src/ecCoreSubst.ml:185](src/ecCoreSubst.ml#L185) and - [src/ecSubst.ml:153](src/ecSubst.ml#L153): for `TIVar id`, look up - `fs_loc`/`fs_v`; if a binding exists, `tindex_of_form` it and - `Option.get` (panic if the substitution invariant is violated). - Re-normalise at the root. -3. Patch `targs_fv` in [src/ecAst.ml:1090](src/ecAst.ml#L1090) and - `Hsty.fv` in [src/ecAst.ml:1147](src/ecAst.ml#L1147) to fold over - `indices` (currently they only walk `types`, so - `Tconstr (p, {indices=[TIVar n]; types=[]})` reports empty fv — - wrong). -4. Audit smart-equality fast paths in `targs_subst`: `==` survives - normalisation only when nothing changed *and* the input was already - canonical. +### Phase 2 — Substitution & FV (DONE) + +#### What changed + +- [src/ecCoreFol.ml](src/ecCoreFol.ml) + [src/ecCoreFol.mli](src/ecCoreFol.mli) + — added `tindex_of_form : form -> tindex option` recognising the + polynomial fragment over ℕ (`Fint n` with `n ≥ 0`, int-typed + `Flocal`, `p_int_add`, `p_int_mul`); returns `None` on anything + else. +- [src/ecCoreSubst.ml](src/ecCoreSubst.ml) — `is_ty_subst_id` now + also checks `Mid.is_empty s.fs_loc`, since indices share the + formula-locals namespace and so `fs_loc` can affect types via + `Tconstr` indices. `tindex_subst` consults `s.fs_loc` per `TIVar`, + converts via `tindex_of_form`, and panics with a descriptive + message if a binding is non-polynomial. `targs_subst`'s + short-circuit follows automatically. +- [src/ecCoreSubst.mli](src/ecCoreSubst.mli) — exposed + `tindex_subst`. +- [src/ecSubst.ml](src/ecSubst.ml) — same treatment for + `subst_tindex` against `sb_flocal`. +- [src/ecAst.ml](src/ecAst.ml) — added `tindex_fv_acc` / `tindex_fv` + (each `TIVar` contributes its identifier with multiplicity 1). + `targs_fv` now folds over `indices` too. `Hsty.fv` already routed + through `targs_fv`, so `ty.ty_fv` now includes index-variable + identifiers; `Fsubst.f_subst_local`'s per-formula + `Mid.mem x f.f_fv` short-circuit therefore triggers correctly on + types whose `Tconstr` carries `TIVar x`. +- [src/ecAst.mli](src/ecAst.mli) — exposed `tindex_fv`, `targs_fv`. + +#### Verified + +Built `dune build`, then ran an ephemeral smoke executable (deleted +after success) covering: +- `fv(n*m+1) = {n, m}` and `k ∉ fv`. +- `targs_fv` carries indices. +- `(n+1)[n:=5] ≡ 6` (constant folds via canonicalisation). +- `(n+1)[n:=1+m] ≡ m+2` (substitution composes with normalisation). +- `(2n+nm)[n:=5] ≡ 10+5m`. +- `targs_subst` actually rewrites `TIVar`. +- `ty_fv` of a `Tconstr` with an index reports the index variable. + +#### Notable Phase-2 design choices + +- `tindex_subst` does not re-canonicalise after substitution; the AST + may hold non-canonical shapes (e.g. `(1+m)+1` rather than `m+2`) + but `tindex_equal` / `tindex_hash` always canonicalise lazily, so + hashconsing of `Tconstr` still identifies them. Pretty-printing + (Phase 6) will canonicalise for display. +- Substitution looks at `fs_loc` only; `fs_eloc` (expression-only + bindings) is not consulted. `f_bind_rename` writes both maps so + α-renaming still propagates into indices. + +#### Risk left for later + +- Audit of `f_bind_local` callers for the substitution invariant: if + any pass binds an `int`-typed local to a non-polynomial formula and + that local later appears as a `TIVar` inside a type, EasyCrypt will + crash mid-proof from `tindex_subst`. Worth a tactical sweep before + merging to main. ### Phase 3 — Parser & typing 1. Concrete syntax for *binders*: propose `type ['n 'm] 'a vec`, diff --git a/src/ecAst.ml b/src/ecAst.ml index c920028e3c..dc7cc5ccc8 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -1204,10 +1204,24 @@ let targs_equal (ta1 : targs) (ta2 : targs) : bool = && List.all2 tindex_equal ta1.indices ta2.indices && List.all2 ty_equal ta1.types ta2.types +(* Free variables of a tindex: every TIVar contributes its identifier + (with multiplicity 1, like other fv counters in this module). *) +let rec tindex_fv_acc (acc : int Mid.t) (ti : tindex) : int Mid.t = + match ti with + | TIVar id -> fv_add id acc + | TIConst _ -> acc + | TIAdd (l, r) + | TIMul (l, r) -> tindex_fv_acc (tindex_fv_acc acc l) r + +let tindex_fv (ti : tindex) : int Mid.t = + tindex_fv_acc Mid.empty ti + let targs_fv (ta : targs) = - List.fold_left - (fun ids ty -> fv_union ids (ty_fv ty)) - Mid.empty ta.types + let acc = + List.fold_left + (fun ids ty -> fv_union ids (ty_fv ty)) + Mid.empty ta.types in + List.fold_left tindex_fv_acc acc ta.indices let tindex_hash (ti : tindex) = canonical_hash (tindex_canonicalize ti) diff --git a/src/ecAst.mli b/src/ecAst.mli index 617d77a103..b88c2e048d 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -420,7 +420,9 @@ type 'a fv = 'a -> int EcIdent.Mid.t val tindex_equal : tindex equality val tindex_hash : tindex hash +val tindex_fv : tindex fv val targs_equal : targs equality +val targs_fv : targs fv val ty_equal : ty equality val ty_hash : ty hash diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 125c3b0486..b35a690327 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -1087,6 +1087,29 @@ let expr_of_form f = in aux f +(* -------------------------------------------------------------------- *) +(* Recognise a formula as a tindex polynomial. Returns Some ti when + [f] is built only from non-negative integer literals, int-typed + Flocal occurrences, p_int_add and p_int_mul applications. Returns + None otherwise. *) +let rec tindex_of_form (f : form) : tindex option = + match f.f_node with + | Fint n when EcBigInt.sign n >= 0 -> + Some (TIConst n) + | Flocal id when ty_equal f.f_ty tint -> + Some (TIVar id) + | Fapp ({ f_node = Fop (p, _) }, [a; b]) + when EcPath.p_equal p EcCoreLib.CI_Int.p_int_add -> + Option.bind (tindex_of_form a) (fun ta -> + Option.bind (tindex_of_form b) (fun tb -> + Some (TIAdd (ta, tb)))) + | Fapp ({ f_node = Fop (p, _) }, [a; b]) + when EcPath.p_equal p EcCoreLib.CI_Int.p_int_mul -> + Option.bind (tindex_of_form a) (fun ta -> + Option.bind (tindex_of_form b) (fun tb -> + Some (TIMul (ta, tb)))) + | _ -> None + (* -------------------------------------------------------------------- *) (* A predicate on memory: λ mem. -> pred *) type mem_pr = EcMemory.memory * form diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 71c223c057..fd182db51d 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -317,6 +317,11 @@ exception CannotTranslate val expr_of_ss_inv : ss_inv -> EcTypes.expr val expr_of_form : form -> EcTypes.expr +(* Recognise a formula as a tindex polynomial. Returns [None] when the + formula falls outside the polynomial fragment over the naturals + (variables, non-negative literals, p_int_add, p_int_mul). *) +val tindex_of_form : form -> tindex option + (* -------------------------------------------------------------------- *) (* A predicate on memory: λ mem. -> pred *) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index e2e248c0a4..586128489b 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -156,10 +156,14 @@ let f_rem_mod (s : f_subst) (x : ident) : f_subst = fs_modex = Mid.remove x s.fs_modex; } (* -------------------------------------------------------------------- *) +(* True when no substitution can affect a type. Indices share the + formula-locals namespace (Phase 2), so [fs_loc] participates here + even though it is otherwise a formula-only map. *) let is_ty_subst_id (s : f_subst) : bool = Mid.is_empty s.fs_mod && Muid.is_empty s.fs_u && Mid.is_empty s.fs_v + && Mid.is_empty s.fs_loc (* -------------------------------------------------------------------- *) let rec ty_subst (s : f_subst) (ty : ty) : ty = @@ -182,8 +186,35 @@ let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s (* -------------------------------------------------------------------- *) -let tindex_subst (_ : f_subst) (ti : tindex) = - ti (* FIXME *) +(* Substitute through a tindex polynomial. For each [TIVar id], look up + [id] in [fs_loc]; if a binding exists, the bound formula must be + expressible as a tindex (caller-side invariant — see + [tindex_of_form]). The result is left in syntactic form; + normalisation happens lazily in [tindex_equal] / [tindex_hash]. *) +let rec tindex_subst (s : f_subst) (ti : tindex) : tindex = + match ti with + | TIVar id -> begin + match Mid.find_opt id s.fs_loc with + | None -> ti + | Some f -> + match tindex_of_form f with + | Some ti' -> ti' + | None -> + failwith + (Printf.sprintf + "tindex_subst: index variable %s is bound to a \ + formula not expressible as a tindex" + (EcIdent.name id)) + end + | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = tindex_subst s l in + let r' = tindex_subst s r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = tindex_subst s l in + let r' = tindex_subst s r in + if l == l' && r == r' then ti else TIMul (l', r') (* -------------------------------------------------------------------- *) let targs_subst (s : f_subst) (ta : targs) : targs = diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 09e85e70e2..476b6943a2 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -56,7 +56,8 @@ val add_elocals : (EcIdent.t * ty) list subst_binder val bind_elocal : f_subst -> EcIdent.t -> expr -> f_subst (* -------------------------------------------------------------------- *) -val targs_subst : targs substitute +val targs_subst : targs substitute +val tindex_subst : tindex substitute val ty_subst : ty substitute val e_subst : expr substitute diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 575265a72e..b9c0dadad9 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -150,8 +150,30 @@ let add_tyvars (s : subst) (xs : EcIdent.t list) (tys : ty list) = List.fold_left2 add_tyvar s xs tys (* -------------------------------------------------------------------- *) -let subst_tindex (_s : subst) (ti : tindex) = - ti +let rec subst_tindex (s : subst) (ti : tindex) : tindex = + match ti with + | TIVar id -> begin + match Mid.find_opt id s.sb_flocal with + | None -> ti + | Some f -> + match EcCoreFol.tindex_of_form f with + | Some ti' -> ti' + | None -> + failwith + (Printf.sprintf + "subst_tindex: index variable %s is bound to a \ + formula not expressible as a tindex" + (EcIdent.name id)) + end + | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = subst_tindex s l in + let r' = subst_tindex s r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = subst_tindex s l in + let r' = subst_tindex s r in + if l == l' && r == r' then ti else TIMul (l', r') (* -------------------------------------------------------------------- *) let rec subst_ty (s : subst) (ty : ty) = From 97ee906968e8dfcf6086755a2bf1ceb326d7186c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 14:45:26 +0200 Subject: [PATCH 06/40] =?UTF-8?q?indexed-types:=20phase=203=20=E2=80=94=20?= =?UTF-8?q?surface=20syntax=20for=20indexed=20types?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Tydecls, operators, predicates and axioms can now declare integer index parameters; type-constructor applications can supply index arguments. type [n m] ('a, 'b) vec. op f [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>. pred p [n 'a] : 'a vec<:n>. axiom A [n 'a] : true. Index binders use plain (no apostrophe) identifiers in `[...]`. Index applications are framed by `<:...>` rather than `[...]` to avoid a shift/reduce conflict with codepos brackets in module-update syntax. Index expressions inside the framing are restricted to the polynomial fragment (`+`, `*`, non-negative literals, identifiers). Datatype/record indexed types and cloning of indexed declarations are refused with clean errors — useful index-instantiation at op call sites still requires the deferred TIUnivar / polynomial-with- univars unification work, also flagged in memory.md. A regression test lives at tests/indexed-types.ec. --- memory.md | 109 ++++++++++++++++++++++++++++++----- src/ecHiPredicates.ml | 3 +- src/ecParser.mly | 127 ++++++++++++++++++++++++++++++++--------- src/ecParsetree.ml | 23 ++++++-- src/ecScope.ml | 20 +++++-- src/ecThCloning.ml | 5 ++ src/ecThCloning.mli | 1 + src/ecTyping.ml | 81 +++++++++++++++++++++----- src/ecTyping.mli | 4 ++ src/ecUnify.ml | 44 +++++++++----- src/ecUnify.mli | 2 + src/ecUserMessages.ml | 14 +++++ tests/indexed-types.ec | 33 +++++++++++ 13 files changed, 389 insertions(+), 77 deletions(-) create mode 100644 tests/indexed-types.ec diff --git a/memory.md b/memory.md index 9970dbd222..4bf8e29e75 100644 --- a/memory.md +++ b/memory.md @@ -196,20 +196,101 @@ after success) covering: crash mid-proof from `tindex_subst`. Worth a tactical sweep before merging to main. -### Phase 3 — Parser & typing -1. Concrete syntax for *binders*: propose `type ['n 'm] 'a vec`, - `op f ['n] ('a) (xs : 'a vec['n]) : …`, `axiom ['n] foo : …`. - Bracket order should match `dump_ty`'s `[indices|types]`. -2. Concrete syntax for *applications*: `'a vec[n+1]`. -3. `EcTyping`: parse index expressions through a restricted grammar — - only `+`, `*`, non-negative literals, identifiers bound as indices. - Reject subtraction, division, calls. -4. Resolution: when `n` is in scope as both an index binder and an int - term variable (shared namespace), an occurrence in an index - position becomes `TIVar n`, in a term position becomes - `Flocal n` — disambiguated by syntactic position. -5. Cloning (`EcThCloning`, `EcSubst`): index parameters get - instantiated alongside type parameters during clone-with. +### Phase 3 — Parser & typing (DONE) + +#### Final concrete syntax + +- **Index binders** are plain identifiers (no apostrophe) inside + `[...]`, e.g. `type [n m] ('a, 'b) vec.`. On op / pred / axiom / + lemma headers, `[...]` accepts a *mixed* list — apostrophe-prefixed + → tyvar, plain → index — bucketed in the parser prelude: + `op f [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>`. +- **Index applications** use `<: ... >` framing (LTCOLON / GT), e.g. + `'a vec<:n+1, m*2>`. We avoid `[...]` here because it would + shift/reduce-conflict with the codepos brackets in + `module M = N with { proc f [ var x : T [..] ] }`. The framing also + matches the existing operator type-arg syntax `f<:int>`. +- **Index-expression sub-grammar**: literals, identifiers, `+`, `*` + with standard precedence. The grammar guarantees only the + polynomial fragment. +- **Disambiguation rule** (shared namespace): inside `[...]` and + `<:...>` an identifier is read as an index variable; everywhere + else it's a formula/expression local. Apostrophe-prefixed names are + always type variables. + +#### What changed + +- [src/ecParsetree.ml](src/ecParsetree.ml) — `pindex_r` / `pindex` + added, mutually recursive with `pty_r`. `PTapp` now carries + `pindex list`. `ptydecl` / `poperator` / `ppredicate` / `paxiom` + each grow an `*_idxvars : psymbol list` field. +- [src/ecParser.mly](src/ecParser.mly) — `idxvars_decl` (tydecl + prefix), `idx_args` (postfix `<: ... >` on `simpl_type_exp`), + `pindex` sub-grammar, `mixed_tyvars_item` / `mixed_tyvars_decl` + (mixed binder list), and a `bucket_mixed` helper in the prelude. + `tyd_name`, `operator`, `predicate`, `lemma_decl` updated to + produce the new fields. +- [src/ecTyping.ml](src/ecTyping.ml) + [.mli](src/ecTyping.mli) — + `transtyvars` gains `?idxparams:psymbol list`. `transtindex` + translates a `pindex` to a `tindex`, looking variables up via + `EcUnify.UniEnv.getnamed_idx`. `transty` `PTapp` validates index + arity and translates each index argument. New `tyerror` variants: + `InvalidIndexAppl`, `UnboundIndexVariable`, `DuplicatedIndexVar`, + with printer entries in + [src/ecUserMessages.ml](src/ecUserMessages.ml). +- [src/ecUnify.ml](src/ecUnify.ml) + [.mli](src/ecUnify.mli) — + `unienv` carries a separate `ue_idxnamed` / `ue_idxdecl`. New + `getnamed_idx`. `tparams` propagates `idxvars` into the returned + `ty_params`. +- [src/ecScope.ml](src/ecScope.ml) — tydecl path threads + `pty_idxvars` for abstract / alias bodies, refuses indices on + datatype / record with a clean error. Op + axiom call sites pass + `~idxparams`. +- [src/ecHiPredicates.ml](src/ecHiPredicates.ml) — predicate-decl + passes `~idxparams`. +- [src/ecThCloning.ml](src/ecThCloning.ml) + [.mli](src/ecThCloning.mli) + — new `CE_IndexedNotYetSupported` clone-error; `ty_ovrd` refuses + cloning of indexed types with a clean printer entry. +- [tests/indexed-types.ec](tests/indexed-types.ec) — regression + exercising tydecl binders + applications, op / pred / axiom + binders. + +#### Verified + +- `_build/default/src/ec.exe compile -boot tests/indexed-types.ec` + succeeds (12 indexed-type declarations and 3 indexed + op/pred/axiom binders). +- Ad-hoc negative cases: unbound index, index arity mismatch, + duplicated index variable, cloning of an indexed type — each + raises a clean message at the right location. + +#### Notable Phase-3 design choices + +- The `<:...>` framing for index applications was chosen over the + user-preferred `[...]` after a real shift/reduce conflict surfaced + in `mod_update_fun`. Reuses the existing operator-tvi framing. +- `pindex` is its own AST (not a re-use of `pformula`) to avoid + pulling `pformula` into `pty_r`'s mutual recursion. +- `transtyvars` keeps its existing positional `(loc, tparams option)` + argument; the new `?idxparams` is an optional keyword. Backward + compatible — every existing call site still compiles unchanged. + +#### Risks left for later + +- **Index inference at op application sites.** Indexed ops *declare* + fine but *calling* them doesn't yet work — `EcUnify` has no + `TIUnivar` machinery, so an op's index parameter stays as a fresh + ident that can't be unified against the caller's index expression. + This is the deferred Phase-1 question (introduce `TIUnivar`, + decide polynomial-with-univars unification). Without it, indexed + ops are mostly cosmetic. +- **Datatype / Record indexed types.** Refused with a clean error in + `ecScope`. Adding support is mostly threading idxvars through + `ecHiInductive.trans_datatype` / `trans_record`. +- **Cloning of indexed types/ops.** Refused with `CE_IndexedNotYetSupported`. + Real support needs index-instantiation surface syntax in + `clone with`, plus a way to substitute indices through the cloned + declarations. ### Phase 4 — Theories & smoke tests 1. Add a focused `.ec` test exercising: diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index 49e725ad58..3b53282722 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -40,7 +40,8 @@ let close_pr_body (uni : ty EcUid.Muid.t) (body : prbody) = (* -------------------------------------------------------------------- *) let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = let pr = pr.pl_desc and loc = pr.pl_loc in - let ue = TT.transtyvars env (loc, pr.pp_tyvars) in + let ue = + TT.transtyvars ~idxparams:pr.pp_idxvars env (loc, pr.pp_tyvars) in let tp = TT.tp_relax in let dom, body = diff --git a/src/ecParser.mly b/src/ecParser.mly index b1146388e1..f6c79fdca9 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -14,13 +14,26 @@ let pqsymb_of_symb loc x : pqsymbol = mk_loc loc ([], x) - let mk_tydecl ~locality (tyvars, name) body = { + let mk_tydecl ~locality (idxvars, tyvars, name) body = { pty_name = name; + pty_idxvars = idxvars; pty_tyvars = tyvars; pty_body = body; pty_locality = locality; } + (* Bucket a mixed `[ apostrophe-or-plain idents... ]` binder list into + (indices, type variables). *) + let bucket_mixed + (items : [`Ty of EcParsetree.psymbol | `Idx of EcParsetree.psymbol] list) + : EcParsetree.psymbol list * EcParsetree.psymbol list + = + let rec aux ix ty = function + | [] -> (List.rev ix, List.rev ty) + | `Idx x :: rest -> aux (x :: ix) ty rest + | `Ty x :: rest -> aux ix (x :: ty) rest + in aux [] [] items + let opdef_of_opbody ty b = match b with | None -> PO_abstr ty @@ -79,8 +92,9 @@ let pflist loc ti (es : pformula list) : pformula = List.fold_right (fun e1 e2 -> pf_cons loc ti e1 e2) es (pf_nil loc ti) - let mk_axiom ~locality (x, ty, pv, vd, f) k = + let mk_axiom ~locality (x, idx, ty, pv, vd, f) k = { pa_name = x; + pa_idxvars = idx; pa_tyvars = ty; pa_pvars = pv; pa_vars = vd; @@ -1269,17 +1283,52 @@ pgtybindings: (* Type expressions *) simpl_type_exp: -| UNDERSCORE { PTunivar } -| x=qident { PTnamed x } -| x=tident { PTvar x } -| tya=type_args x=qident { PTapp (x, tya) } -| GLOB m=loc(mod_qident) { PTglob m } -| LPAREN ty=type_exp RPAREN { ty } +| UNDERSCORE { PTunivar } +| x=qident { PTnamed x } +| x=qident is=idx_args { PTapp (x, [], is) } +| x=tident { PTvar x } +| tya=type_args x=qident is=loption(idx_args) { PTapp (x, tya, is) } +| GLOB m=loc(mod_qident) { PTglob m } +| LPAREN ty=type_exp RPAREN { ty } type_args: | ty=loc(simpl_type_exp) { [ty] } | LPAREN tys=plist2(loc(type_exp), COMMA) RPAREN { tys } +(* Indexed-type index arguments: a comma-separated list of polynomial + expressions enclosed between `<:` and `>`, e.g. `'a vec<:n+1>` or + `('a, 'b) map<:n, m>`. We reuse the LTCOLON/GT framing already used + for operator type-variable instantiation (`f<:int>`); a square- + bracket framing would conflict with `mod_update_fun`'s codepos + ranges in `module M = N with { proc f [ var x : T [..] ] }`. *) +idx_args: +| LTCOLON xs=plist1(pindex, COMMA) GT { xs } + +(* Index-expression sub-grammar (polynomial fragment over the + naturals). Precedence: `*` binds tighter than `+`. *) +pindex_atom: +| x=lident { mk_loc x.pl_loc (PIvar x) } +| n=loc(UINT) + { mk_loc n.pl_loc (PIint n.pl_desc) } +| LPAREN p=pindex RPAREN { p } + +pindex_mul: +| a=pindex_atom { a } +| a=pindex_mul STAR b=pindex_atom + { mk_loc (EcLocation.merge a.pl_loc b.pl_loc) (PImul (a, b)) } + +pindex: +| a=pindex_mul { a } +| a=pindex PLUS b=pindex_mul + { mk_loc (EcLocation.merge a.pl_loc b.pl_loc) (PIadd (a, b)) } + +(* Optional binder list of index parameters appearing right after + `type` (e.g. `type [n m] 'a vec`). Naked identifiers (no + apostrophe) inside square brackets distinguish them from type + parameters which use `'a`-style identifiers. *) +idxvars_decl: +| LBRACKET xs=lident+ RBRACKET { xs } + type_exp: | ty=simpl_type_exp { ty } | ty=plist2(loc(simpl_type_exp), STAR) { PTtuple ty } @@ -1650,7 +1699,7 @@ typarams: { (xs : ptyparams) } %inline tyd_name: -| tya=typarams x=ident { (tya, x) } +| idx=loption(idxvars_decl) tya=typarams x=ident { (idx, tya, x) } dt_ctor_def: | x=oident { (x, []) } @@ -1750,38 +1799,55 @@ tyvars_decl: | LBRACKET tyvars=rlist2(tident, empty) RBRACKET { tyvars } +(* Mixed binder list: each item is a tident (`'a`) bound as a type + variable, or a plain lident (`n`) bound as an integer index. Used + on operator/predicate/axiom/lemma headers, where indices and type + variables share a single set of brackets. Returns (idxvars, tyvars). *) +mixed_tyvars_item: +| x=tident { `Ty x } +| x=lident { `Idx x } + +mixed_tyvars_decl: +| LBRACKET items=rlist0(mixed_tyvars_item, COMMA) RBRACKET +| LBRACKET items=rlist2(mixed_tyvars_item, empty) RBRACKET + { bucket_mixed items } + op_or_const: | OP { `Op } | CONST { `Const } operator: | locality=locality k=op_or_const tags=bracket(ident*)? - x=plist1(oident, COMMA) tyvars=tyvars_decl? args=ptybindings_opdecl? + x=plist1(oident, COMMA) tvs=mixed_tyvars_decl? args=ptybindings_opdecl? sty=prefix(COLON, loc(type_exp))? b=seq(prefix(EQ, loc(opbody)), opax?)? { let gloc = EcLocation.make $startpos $endpos in let sty = sty |> ofdfl (fun () -> mk_loc (b |> omap (loc |- fst) |> odfl gloc) PTunivar) in + let (idxvars, tyvars) = odfl ([], []) tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; po_tags = odfl [] tags; - po_tyvars = tyvars; + po_idxvars = idxvars; + po_tyvars = tvs |> omap (fun _ -> tyvars); po_args = odfl ([], None) args; po_def = opdef_of_opbody sty (omap (unloc |- fst) b); po_ax = obind snd b; po_locality = locality; } } | locality=locality k=op_or_const tags=bracket(ident*)? - x=plist1(oident, COMMA) tyvars=tyvars_decl? args=ptybindings_opdecl? + x=plist1(oident, COMMA) tvs=mixed_tyvars_decl? args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { { po_kind = k; + { let (idxvars, tyvars) = odfl ([], []) tvs in + { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; po_tags = odfl [] tags; - po_tyvars = tyvars; + po_idxvars = idxvars; + po_tyvars = tvs |> omap (fun _ -> tyvars); po_args = odfl ([], None) args; po_def = opdef_of_opbody sty (Some (`Reft (rname, reft))); po_ax = None; @@ -1841,27 +1907,34 @@ procop: predicate: | locality=locality PRED x=oident { { pp_name = x; + pp_idxvars = []; pp_tyvars = None; pp_def = PPabstr []; pp_locality = locality; } } -| locality=locality PRED x=oident tyvars=tyvars_decl? COLON sty=pred_tydom - { { pp_name = x; - pp_tyvars = tyvars; +| locality=locality PRED x=oident tvs=mixed_tyvars_decl? COLON sty=pred_tydom + { let (idxvars, tyvars) = odfl ([], []) tvs in + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = tvs |> omap (fun _ -> tyvars); pp_def = PPabstr sty; pp_locality = locality; } } -| locality=locality PRED x=oident tyvars=tyvars_decl? p=ptybindings? EQ f=form - { { pp_name = x; - pp_tyvars = tyvars; +| locality=locality PRED x=oident tvs=mixed_tyvars_decl? p=ptybindings? EQ f=form + { let (idxvars, tyvars) = odfl ([], []) tvs in + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = tvs |> omap (fun _ -> tyvars); pp_def = PPconcr (odfl [] p, f); pp_locality = locality; } } -| locality=locality INDUCTIVE x=oident tyvars=tyvars_decl? p=ptybindings? +| locality=locality INDUCTIVE x=oident tvs=mixed_tyvars_decl? p=ptybindings? EQ b=indpred_def - { { pp_name = x; - pp_tyvars = tyvars; + { let (idxvars, tyvars) = odfl ([], []) tvs in + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = tvs |> omap (fun _ -> tyvars); pp_def = PPind (odfl [] p, b); pp_locality = locality; } } @@ -1945,11 +2018,13 @@ mempred_binding: lemma_decl: | x=ident - tyvars=tyvars_decl? + tvs=mixed_tyvars_decl? predvars=mempred_binding? pd=pgtybindings? COLON f=form - { (x, tyvars, predvars, pd, f) } + { let (idxvars, tyvars) = odfl ([], []) tvs in + let tyvars = tvs |> omap (fun _ -> tyvars) in + (x, idxvars, tyvars, predvars, pd, f) } axiom_tc: | /* empty */ { PLemma None } @@ -1967,7 +2042,7 @@ axiom: | l=locality HOARE x=ident pd=pgtybindings? COLON p=loc( hoare_body(none)) ao=axiom_tc | l=locality EHOARE x=ident pd=pgtybindings? COLON p=loc( ehoare_body(none)) ao=axiom_tc | l=locality PHOARE x=ident pd=pgtybindings? COLON p=loc(phoare_body(none)) ao=axiom_tc - { mk_axiom ~locality:l (x, None, None, pd, p) ao } + { mk_axiom ~locality:l (x, [], None, None, pd, p) ao } proofend: | QED { `Qed } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 169e22ba8f..18f6242e1a 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -68,11 +68,22 @@ type pty_r = | PTtuple of pty list | PTnamed of pqsymbol | PTvar of psymbol - | PTapp of pqsymbol * pty list + | PTapp of pqsymbol * pty list * pindex list | PTfun of pty * pty | PTglob of pmsymbol located and pty = pty_r located +(* Polynomial-fragment index expressions appearing inside `[ ... ]` + on type-constructor applications. The typechecker validates the + sub-grammar (only +, *, non-negative literals, and identifiers + bound as indices). *) +and pindex_r = + | PIvar of psymbol + | PIint of zint + | PIadd of pindex * pindex + | PImul of pindex * pindex +and pindex = pindex_r located + type ptyannot_r = | TVIunamed of pty list | TVInamed of (psymbol * pty) list @@ -106,9 +117,10 @@ type ptyparams = ptyparam list type ptydname = (ptyparams * psymbol) located type ptydecl = { - pty_name : psymbol; - pty_tyvars : ptyparams; - pty_body : ptydbody; + pty_name : psymbol; + pty_idxvars : psymbol list; + pty_tyvars : ptyparams; + pty_body : ptydbody; pty_locality : locality; } @@ -423,6 +435,7 @@ type poperator = { po_name : psymbol; po_aliases: psymbol list; po_tags : psymbol list; + po_idxvars: psymbol list; po_tyvars : ptyvardecls option; po_args : ptybindings * ptybindings option; po_def : pop_def; @@ -451,6 +464,7 @@ and ppind = ptybindings * (ppind_ctor list) type ppredicate = { pp_name : psymbol; + pp_idxvars : psymbol list; pp_tyvars : psymbol list option; pp_def : ppred_def; pp_locality : locality; @@ -1062,6 +1076,7 @@ type mempred_binding = PT_MemPred of psymbol list type paxiom = { pa_name : psymbol; pa_pvars : mempred_binding option; + pa_idxvars : psymbol list; pa_tyvars : ptyparams option; pa_vars : pgtybindings option; pa_formula : pformula; diff --git a/src/ecScope.ml b/src/ecScope.ml index 98b830daa9..292659bcf8 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -973,7 +973,8 @@ module Ax = struct let env = env scope in let loc = ax.pl_loc and ax = ax.pl_desc in - let ue = TT.transtyvars env (loc, ax.pa_tyvars) in + let ue = + TT.transtyvars ~idxparams:ax.pa_idxvars env (loc, ax.pa_tyvars) in let (pconcl, tintro) = match ax.pa_vars with @@ -1277,7 +1278,8 @@ module Op = struct let op = op.pl_desc and loc = op.pl_loc in let eenv = env scope in - let ue = TT.transtyvars eenv (loc, op.po_tyvars) in + let ue = + TT.transtyvars ~idxparams:op.po_idxvars eenv (loc, op.po_tyvars) in let lc = op.po_locality in let args = fst op.po_args @ odfl [] (snd op.po_args) in let (ty, body, refts) = @@ -2227,23 +2229,30 @@ module Ty = struct let loc = loc tyd in - let { pty_name = name; pty_tyvars = args; + let { pty_name = name; pty_idxvars = idxs; pty_tyvars = args; pty_body = body; pty_locality = tyd_loca } = unloc tyd in check_name_available scope name; let env = env scope in + let no_indices_for kind = + if idxs <> [] then + hierror ~loc + "indexed type parameters are not yet supported on `%s' type \ + declarations" kind + in let tyd_params, tyd_type = match body with | PTYD_Abstract -> - let ue = TT.transtyvars env (loc, Some args) in + let ue = TT.transtyvars ~idxparams:idxs env (loc, Some args) in EcUnify.UniEnv.tparams ue, Abstract | PTYD_Alias bd -> - let ue = TT.transtyvars env (loc, Some args) in + let ue = TT.transtyvars ~idxparams:idxs env (loc, Some args) in let body = transty tp_tydecl env ue bd in EcUnify.UniEnv.tparams ue, Concrete body | PTYD_Datatype dt -> ( + no_indices_for "datatype"; let datatype = EHI.trans_datatype env (mk_loc loc (args, name)) dt in let ty_from_ctor ctor = EcEnv.Ty.by_path ctor env in try @@ -2255,6 +2264,7 @@ module Ty = struct EHI.dterror loc env (EHI.DTE_NonPositive (symbol, ctx))) | PTYD_Record rt -> + no_indices_for "record"; let record = EHI.trans_record env (mk_loc loc (args,name)) rt in let scheme = ELI.indsc_of_record record in record.ELI.rc_tparams, Record (scheme, record.ELI.rc_fields) diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 3c2a6093c4..dfc895d1c4 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -40,6 +40,9 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +(* Cloning of indexed declarations is not yet supported (Phase 3 + landed the binders but not the index-instantiation surface). *) +| CE_IndexedNotYetSupported of ovkind * qsymbol exception CloneError of EcEnv.env * clone_error @@ -276,6 +279,8 @@ end = struct | None -> clone_error oc.oc_env (CE_UnkOverride (OVK_Type, name)); | Some refty -> + if refty.tyd_params.idxvars <> [] then + clone_error oc.oc_env (CE_IndexedNotYetSupported (OVK_Type, name)); if List.length refty.tyd_params.tyvars <> ntyargs then clone_error oc.oc_env (CE_TypeArgMism (OVK_Type, name)) in diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli index 82e160cfa2..e632cc051a 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -34,6 +34,7 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IndexedNotYetSupported of ovkind * qsymbol exception CloneError of EcEnv.env * clone_error diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 0fc53ff65b..36bb97592d 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -136,7 +136,10 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol | DuplicatedTyVar +| DuplicatedIndexVar of symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | NonLinearPattern @@ -481,15 +484,36 @@ let transtcs (env : EcEnv.env) tcs = Sp.of_list (List.map for1 tcs) (* -------------------------------------------------------------------- *) -let transtyvars (env : EcEnv.env) (loc, tparams) = - let tparams = tparams |> omap - (fun tparams -> - let for1 ({ pl_desc = x }) = (EcIdent.create x) in - if not (List.is_unique (List.map unloc tparams)) then - tyerror loc env DuplicatedTyVar; - { EcDecl.idxvars = []; tyvars = List.map for1 tparams }) +let transtyvars + ?(idxparams : psymbol list = []) + (env : EcEnv.env) + (loc, tparams) += + let mk1 ({ pl_desc = x } : psymbol) = EcIdent.create x in + let idxvars = List.map mk1 idxparams in + begin + let rec find_dup seen = function + | [] -> None + | x :: rest -> if List.mem x seen then Some x else find_dup (x :: seen) rest + in + match find_dup [] (List.map unloc idxparams) with + | None -> () + | Some x -> tyerror loc env (DuplicatedIndexVar x) + end; + let tyvars = + match tparams with + | None -> [] + | Some tparams -> + if not (List.is_unique (List.map unloc tparams)) then + tyerror loc env DuplicatedTyVar; + List.map mk1 tparams in - EcUnify.UniEnv.create tparams + let params : EcDecl.ty_params option = + if idxparams = [] && tparams = None + then None + else Some { idxvars; tyvars } + in + EcUnify.UniEnv.create params (* -------------------------------------------------------------------- *) exception TymodCnvFailure of tymod_cnv_failure @@ -1002,31 +1026,41 @@ let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = tyerror ty.pl_loc env (UnknownTypeName name) | Some (p, tydecl) -> - let { tyvars; idxvars = _ } = tydecl.tyd_params in + let { tyvars; idxvars } = tydecl.tyd_params in if tyvars <> [] then begin let nargs = List.length tyvars in tyerror ty.pl_loc env (InvalidTypeAppl (name, nargs, 0)) end; + if idxvars <> [] then begin + let nargs = List.length idxvars in + tyerror ty.pl_loc env (InvalidIndexAppl (name, nargs, 0)) + end; tconstr p end | PTfun(ty1,ty2) -> tfun (transty tp env ue ty1) (transty tp env ue ty2) - | PTapp ({ pl_desc = name }, tyargs) -> + | PTapp ({ pl_desc = name }, tyargs, idxargs) -> begin match EcEnv.Ty.lookup_opt name env with | None -> tyerror ty.pl_loc env (UnknownTypeName name) | Some (p, tydecl) -> - let nargs = List.length tyargs in - let expected = List.length tydecl.tyd_params.tyvars in + let nargs = List.length tyargs in + let expected = List.length tydecl.tyd_params.tyvars in + let nidx = List.length idxargs in + let expected_ix = List.length tydecl.tyd_params.idxvars in if nargs <> expected then tyerror ty.pl_loc env (InvalidTypeAppl (name, expected, nargs)); + if nidx <> expected_ix then + tyerror ty.pl_loc env (InvalidIndexAppl (name, expected_ix, nidx)); + let tyargs = transtys tp env ue tyargs in - tconstr ~tyargs p + let indices = List.map (transtindex env ue) idxargs in + tconstr ~indices ~tyargs p end | PTglob gp -> let mo,_ = trans_msymbol env gp in @@ -1035,6 +1069,27 @@ let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = and transtys tp (env : EcEnv.env) ue tys = List.map (transty tp env ue) tys +(* Translate a parsed [pindex] to a [tindex]. Identifiers must be + bound as index variables in [ue]. The grammar guarantees we never + see a non-polynomial shape; the only typing-time check is the + variable lookup. *) +and transtindex (env : EcEnv.env) (ue : EcUnify.unienv) (pi : pindex) : tindex = + match pi.pl_desc with + | PIvar { pl_desc = name; pl_loc = loc } -> + begin match EcUnify.UniEnv.getnamed_idx ue name with + | Some id -> TIVar id + | None -> tyerror loc env (UnboundIndexVariable name) + end + | PIint n -> + (* Lexer only produces non-negative UINTs, but defensively. *) + if EcBigInt.sign n < 0 then + tyerror pi.pl_loc env (UnboundIndexVariable "negative literal"); + TIConst n + | PIadd (a, b) -> + TIAdd (transtindex env ue a, transtindex env ue b) + | PImul (a, b) -> + TIMul (transtindex env ue a, transtindex env ue b) + let transty_for_decl env ty = let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in transty tp_nothing env ue ty diff --git a/src/ecTyping.mli b/src/ecTyping.mli index bf2da3aa21..14179d1bd0 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -128,7 +128,10 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol | DuplicatedTyVar +| DuplicatedIndexVar of symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | NonLinearPattern @@ -190,6 +193,7 @@ val tp_nothing : typolicy (* -------------------------------------------------------------------- *) val transtyvars: + ?idxparams:psymbol list -> env -> (EcLocation.t * ptyparams option) -> EcUnify.unienv (* -------------------------------------------------------------------- *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index fb86a4f6f5..a386e18ba8 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -204,10 +204,14 @@ let subst_of_uf (uf : UF.t) = (* -------------------------------------------------------------------- *) type unienv_r = { - ue_uf : UF.t; - ue_named : EcIdent.t Mstr.t; - ue_decl : EcIdent.t list; - ue_closed : bool; + ue_uf : UF.t; + ue_named : EcIdent.t Mstr.t; + ue_decl : EcIdent.t list; + ue_closed : bool; + (* Indices live in their own namespace, separate from type variables. + They are always closed (declared up front, no on-demand creation). *) + ue_idxnamed : EcIdent.t Mstr.t; + ue_idxdecl : EcIdent.t list; } type unienv = unienv_r ref @@ -240,25 +244,36 @@ module UniEnv = struct let create (vd : ty_params option) = let ue = { - ue_uf = UF.initial; - ue_named = Mstr.empty; - ue_decl = []; - ue_closed = false; + ue_uf = UF.initial; + ue_named = Mstr.empty; + ue_decl = []; + ue_closed = false; + ue_idxnamed = Mstr.empty; + ue_idxdecl = []; } in let ue = match vd with | None -> ue | Some vd -> - let vd = vd.tyvars in - let vdmap = List.map (fun x -> (EcIdent.name x, x)) vd in + let tyvars = vd.tyvars in + let vdmap = List.map (fun x -> (EcIdent.name x, x)) tyvars in + let imap = List.map (fun x -> (EcIdent.name x, x)) vd.idxvars in { ue with - ue_named = Mstr.of_list vdmap; - ue_decl = List.rev vd; - ue_closed = true; } + ue_named = Mstr.of_list vdmap; + ue_decl = List.rev tyvars; + ue_closed = true; + ue_idxnamed = Mstr.of_list imap; + ue_idxdecl = List.rev vd.idxvars; } in ref ue + (* Look up an index variable by name. Returns None if no such + binding exists. Indices are always declared up front, so we never + create one on demand. *) + let getnamed_idx (ue : unienv) (x : symbol) : EcIdent.t option = + Mstr.find_opt x (!ue).ue_idxnamed + let fresh ?(ty : ty option) (ue : unienv) = let (uf, uid) = UnifyCore.fresh ?ty (!ue).ue_uf in ue := { !ue with ue_uf = uf }; uid @@ -317,7 +332,8 @@ module UniEnv = struct subst_of_uf (!ue).ue_uf let tparams (ue : unienv) : ty_params = - { idxvars = []; tyvars = List.rev (!ue).ue_decl } + { idxvars = List.rev (!ue).ue_idxdecl; + tyvars = List.rev (!ue).ue_decl; } end (* -------------------------------------------------------------------- *) diff --git a/src/ecUnify.mli b/src/ecUnify.mli index d19596eb6b..70ea5ac08e 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -24,6 +24,8 @@ module UniEnv : sig val restore : dst:unienv -> src:unienv -> unit (* constant time *) val fresh : ?ty:ty -> unienv -> ty val getnamed : unienv -> symbol -> EcIdent.t + (* Indices are declared up front: returns [None] when no binding. *) + val getnamed_idx : unienv -> symbol -> EcIdent.t option val repr : unienv -> ty -> ty val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t val openty : unienv -> ty_params -> tvi -> ty -> ty * ty list diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 249cfb5209..e4df6a888e 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -292,9 +292,19 @@ end = struct | InvalidTypeAppl (name, _, _) -> msg "invalid type application: %a" pp_qsymbol name + | InvalidIndexAppl (name, expected, got) -> + msg "invalid index application for `%a': %d index argument(s) expected, %d given" + pp_qsymbol name expected got + + | UnboundIndexVariable name -> + msg "unbound index variable: `%s'" name + | DuplicatedTyVar -> msg "a type variable appear at least twice" + | DuplicatedIndexVar name -> + msg "an index variable appears at least twice: `%s'" name + | DuplicatedLocal name -> msg "duplicated local/parameters name: `%s'" name @@ -749,6 +759,10 @@ end = struct msg "type argument mismatch for %s `%s'" (string_of_ovkind kd) (string_of_qsymbol x) + | CE_IndexedNotYetSupported (kd, x) -> + msg "cloning of indexed %s `%s' is not yet supported" + (string_of_ovkind kd) (string_of_qsymbol x) + | CE_OpIncompatible (x, err) -> msg "operator `%s' body %a" (string_of_qsymbol x) (pp_incompatible env) err diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec new file mode 100644 index 0000000000..ddaef74b01 --- /dev/null +++ b/tests/indexed-types.ec @@ -0,0 +1,33 @@ +(* -------------------------------------------------------------------- *) +(* Phase-3 Slice A — concrete syntax for indexed types. + Indices live in [...] (no apostrophe); applications use <:...:>. *) + +(* Bare indexed type (no type parameters). *) +type [n] vec0. + +(* Indexed and parametric. *) +type [n] 'a vec. + +(* Multiple indices, multiple type parameters. *) +type [n m] ('a, 'b) mat. + +(* Fully-applied (no free index variable): integer literals. *) +type three_vec = int vec<:3>. + +(* Index expressions: + and *. The polynomial fragment is not yet + reduced to canonical form at the surface, but Phase-1 ensures the + resulting ty is hashconsed canonically. *) +type tagged = int vec<:1+1>. +type two_three = int vec<:2*3>. + +(* Index variables in scope, used in the body. *) +type [n] 'a my_vec = 'a vec<:n>. +type [n m] 'a my_pair = 'a vec<:n+m>. + +(* Phase-3 Slice B — indices on operator / predicate / axiom binders. + Indexed application at use sites is not yet supported (it would + need TIUnivar-based index inference); the binders themselves + parse and typecheck. *) +op ix_op [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>. +pred ix_pr [n 'a] : 'a vec<:n>. +axiom ix_ax [n 'a] : true. From 02b7e17894cf370bd3112fe53db74839a317cc1d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 15:17:13 +0200 Subject: [PATCH 07/40] =?UTF-8?q?indexed-types:=20phase=203.5=20=E2=80=94?= =?UTF-8?q?=20index=20inference=20at=20op-application=20sites?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds the TIUnivar machinery Phase 3 deferred. Indexed ops can now be called: each idxvar of the op being applied is freshened to a TIUnivar and unified against the call site via polynomial-normal-form equality. op concat [n m 'a] (xs : 'a vec<:n>) (ys : 'a vec<:m>) : 'a vec<:n+m>. op cons [n 'a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. op test [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) : 'a vec<:n+(1+m)> (* canonically equal to (n+1)+m *) = concat (cons x ys) zs. The typecheck of `test` works because `cons`'s `?u` unifies with `n`, `concat`'s `?u_n` unifies with `(n+1)`, `?u_m` with `m`, and the inferred return type `(n+1)+m` is canonically equal to the annotated `n+(1+m)`. MVP scope: handles "naked TIUnivar = arbitrary polynomial" (with occurs check) and canonical equality after resolution. Refuses genuine polynomial unification (e.g. `?u + 1 = n` would need subtraction-inversion) with a clean IndexMismatch error. Also fixes a lurking bug in `ty_subst` where the `Tconstr` case fell through to `ty_map`, which preserves indices verbatim — silently dropping op-application index substitution. --- memory.md | 66 +++++++++++++ src/ecAst.ml | 69 +++++++++++--- src/ecAst.mli | 13 ++- src/ecCoreSubst.ml | 96 +++++++++++++------ src/ecCoreSubst.mli | 4 + src/ecSubst.ml | 1 + src/ecTypes.ml | 7 +- src/ecTypes.mli | 1 + src/ecTyping.ml | 3 + src/ecTyping.mli | 1 + src/ecUnify.ml | 208 ++++++++++++++++++++++++++++++++--------- src/ecUnify.mli | 5 +- src/ecUserMessages.ml | 6 ++ tests/indexed-types.ec | 21 +++++ 14 files changed, 406 insertions(+), 95 deletions(-) diff --git a/memory.md b/memory.md index 4bf8e29e75..c14876c470 100644 --- a/memory.md +++ b/memory.md @@ -292,6 +292,68 @@ after success) covering: `clone with`, plus a way to substitute indices through the cloned declarations. +### Phase 3.5 — Index inference at op-application sites (DONE) + +Added the `TIUnivar`-based machinery that Phase 3 deferred. Without +this, indexed ops could be *declared* but not *called* — the unifier +had no way to instantiate an op's index parameter against the +caller's index expression. + +#### What changed + +- [src/ecAst.ml](src/ecAst.ml) + [.mli](src/ecAst.mli) — new + `TIUnivar of EcUid.uid` variant on `tindex`. The canonical-form + monomial key is now `tindex_var = TVVar of EcIdent.t | TVUni of + EcUid.uid`, so univars are first-class atoms in the polynomial. + New helpers `tindex_naked_univar` (detects `TIUnivar u` modulo + canonicalisation) and `tindex_occurs_univar` (occurs check). + `tindex_canonicalize`, `tindex_fv_acc`, `dump_tindex` extended. +- [src/ecCoreSubst.ml](src/ecCoreSubst.ml) + + [.mli](src/ecCoreSubst.mli) — `f_subst` gains `fs_idx : tindex + Mid.t` (op-application instantiation, ident → tindex) and `fs_iu : + tindex Muid.t` (univar resolution after unification). + `tindex_subst` consults both. + **Critical fix**: `ty_subst`'s `Tconstr` case now substitutes + through `targs.indices` directly; the previous `ty_map` catch-all + left them untouched, which silently dropped the op-application + index substitution. This was the immediate cause of every "no + matching operator" error on indexed op calls. +- [src/ecUnify.ml](src/ecUnify.ml) + [.mli](src/ecUnify.mli) — + `unienv_r` gains `ue_iuf : tindex Muid.t` (assignments) and + `ue_iuf_alloc : Suid.t` (alloc tracking, for the close-time + check). `unify_core` rewritten to take a `unienv` directly and + handle a new `IxUni` work-list case. `pb` extended to + `[ TyUni | IxUni ]`. `idx_fresh` allocates fresh TIUnivars; + `openidx` produces the ident → univar substitution map; `openty_r` + threads it. `closed`/`close` now also require all index univars + resolved; new `iu_close` / `iu_assubst` expose the assignment map. +- [src/ecTyping.ml](src/ecTyping.ml) + [.mli](src/ecTyping.mli) — + `unify_or_fail` handles `IxUni`; new `IndexMismatch` tyerror with + a printer in [src/ecUserMessages.ml](src/ecUserMessages.ml). +- [src/ecTypes.mli](src/ecTypes.mli) — exposed `dump_tindex`. +- [tests/indexed-types.ec](tests/indexed-types.ec) — extended with + the polynomial-equality regression: single-call `cons`, the + chained `concat (cons x ys) zs`, two variants annotated with + `(n+1)+m` vs `n+(1+m)` proving normal-form equality across + associativity. + +#### MVP scope + +- **Handled**: "naked `TIUnivar` ≟ arbitrary polynomial" + (with occurs check), and canonical-equality after univar + resolution. Covers the common chained-op pattern. +- **Not handled**: general polynomial unification. + `?u + 1 ≟ n` would need to invert subtraction; refused with + `IndexMismatch`. + +#### Verified + +55 declarations in `tests/indexed-types.ec` compile, including +`single`, `test1` (`(n+1)+m`) and `test2` (`n+(1+m)`). +Negative case (`vec<:n+2>` annotated as the result of `cons x ys`) +errors out cleanly (with a slightly misleading "no matching +operator" message — Phase-6 polish issue). + ### Phase 4 — Theories & smoke tests 1. Add a focused `.ec` test exercising: - declaration of an indexed type and indexed op @@ -301,6 +363,10 @@ after success) covering: 2. Recommend leaving `theories/Array.ec` etc. untouched for the first landing. +Note: Phase-3.5's regression already covers items 1.a and 1.b. +Phase 4 may collapse to "extend the regression with cloning once +that's supported" plus the optional Array.ec migration. + ### Phase 5 — SMT gating Replace the `assert (List.is_empty tys.indices)` calls in [src/ecSmt.ml](src/ecSmt.ml) with a clean "indexed types not yet diff --git a/src/ecAst.ml b/src/ecAst.ml index dc7cc5ccc8..ae9413d091 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -58,10 +58,11 @@ and ty_node = | Tfun of ty * ty and tindex = - | TIVar of EcIdent.t - | TIConst of EcBigInt.zint - | TIAdd of tindex * tindex - | TIMul of tindex * tindex + | TIVar of EcIdent.t + | TIUnivar of EcUid.uid + | TIConst of EcBigInt.zint + | TIAdd of tindex * tindex + | TIMul of tindex * tindex and targs = { indices : tindex list; @@ -1074,9 +1075,27 @@ let pr_hash pr = (* normalising to a canonical sum-of-monomials. *) (* ----------------------------------------------------------------- *) -(* A monomial is a sorted association list (ident, exponent) with +(* A polynomial "variable" is either a user-bound index identifier or + a unification univar; both are opaque atoms inside the polynomial. + A monomial is a sorted association list (variable, exponent) with each exponent >= 1. The empty list represents the constant 1. *) -type tindex_mono = (EcIdent.t * int) list +type tindex_var = + | TVVar of EcIdent.t + | TVUni of EcUid.uid + +let tindex_var_compare (a : tindex_var) (b : tindex_var) : int = + match a, b with + | TVVar x, TVVar y -> EcIdent.id_compare x y + | TVUni u, TVUni v -> EcUid.uid_compare u v + | TVVar _, TVUni _ -> -1 + | TVUni _, TVVar _ -> 1 + +let tindex_var_hash (a : tindex_var) : int = + match a with + | TVVar x -> EcIdent.id_hash x + | TVUni u -> Why3.Hashcons.combine 1 u + +type tindex_mono = (tindex_var * int) list (* A polynomial in canonical form over the non-negative integers. Invariants: @@ -1096,19 +1115,19 @@ let mono_compare : tindex_mono -> tindex_mono -> int = | [], _ -> -1 | _ , [] -> 1 | (x1, e1) :: t1, (x2, e2) :: t2 -> - let c = EcIdent.id_compare x1 x2 in + let c = tindex_var_compare x1 x2 in if c <> 0 then c else let c = Stdlib.compare (e1 : int) e2 in if c <> 0 then c else cmp t1 t2 in cmp -(* Multiply two monomials: merge by ident, sum exponents. *) +(* Multiply two monomials: merge by variable, sum exponents. *) let rec mono_mul (m1 : tindex_mono) (m2 : tindex_mono) : tindex_mono = match m1, m2 with | [], _ -> m2 | _, [] -> m1 | (x1, e1) :: t1, (x2, e2) :: t2 -> - let c = EcIdent.id_compare x1 x2 in + let c = tindex_var_compare x1 x2 in if c < 0 then (x1, e1) :: mono_mul t1 m2 else if c > 0 then (x2, e2) :: mono_mul m1 t2 else (x1, e1 + e2) :: mono_mul t1 t2 @@ -1139,7 +1158,11 @@ let canonical_const (n : EcBigInt.zint) = let canonical_var (id : EcIdent.t) = { cn_konst = EcBigInt.zero; - cn_mons = [([(id, 1)], EcBigInt.one)] } + cn_mons = [([(TVVar id, 1)], EcBigInt.one)] } + +let canonical_univar (u : EcUid.uid) = + { cn_konst = EcBigInt.zero; + cn_mons = [([(TVUni u, 1)], EcBigInt.one)] } let canonical_add (p : tindex_canonical) (q : tindex_canonical) = { cn_konst = EcBigInt.add p.cn_konst q.cn_konst; @@ -1166,6 +1189,7 @@ let canonical_mul (p : tindex_canonical) (q : tindex_canonical) = let rec tindex_canonicalize (ti : tindex) : tindex_canonical = match ti with | TIVar id -> canonical_var id + | TIUnivar u -> canonical_univar u | TIConst n -> canonical_const n | TIAdd (l, r) -> canonical_add (tindex_canonicalize l) (tindex_canonicalize r) | TIMul (l, r) -> canonical_mul (tindex_canonicalize l) (tindex_canonicalize r) @@ -1182,10 +1206,32 @@ let canonical_equal (p : tindex_canonical) (q : tindex_canonical) = && eq t1 t2 in eq p.cn_mons q.cn_mons +(* Whether the canonical polynomial is a single naked TIUnivar. + Returns [Some u] when so; otherwise [None]. Used by the unifier + to detect index-equations that reduce to a univar assignment. *) +let tindex_naked_univar (ti : tindex) : EcUid.uid option = + let c = tindex_canonicalize ti in + if not (EcBigInt.equal c.cn_konst EcBigInt.zero) then None else + match c.cn_mons with + | [(mono, coef)] when EcBigInt.equal coef EcBigInt.one -> begin + match mono with + | [(TVUni u, 1)] -> Some u + | _ -> None + end + | _ -> None + +(* Occurs check: does univar [u] appear anywhere in [ti]? *) +let tindex_occurs_univar (u : EcUid.uid) (t : tindex) : bool = + let rec walk = function + | TIUnivar v -> EcUid.uid_equal u v + | TIVar _ | TIConst _ -> false + | TIAdd (l, r) | TIMul (l, r) -> walk l || walk r + in walk t + let canonical_hash (p : tindex_canonical) = let mono_hash (m : tindex_mono) = Why3.Hashcons.combine_list - (fun (id, e) -> Why3.Hashcons.combine (EcIdent.id_hash id) e) + (fun (v, e) -> Why3.Hashcons.combine (tindex_var_hash v) e) 0 m in let pair_hash (m, c) = Why3.Hashcons.combine (mono_hash m) (EcBigInt.hash c) in @@ -1209,6 +1255,7 @@ let targs_equal (ta1 : targs) (ta2 : targs) : bool = let rec tindex_fv_acc (acc : int Mid.t) (ti : tindex) : int Mid.t = match ti with | TIVar id -> fv_add id acc + | TIUnivar _ -> acc | TIConst _ -> acc | TIAdd (l, r) | TIMul (l, r) -> tindex_fv_acc (tindex_fv_acc acc l) r diff --git a/src/ecAst.mli b/src/ecAst.mli index b88c2e048d..8f9e8ae00c 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -52,10 +52,11 @@ and ty_node = | Tfun of ty * ty and tindex = - | TIVar of EcIdent.t - | TIConst of EcBigInt.zint - | TIAdd of tindex * tindex - | TIMul of tindex * tindex + | TIVar of EcIdent.t + | TIUnivar of EcUid.uid + | TIConst of EcBigInt.zint + | TIAdd of tindex * tindex + | TIMul of tindex * tindex and targs = { indices : tindex list; @@ -424,6 +425,10 @@ val tindex_fv : tindex fv val targs_equal : targs equality val targs_fv : targs fv +(* Index-univar helpers used by [EcUnify]. *) +val tindex_naked_univar : tindex -> EcUid.uid option +val tindex_occurs_univar : EcUid.uid -> tindex -> bool + val ty_equal : ty equality val ty_hash : ty hash val ty_fv : ty fv diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 586128489b..e38145e281 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -25,6 +25,15 @@ type f_subst = { fs_freshen : bool; (* true means freshen locals *) fs_u : ty Muid.t; fs_v : ty Mid.t; + (* Index-variable substitution. Used at op-application time to + replace each of the op's idxvar idents with a fresh TIUnivar + allocated by EcUnify. Consulted by [tindex_subst] before + falling back to [fs_loc]. *) + fs_idx : tindex Mid.t; + (* Index-univar substitution. Populated when an index unification + resolves a TIUnivar; applied lazily when subsituting through + types that still mention the univar. *) + fs_iu : tindex Muid.t; fs_mod : EcPath.mpath Mid.t; fs_modex : mod_extra Mid.t; fs_loc : form Mid.t; @@ -58,17 +67,23 @@ let f_subst_init ?(freshen=false) ?(tu=Muid.empty) ?(tv=Mid.empty) + ?(idx=Mid.empty) + ?(iu=Muid.empty) ?(esloc=Mid.empty) () = let fv = Mid.empty in let fv = Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu fv in let fv = fv_Mid ty_fv tv fv in let fv = fv_Mid e_fv esloc fv in + let fv = fv_Mid tindex_fv idx fv in + let fv = Muid.fold (fun _ t s -> fv_union s (tindex_fv t)) iu fv in { fs_freshen = freshen; fs_u = tu; fs_v = tv; + fs_idx = idx; + fs_iu = iu; fs_mod = Mid.empty; fs_modex = Mid.empty; fs_loc = Mid.empty; @@ -158,15 +173,53 @@ let f_rem_mod (s : f_subst) (x : ident) : f_subst = (* -------------------------------------------------------------------- *) (* True when no substitution can affect a type. Indices share the formula-locals namespace (Phase 2), so [fs_loc] participates here - even though it is otherwise a formula-only map. *) + even though it is otherwise a formula-only map. The dedicated + [fs_idx] map (Phase 3.5, op-application substitution) does too. *) let is_ty_subst_id (s : f_subst) : bool = Mid.is_empty s.fs_mod && Muid.is_empty s.fs_u && Mid.is_empty s.fs_v + && Mid.is_empty s.fs_idx + && Muid.is_empty s.fs_iu && Mid.is_empty s.fs_loc (* -------------------------------------------------------------------- *) -let rec ty_subst (s : f_subst) (ty : ty) : ty = +let rec tindex_subst_ (s : f_subst) (ti : tindex) : tindex = + match ti with + | TIVar id -> begin + match Mid.find_opt id s.fs_idx with + | Some ti' -> ti' + | None -> + match Mid.find_opt id s.fs_loc with + | None -> ti + | Some f -> + match tindex_of_form f with + | Some ti' -> ti' + | None -> + failwith + (Printf.sprintf + "tindex_subst: index variable %s is bound to a \ + formula not expressible as a tindex" + (EcIdent.name id)) + end + | TIUnivar u -> begin + (* Resolve through the unifier-produced assignment map. Walk + chains in case the assignment itself contains univars. *) + match Muid.find_opt u s.fs_iu with + | None -> ti + | Some ti -> tindex_subst_ s ti + end + | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = tindex_subst_ s l in + let r' = tindex_subst_ s r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = tindex_subst_ s l in + let r' = tindex_subst_ s r in + if l == l' && r == r' then ti else TIMul (l', r') + +and ty_subst (s : f_subst) (ty : ty) : ty = match ty.ty_node with | Tglob m -> Mid.find_opt m s.fs_modex @@ -178,6 +231,13 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = |> Option.value ~default:ty | Tvar id -> Mid.find_def ty id s.fs_v + | Tconstr (p, ta) -> + (* Walk both index and type arguments — [ty_map] would only + touch the type arguments. *) + let indices = List.Smart.map (tindex_subst_ s) ta.indices in + let types = List.Smart.map (ty_subst s) ta.types in + if indices == ta.indices && types == ta.types then ty + else tconstr_r p { indices; types } | _ -> ty_map (ty_subst s) ty @@ -186,35 +246,9 @@ let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s (* -------------------------------------------------------------------- *) -(* Substitute through a tindex polynomial. For each [TIVar id], look up - [id] in [fs_loc]; if a binding exists, the bound formula must be - expressible as a tindex (caller-side invariant — see - [tindex_of_form]). The result is left in syntactic form; - normalisation happens lazily in [tindex_equal] / [tindex_hash]. *) -let rec tindex_subst (s : f_subst) (ti : tindex) : tindex = - match ti with - | TIVar id -> begin - match Mid.find_opt id s.fs_loc with - | None -> ti - | Some f -> - match tindex_of_form f with - | Some ti' -> ti' - | None -> - failwith - (Printf.sprintf - "tindex_subst: index variable %s is bound to a \ - formula not expressible as a tindex" - (EcIdent.name id)) - end - | TIConst _ -> ti - | TIAdd (l, r) -> - let l' = tindex_subst s l in - let r' = tindex_subst s r in - if l == l' && r == r' then ti else TIAdd (l', r') - | TIMul (l, r) -> - let l' = tindex_subst s l in - let r' = tindex_subst s r in - if l == l' && r == r' then ti else TIMul (l', r') +(* Public name for the polynomial-substitution helper used internally + by [ty_subst] above. *) +let tindex_subst = tindex_subst_ (* -------------------------------------------------------------------- *) let targs_subst (s : f_subst) (ta : targs) : targs = diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 476b6943a2..2334e0873b 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -28,6 +28,8 @@ val f_subst_init : ?freshen:bool -> ?tu:ty Muid.t -> ?tv:ty Mid.t + -> ?idx:tindex Mid.t + -> ?iu:tindex Muid.t -> ?esloc:expr Mid.t -> unit -> f_subst @@ -72,6 +74,8 @@ module Fsubst : sig ?freshen:bool -> ?tu:ty Muid.t -> ?tv:ty Mid.t + -> ?idx:tindex Mid.t + -> ?iu:tindex Muid.t -> ?esloc:expr Mid.t -> unit -> f_subst diff --git a/src/ecSubst.ml b/src/ecSubst.ml index b9c0dadad9..b85f888879 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -165,6 +165,7 @@ let rec subst_tindex (s : subst) (ti : tindex) : tindex = formula not expressible as a tindex" (EcIdent.name id)) end + | TIUnivar _ -> ti | TIConst _ -> ti | TIAdd (l, r) -> let l' = subst_tindex s l in diff --git a/src/ecTypes.ml b/src/ecTypes.ml index ee196d1f03..97e790d081 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -45,14 +45,17 @@ let rec dump_tindex (ti : tindex) = | TIVar x -> EcIdent.tostring_internal x + | TIUnivar u -> + Format.sprintf "?#%d" u + | TIConst i -> EcBigInt.to_string i - | TIAdd (l, r) -> + | TIAdd (l, r) -> Format.sprintf "(%s + %s)" (dump_tindex l) (dump_tindex r) | TIMul (l, r) -> - Format.sprintf "(%s + %s)" (dump_tindex l) (dump_tindex r) + Format.sprintf "(%s * %s)" (dump_tindex l) (dump_tindex r) (* -------------------------------------------------------------------- *) let rec dump_ty (ty : ty) = diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 18b5799819..51075d2e10 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -29,6 +29,7 @@ module Hty : EcMaps.EHashtbl.S with type key = ty type dom = ty list val dump_ty : ty -> string +val dump_tindex : tindex -> string val ty_equal : ty -> ty -> bool val ty_hash : ty -> int diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 36bb97592d..ad7103cba4 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -138,6 +138,7 @@ type tyerror = | InvalidTypeAppl of qsymbol * int * int | InvalidIndexAppl of qsymbol * int * int | UnboundIndexVariable of symbol +| IndexMismatch of tindex * tindex | DuplicatedTyVar | DuplicatedIndexVar of symbol | DuplicatedLocal of symbol @@ -209,6 +210,8 @@ let unify_or_fail (env : EcEnv.env) ue loc ~expct:ty1 ty2 = let tyinst = ty_subst (Tuni.subst uidmap) in tyerror loc env (TypeMismatch ((tyinst ty1, tyinst ty2), (tyinst t1, tyinst t2))) + | `IxUni (i1, i2) -> + tyerror loc env (IndexMismatch (i1, i2)) (* -------------------------------------------------------------------- *) let add_glob (m:Sx.t) (x:prog_var) : Sx.t = diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 14179d1bd0..98967ae7ec 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -130,6 +130,7 @@ type tyerror = | InvalidTypeAppl of qsymbol * int * int | InvalidIndexAppl of qsymbol * int * int | UnboundIndexVariable of symbol +| IndexMismatch of tindex * tindex | DuplicatedTyVar | DuplicatedIndexVar of symbol | DuplicatedLocal of symbol diff --git a/src/ecUnify.ml b/src/ecUnify.ml index a386e18ba8..013b50daef 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -13,7 +13,7 @@ module Sp = EcPath.Sp module TC = EcTypeClass (* -------------------------------------------------------------------- *) -type pb = [ `TyUni of ty * ty ] +type pb = [ `TyUni of ty * ty | `IxUni of tindex * tindex ] exception UnificationFailure of pb exception UninstantiateUni @@ -71,25 +71,71 @@ module UnifyCore = struct end (* -------------------------------------------------------------------- *) -let unify_core (env : EcEnv.env) (uf : UF.t) pb = +type unienv_r = { + ue_uf : UF.t; + ue_named : EcIdent.t Mstr.t; + ue_decl : EcIdent.t list; + ue_closed : bool; + (* Indices live in their own namespace, separate from type variables. + They are always closed (declared up front, no on-demand creation). *) + ue_idxnamed : EcIdent.t Mstr.t; + ue_idxdecl : EcIdent.t list; + (* Index-univar machinery (Phase 3.5). [ue_iuf] holds assignments for + resolved univars; [ue_iuf_alloc] tracks the set of all index uids + ever allocated, so [close] can detect leftover unresolved ones. *) + ue_iuf : tindex Muid.t; + ue_iuf_alloc : Suid.t; +} + +type unienv = unienv_r ref + +(* -------------------------------------------------------------------- *) +(* Index-univar helpers — defined at top level so [unify_core] can use + them. All operate on a [unienv ref]. *) + +let resolve_tindex (ue : unienv) : tindex -> tindex = + let rec doit ti = + match ti with + | TIUnivar u -> begin + match Muid.find_opt u (!ue).ue_iuf with + | None -> ti + | Some ti -> doit ti + end + | TIVar _ | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = doit l in + let r' = doit r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = doit l in + let r' = doit r in + if l == l' && r == r' then ti else TIMul (l', r') + in doit + +(* -------------------------------------------------------------------- *) +let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = let failure () = raise (UnificationFailure pb) in - let uf = ref uf in - let pb = let x = Queue.create () in Queue.push pb x; x in + let pb_q = let x = Queue.create () in Queue.push pb x; x in + let push p = Queue.push p pb_q in + + let get_uf () = (!ue).ue_uf in + let set_uf u = ue := { !ue with ue_uf = u } in + let upd_uf f = set_uf (f (get_uf ())) in let ocheck i t = - let i = UF.find i !uf in + let i = UF.find i (get_uf ()) in let map = Hint.create 0 in let rec doit t = match t.ty_node with | Tunivar i' -> begin - let i' = UF.find i' !uf in + let i' = UF.find i' (get_uf ()) in match i' with | _ when i = i' -> true | _ when Hint.mem map i' -> false | _ -> - match UF.data i' !uf with + match UF.data i' (get_uf ()) with | None -> Hint.add map i' (); false | Some t -> match doit t with @@ -103,21 +149,44 @@ let unify_core (env : EcEnv.env) (uf : UF.t) pb = in let setvar i t = - let (ti, effects) = UFArgs.D.union (UF.data i !uf) (Some t) in + let (ti, effects) = UFArgs.D.union (UF.data i (get_uf ())) (Some t) in if odfl false (ti |> omap (ocheck i)) then failure (); - List.iter (Queue.push^~ pb) effects; - uf := UF.set i ti !uf + List.iter push effects; + upd_uf (UF.set i ti) + in - and getvar t = + let getvar t = match t.ty_node with - | Tunivar i -> odfl t (UF.data i !uf) + | Tunivar i -> odfl t (UF.data i (get_uf ())) | _ -> t + in + (* Try to unify two indices. Resolves both sides through the current + univar assignments, canonicalises, and compares. If equal, done. + Otherwise tries to assign a naked univar on either side to the + other side (with occurs check). Anything else fails — we do not + attempt full polynomial unification. *) + let unify_ix t1 t2 = + let r1 = resolve_tindex ue t1 in + let r2 = resolve_tindex ue t2 in + if tindex_equal r1 r2 then () else + let assign u t = + ue := { !ue with ue_iuf = Muid.add u t (!ue).ue_iuf } in + match tindex_naked_univar r1 with + | Some u when not (tindex_occurs_univar u r2) -> assign u r2 + | _ -> begin + match tindex_naked_univar r2 with + | Some u when not (tindex_occurs_univar u r1) -> assign u r1 + | _ -> failure () + end in let doit () = - while not (Queue.is_empty pb) do - match Queue.pop pb with + while not (Queue.is_empty pb_q) do + match Queue.pop pb_q with + | `IxUni (t1, t2) -> + unify_ix t1 t2 + | `TyUni (t1, t2) -> begin let (t1, t2) = (getvar t1, getvar t2) in @@ -127,8 +196,11 @@ let unify_core (env : EcEnv.env) (uf : UF.t) pb = match t1.ty_node, t2.ty_node with | Tunivar id1, Tunivar id2 -> begin if not (uid_equal id1 id2) then - let effects = reffold (swap |- UF.union id1 id2) uf in - List.iter (Queue.push^~ pb) effects + let effects = + let uf' = get_uf () in + let (uf'', effs) = UF.union id1 id2 uf' in + set_uf uf''; effs in + List.iter push effects end | Tunivar id, _ -> setvar id t2 @@ -136,32 +208,34 @@ let unify_core (env : EcEnv.env) (uf : UF.t) pb = | Ttuple lt1, Ttuple lt2 -> if List.length lt1 <> List.length lt2 then failure (); - List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 + List.iter2 (fun t1 t2 -> push (`TyUni (t1, t2))) lt1 lt2 | Tfun (t1, t2), Tfun (t1', t2') -> - Queue.push (`TyUni (t1, t1')) pb; - Queue.push (`TyUni (t2, t2')) pb + push (`TyUni (t1, t1')); + push (`TyUni (t2, t2')) | Tconstr (p1, ta1), Tconstr (p2, ta2) when EcPath.p_equal p1 p2 -> if List.compare_lengths ta1.indices ta2.indices <> 0 then failure (); if List.compare_lengths ta1.types ta2.types <> 0 then failure (); - if not (List.all2 tindex_equal ta1.indices ta2.indices) then failure (); List.iter2 - (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) + (fun i1 i2 -> push (`IxUni (i1, i2))) + ta1.indices ta2.indices; + List.iter2 + (fun t1 t2 -> push (`TyUni (t1, t2))) ta1.types ta2.types | Tconstr (p, lt), _ when EcEnv.Ty.defined p env -> - Queue.push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) pb + push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) | _, Tconstr (p, lt) when EcEnv.Ty.defined p env -> - Queue.push (`TyUni (t1, EcEnv.Ty.unfold p lt env)) pb + push (`TyUni (t1, EcEnv.Ty.unfold p lt env)) | _, _ -> failure () end end done in - doit (); !uf + doit () (* -------------------------------------------------------------------- *) let close (uf : UF.t) = @@ -203,19 +277,6 @@ let subst_of_uf (uf : UF.t) = (* -------------------------------------------------------------------- *) -type unienv_r = { - ue_uf : UF.t; - ue_named : EcIdent.t Mstr.t; - ue_decl : EcIdent.t list; - ue_closed : bool; - (* Indices live in their own namespace, separate from type variables. - They are always closed (declared up front, no on-demand creation). *) - ue_idxnamed : EcIdent.t Mstr.t; - ue_idxdecl : EcIdent.t list; -} - -type unienv = unienv_r ref - type tvar_inst = | TVIunamed of ty list | TVInamed of (EcSymbols.symbol * ty) list @@ -244,12 +305,14 @@ module UniEnv = struct let create (vd : ty_params option) = let ue = { - ue_uf = UF.initial; - ue_named = Mstr.empty; - ue_decl = []; - ue_closed = false; - ue_idxnamed = Mstr.empty; - ue_idxdecl = []; + ue_uf = UF.initial; + ue_named = Mstr.empty; + ue_decl = []; + ue_closed = false; + ue_idxnamed = Mstr.empty; + ue_idxdecl = []; + ue_iuf = Muid.empty; + ue_iuf_alloc = Suid.empty; } in let ue = @@ -278,6 +341,37 @@ module UniEnv = struct let (uf, uid) = UnifyCore.fresh ?ty (!ue).ue_uf in ue := { !ue with ue_uf = uf }; uid + (* Allocate a fresh index univar. Tracked in [ue_iuf_alloc] so that + [close] can complain if it stays unresolved. *) + let idx_fresh (ue : unienv) : tindex = + let u = EcUid.unique () in + ue := { !ue with ue_iuf_alloc = Suid.add u (!ue).ue_iuf_alloc }; + TIUnivar u + + (* Look up the assignment of an index univar, if any. *) + let idx_data (ue : unienv) (u : uid) : tindex option = + Muid.find_opt u (!ue).ue_iuf + + (* Recursively replace TIUnivars in [ti] with their assignments + under the current unienv. Walks chains: if [u := TIUnivar v] and + [v := TIConst 5], [resolve_tindex] returns [TIConst 5]. *) + let rec resolve_tindex (ue : unienv) (ti : tindex) : tindex = + match ti with + | TIUnivar u -> begin + match idx_data ue u with + | None -> ti + | Some ti -> resolve_tindex ue ti + end + | TIVar _ | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = resolve_tindex ue l in + let r' = resolve_tindex ue r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = resolve_tindex ue l in + let r' = resolve_tindex ue r in + if l == l' && r == r' then ti else TIMul (l', r') + let opentvi (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = let params = params.tyvars in match tvi with @@ -301,11 +395,22 @@ module UniEnv = struct in List.fold_left for1 Mid.empty params + (* Allocate a fresh index univar for each [idxvar] of [params], + producing the substitution map used by [openty_r]. *) + let openidx (ue : unienv) (params : ty_params) : tindex Mid.t = + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + let subst_tv (subst : ty -> ty) (params : ty_params) = List.map (fun tv -> subst (tvar tv)) params.tyvars let openty_r (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = - let subst = f_subst_init ~tv:(opentvi ue params tvi) () in + let subst = + f_subst_init + ~tv:(opentvi ue params tvi) + ~idx:(openidx ue params) + () in (subst, subst_tv (ty_subst subst) params) let opentys (ue : unienv) (params : ty_params) (tvi : tvar_inst option) (tys : ty list) = @@ -323,6 +428,9 @@ module UniEnv = struct let closed (ue : unienv) = UF.closed (!ue).ue_uf + && Suid.subset (!ue).ue_iuf_alloc + (Muid.fold (fun u _ s -> Suid.add u s) + (!ue).ue_iuf Suid.empty) let close (ue : unienv) = if not (closed ue) then raise UninstantiateUni; @@ -331,6 +439,15 @@ module UniEnv = struct let assubst (ue : unienv) = subst_of_uf (!ue).ue_uf + (* Index-univar assignment map after typechecking. Use to build a + [f_subst] that resolves residual TIUnivars in computed types. *) + let iu_close (ue : unienv) : tindex Muid.t = + if not (closed ue) then raise UninstantiateUni; + (!ue).ue_iuf + + let iu_assubst (ue : unienv) : tindex Muid.t = + (!ue).ue_iuf + let tparams (ue : unienv) : ty_params = { idxvars = List.rev (!ue).ue_idxdecl; tyvars = List.rev (!ue).ue_decl; } @@ -338,8 +455,7 @@ end (* -------------------------------------------------------------------- *) let unify (env : EcEnv.env) (ue : unienv) (t1 : ty) (t2 : ty) = - let uf = unify_core env (!ue).ue_uf (`TyUni (t1, t2)) in - ue := { !ue with ue_uf = uf; } + unify_core env ue (`TyUni (t1, t2)) (* -------------------------------------------------------------------- *) let tfun_expected ue ?retty psig = diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 70ea5ac08e..582a71ed87 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -6,7 +6,7 @@ open EcTypes open EcDecl (* -------------------------------------------------------------------- *) -exception UnificationFailure of [`TyUni of ty * ty] +exception UnificationFailure of [`TyUni of ty * ty | `IxUni of tindex * tindex] exception UninstantiateUni type unienv @@ -33,6 +33,9 @@ module UniEnv : sig val closed : unienv -> bool val close : unienv -> ty Muid.t val assubst : unienv -> ty Muid.t + (* Index-univar resolved assignment map (Phase 3.5). *) + val iu_close : unienv -> tindex Muid.t + val iu_assubst : unienv -> tindex Muid.t val tparams : unienv -> ty_params end diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index e4df6a888e..47df332176 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -299,6 +299,12 @@ end = struct | UnboundIndexVariable name -> msg "unbound index variable: `%s'" name + | IndexMismatch (i1, i2) -> + msg "cannot unify indices `%s' and `%s' (only naked-univar \ + assignment is supported; full polynomial unification \ + is out of scope)" + (EcTypes.dump_tindex i1) (EcTypes.dump_tindex i2) + | DuplicatedTyVar -> msg "a type variable appear at least twice" diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index ddaef74b01..20c82470be 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -31,3 +31,24 @@ type [n m] 'a my_pair = 'a vec<:n+m>. op ix_op [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>. pred ix_pr [n 'a] : 'a vec<:n>. axiom ix_ax [n 'a] : true. + +(* Phase-3.5 — index inference at op-application sites. + Allocates fresh TIUnivars for each idxvar of the op being called + and unifies them against the call site via polynomial-normal-form + equality. *) +op concat [n m 'a] (xs : 'a vec<:n>) (ys : 'a vec<:m>) : 'a vec<:n+m>. +op cons [n 'a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. + +(* Direct call: ?u_n in cons unifies with caller's n. *) +op single [n 'a] (x : 'a) (ys : 'a vec<:n>) : 'a vec<:n+1> = cons x ys. + +(* Annotated result type identical to the inferred one. *) +op test1 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) + : 'a vec<:(n+1)+m> + = concat (cons x ys) zs. + +(* Same body, but the annotated result type differs by associativity: + (n+1)+m vs n+(1+m). Polynomial normalisation makes them equal. *) +op test2 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) + : 'a vec<:n+(1+m)> + = concat (cons x ys) zs. From 3cc795331a4e9e881c409446c9bded7fbd5e641a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 16:45:50 +0200 Subject: [PATCH 08/40] =?UTF-8?q?indexed-types:=20phase=204=20=E2=80=94=20?= =?UTF-8?q?cloning=20of=20indexed=20types?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit clone T as T2 with type [k] 'a vec = body The optional [k] mirrors the tydecl binder syntax. body may reference both k and the type binders; when vec<:e> appears in T, the substitution binds k to e in body. ty_override_def is widened to (idxvars, tyvars, body); subst gains sb_idxvar; subst_ty's Tconstr-with-tydef branch binds both source binder lists to the call-site indices/types before substituting through body. The previous CE_IndexedNotYetSupported is replaced with CE_IdxArgMism so the user gets a precise arity message. Three clone cases land in the regression: drop the index (= int), propagate (= 'a coll<:k>), and a polynomial of the binder (= 'a coll<:k+1>). 77 declarations now compile. Two gaps are flagged in memory.md but kept out of scope: reaching into a cloned theory's ops whose signature got touched (looks orthogonal to indexed types), and explicit index-instantiation syntax at op call sites. --- memory.md | 73 +++++++++++++++++++++++++++++++++++------- src/ecAlgTactic.ml | 2 +- src/ecEnv.ml | 2 +- src/ecParser.mly | 4 +-- src/ecParsetree.ml | 3 +- src/ecScope.ml | 2 +- src/ecSection.ml | 5 +-- src/ecSubst.ml | 27 +++++++++++++--- src/ecSubst.mli | 2 +- src/ecThCloning.ml | 14 +++++--- src/ecThCloning.mli | 1 + src/ecTheoryReplay.ml | 14 ++++---- src/ecUserMessages.ml | 4 +++ tests/indexed-types.ec | 22 +++++++++++++ 14 files changed, 139 insertions(+), 36 deletions(-) diff --git a/memory.md b/memory.md index c14876c470..fc2399760c 100644 --- a/memory.md +++ b/memory.md @@ -354,18 +354,67 @@ Negative case (`vec<:n+2>` annotated as the result of `cons x ys`) errors out cleanly (with a slightly misleading "no matching operator" message — Phase-6 polish issue). -### Phase 4 — Theories & smoke tests -1. Add a focused `.ec` test exercising: - - declaration of an indexed type and indexed op - - polynomial-equality path: `concat (concat a b) c : vec[(n+m)+k]` - unifies with `vec[n+(m+k)]` - - cloning with index instantiation -2. Recommend leaving `theories/Array.ec` etc. untouched for the first - landing. - -Note: Phase-3.5's regression already covers items 1.a and 1.b. -Phase 4 may collapse to "extend the regression with cloning once -that's supported" plus the optional Array.ec migration. +### Phase 4 — Theories & smoke tests (DONE) + +Implemented cloning of indexed types and extended the regression +accordingly. `theories/Array.ec` migration deliberately skipped for +the first landing. + +#### Final clone-with-type syntax + +`clone T as T2 with type [k] 'a vec = body` — `[k]` is the optional +idxvar list (mirroring tydecl binder syntax), body is a type +expression that may reference the idx binders (and the tyvars). +Applied textually when `vec<:e>` occurs in the source theory: the +body's idx binders get bound to `e`. + +#### What changed + +- [src/ecParsetree.ml](src/ecParsetree.ml) — `ty_override_def` + widened from `psymbol list * pty` to + `psymbol list * psymbol list * pty` (idxvars, tyvars, body). +- [src/ecParser.mly](src/ecParser.mly) — `clone_override`'s TYPE + rule accepts an optional `[]` prefix; reuses the existing + `idxvars_decl` from Phase 3. +- [src/ecSubst.ml](src/ecSubst.ml) + [.mli](src/ecSubst.mli) — + `subst` gains `sb_idxvar : tindex Mid.t`. `sb_tydef` widened to + `(idxvars, tyvars, body)`. `subst_tindex` consults `sb_idxvar` + first (then `sb_flocal` fallback). `subst_ty`'s `Tconstr`-with- + tydef branch binds *both* the source idxvars (to `ta.indices`) + and tyvars (to `ta.types`) before substituting through the body. + `add_tydef`'s tuple widened correspondingly. +- [src/ecThCloning.ml](src/ecThCloning.ml) + + [.mli](src/ecThCloning.mli) — `ty_ovrd` checks index *and* type + arity. The Phase-3 blanket-refusal `CE_IndexedNotYetSupported` is + replaced by the more precise `CE_IdxArgMism` (with a printer in + [src/ecUserMessages.ml](src/ecUserMessages.ml)). +- [src/ecTheoryReplay.ml](src/ecTheoryReplay.ml) — `BySyntax` case + threads `nidxs` through `transtyvars` and into the `add_tydef` + tuple. +- [src/ecEnv.ml](src/ecEnv.ml), [src/ecAlgTactic.ml](src/ecAlgTactic.ml), + [src/ecSection.ml](src/ecSection.ml), + [src/ecScope.ml](src/ecScope.ml) — mechanical updates to existing + `add_tydef` callers (widen `(ids, ty)` → `(idxs, ids, ty)`). +- [tests/indexed-types.ec](tests/indexed-types.ec) — added three + indexed-type clone cases: drop-the-index to `int`, propagate as + `'a coll<:k>`, use a polynomial `'a coll<:k+1>`. + +#### Verified + +77 declarations in `tests/indexed-types.ec` compile (was 55 after +Phase 3.5). `CE_IdxArgMism` correctly catches wrong-arity idx-binder +lists. + +#### Gaps worth flagging + +- Reaching *into* a cloned theory to call ops whose signature got + touched by an indexed-type override is awkward: `T2.make_vec` came + back as "unknown variable" in experimentation. Looks orthogonal to + indexed types — likely a clone-with-substitution / namespace + artefact — but worth a note. +- No explicit index-instantiation syntax at op call sites + (`f<:idx, ty>`) yet; tests that need index-passing at the call + site rely on inference. A Phase-6 polish could add this. ### Phase 5 — SMT gating Replace the `assert (List.is_empty tys.indices)` calls in diff --git a/src/ecAlgTactic.ml b/src/ecAlgTactic.ml index cf1ff5ef4a..efdcbee720 100644 --- a/src/ecAlgTactic.ml +++ b/src/ecAlgTactic.ml @@ -80,7 +80,7 @@ module Axioms = struct let addctt = fun subst x f -> EcSubst.add_opdef subst (xpath x) ([], f) in let subst = - EcSubst.add_tydef EcSubst.empty (xpath tname) ([], cr.r_type) in + EcSubst.add_tydef EcSubst.empty (xpath tname) ([], [], cr.r_type) in let subst = List.fold_left (fun subst (x, p) -> add subst x p) subst crcore in let subst = odfl subst (cr.r_opp |> omap (fun p -> add subst opp p)) in diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 7cfdc22020..0c13608d96 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -904,7 +904,7 @@ module MC = struct let self = EcIdent.create "'self" in - let tsubst =EcSubst.add_tydef EcSubst.empty mypath ([], tvar self) in + let tsubst =EcSubst.add_tydef EcSubst.empty mypath ([], [], tvar self) in let operators = let on1 (opid, optype) = diff --git a/src/ecParser.mly b/src/ecParser.mly index f6c79fdca9..eea73488c9 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3679,8 +3679,8 @@ cltyparams: | xs=paren(plist1(tident, COMMA)) { xs } clone_override: -| TYPE ps=cltyparams x=qident mode=opclmode t=loc(type_exp) - { (x, PTHO_Type (`BySyntax (ps, t), mode)) } +| TYPE idx=loption(idxvars_decl) ps=cltyparams x=qident mode=opclmode t=loc(type_exp) + { (x, PTHO_Type (`BySyntax (idx, ps, t), mode)) } | OP x=qoident tyvars=bracket(tident*)? p=ptybinding1* sty=ioption(prefix(COLON, loc(type_exp))) diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 18f6242e1a..d7db71f2ce 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -1221,7 +1221,8 @@ and 'a genoverride = [ | `BySyntax of 'a ] -and ty_override_def = psymbol list * pty +(* (idxvars, tyvars, body) — both binder lists may be empty. *) +and ty_override_def = psymbol list * psymbol list * pty and op_override_def = { opov_tyvars : psymbol list option; diff --git a/src/ecScope.ml b/src/ecScope.ml index 292659bcf8..a336ba8327 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2561,7 +2561,7 @@ module Ty = struct (* ------------------------------------------------------------------ *) let symbols_of_tc (_env : EcEnv.env) ty (tcp, tc) = - let subst = EcSubst.add_tydef EcSubst.empty tcp ([], ty) in + let subst = EcSubst.add_tydef EcSubst.empty tcp ([], [], ty) in List.map (fun (x, opty) -> (EcIdent.name x, (true, EcSubst.subst_ty subst opty))) tc.tc_ops diff --git a/src/ecSection.ml b/src/ecSection.ml index 2bce619787..f2788f6684 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -652,7 +652,7 @@ let add_declared_ty to_gen path tydecl = { to_gen with tg_params = { to_gen.tg_params with tyvars = to_gen.tg_params.tyvars @ [id] }; - tg_subst = EcSubst.add_tydef to_gen.tg_subst path ([], tvar id); + tg_subst = EcSubst.add_tydef to_gen.tg_subst path ([], [], tvar id); } let add_declared_op to_gen path opdecl = @@ -809,7 +809,8 @@ let generalize_tydecl to_gen prefix (name, tydecl) = tyvars = extra @ tydecl.tyd_params.tyvars; } in let args = List.map tvar tyd_params.tyvars in let params = tydecl.tyd_params.tyvars in - let tosubst = params, tconstr ~tyargs:args path in + let idxparams = tydecl.tyd_params.idxvars in + let tosubst = (idxparams, params, tconstr ~tyargs:args path) in let tg_subst, tyd_type = match tydecl.tyd_type with | Concrete _ | Abstract -> diff --git a/src/ecSubst.ml b/src/ecSubst.ml index b85f888879..2470c62866 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -27,10 +27,16 @@ type subst = { sb_module : EcPath.mpath Mid.t; sb_path : EcPath.path Mp.t; sb_tyvar : ty Mid.t; + (* Index-variable substitution. Populated during the + Tconstr-with-tydef case of [subst_ty] to bind the source type's + idxvars to the call-site index arguments. Consulted by + [subst_tindex] before the [sb_flocal] formula-locals fallback. *) + sb_idxvar : tindex Mid.t; sb_elocal : expr Mid.t; sb_flocal : EcCoreFol.form Mid.t; sb_fmem : EcIdent.t Mid.t; - sb_tydef : (EcIdent.t list * ty) Mp.t; + (* (idxvars, tyvars, body) — both binder lists may be empty. *) + sb_tydef : (EcIdent.t list * EcIdent.t list * ty) Mp.t; sb_def : (EcIdent.t list * [`Op of expr | `Pred of form]) Mp.t; sb_moddef : EcPath.mpath Mp.t; (* Only top-level modules *) } @@ -40,6 +46,7 @@ let empty : subst = { sb_module = Mid.empty; sb_path = Mp.empty; sb_tyvar = Mid.empty; + sb_idxvar = Mid.empty; sb_elocal = Mid.empty; sb_flocal = Mid.empty; sb_fmem = Mid.empty; @@ -52,6 +59,7 @@ let is_empty s = Mid.is_empty s.sb_module && Mp.is_empty s.sb_path && Mid.is_empty s.sb_tyvar + && Mid.is_empty s.sb_idxvar && Mid.is_empty s.sb_elocal && Mid.is_empty s.sb_flocal && Mid.is_empty s.sb_fmem @@ -153,6 +161,11 @@ let add_tyvars (s : subst) (xs : EcIdent.t list) (tys : ty list) = let rec subst_tindex (s : subst) (ti : tindex) : tindex = match ti with | TIVar id -> begin + (* sb_idxvar (cloning instantiation) wins over the formula + locals fallback. *) + match Mid.find_opt id s.sb_idxvar with + | Some ti' -> ti' + | None -> match Mid.find_opt id s.sb_flocal with | None -> ti | Some f -> @@ -198,8 +211,14 @@ let rec subst_ty (s : subst) (ty : ty) = | None -> tconstr_r (subst_path s p) ta - | Some (args, body) -> + | Some (idxs, args, body) -> + (* Bind the source type's idxvars/tyvars to the call-site + index/type arguments, then substitute through the body. *) let s = List.fold_left2 add_tyvar empty args ta.types in + let s = + List.fold_left2 + (fun s id ti -> { s with sb_idxvar = Mid.add id ti s.sb_idxvar }) + s idxs ta.indices in subst_ty s body end @@ -296,9 +315,9 @@ let add_path (s : subst) ~src ~dst = assert (Mp.find_opt src s.sb_path = None); { s with sb_path = Mp.add src dst s.sb_path } -let add_tydef (s : subst) p (ids, ty) = +let add_tydef (s : subst) p ((idxs, ids, ty) : EcIdent.t list * EcIdent.t list * ty) = assert (Mp.find_opt p s.sb_tydef = None); - { s with sb_tydef = Mp.add p (ids, ty) s.sb_tydef } + { s with sb_tydef = Mp.add p (idxs, ids, ty) s.sb_tydef } let add_opdef (s : subst) p (ids, f) = assert (Mp.find_opt p s.sb_def = None); diff --git a/src/ecSubst.mli b/src/ecSubst.mli index e392468354..16cac2f47e 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -25,7 +25,7 @@ val is_empty : subst -> bool (* -------------------------------------------------------------------- *) val add_module : subst -> EcIdent.t -> mpath -> subst val add_path : subst -> src:path -> dst:path -> subst -val add_tydef : subst -> path -> (EcIdent.t list * ty) -> subst +val add_tydef : subst -> path -> (EcIdent.t list * EcIdent.t list * ty) -> subst val add_opdef : subst -> path -> (EcIdent.t list * expr) -> subst val add_pddef : subst -> path -> (EcIdent.t list * form) -> subst val add_moddef : subst -> src:path -> dst:mpath -> subst (* Only concrete modules *) diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index dfc895d1c4..a7ea35cc92 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -40,6 +40,7 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IdxArgMism of ovkind * qsymbol (* Cloning of indexed declarations is not yet supported (Phase 3 landed the binders but not the index-instantiation surface). *) | CE_IndexedNotYetSupported of ovkind * qsymbol @@ -267,10 +268,13 @@ end = struct (* ------------------------------------------------------------------ *) let ty_ovrd oc ((proofs, evc) : state) name (tyd : ty_override) = - let ntyargs = + let nidxargs, ntyargs = match fst tyd with - | `BySyntax (tyargs, _) -> List.length tyargs - | `ByPath p -> List.length (EcEnv.Ty.by_path p oc.oc_env).tyd_params.tyvars in + | `BySyntax (idxargs, tyargs, _) -> + (List.length idxargs, List.length tyargs) + | `ByPath p -> + let p = (EcEnv.Ty.by_path p oc.oc_env).tyd_params in + (List.length p.idxvars, List.length p.tyvars) in let { pl_loc = lc; pl_desc = ((nm, x) as name) } = name in @@ -279,8 +283,8 @@ end = struct | None -> clone_error oc.oc_env (CE_UnkOverride (OVK_Type, name)); | Some refty -> - if refty.tyd_params.idxvars <> [] then - clone_error oc.oc_env (CE_IndexedNotYetSupported (OVK_Type, name)); + if List.length refty.tyd_params.idxvars <> nidxargs then + clone_error oc.oc_env (CE_IdxArgMism (OVK_Type, name)); if List.length refty.tyd_params.tyvars <> ntyargs then clone_error oc.oc_env (CE_TypeArgMism (OVK_Type, name)) in diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli index e632cc051a..5716c538d4 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -34,6 +34,7 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IdxArgMism of ovkind * qsymbol | CE_IndexedNotYetSupported of ovkind * qsymbol exception CloneError of EcEnv.env * clone_error diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index fe35282d6f..f6af3ce07d 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -422,11 +422,11 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | Some { pl_desc = (tydov, mode) } -> begin let newtyd, body = match tydov with - | `BySyntax (nargs, ntyd) -> - let nargs = List.map - (fun x -> (EcIdent.create (unloc x))) - nargs in - let nargs_p = { idxvars = []; tyvars = nargs } in + | `BySyntax (nidxs, nargs, ntyd) -> + let mk1 x = EcIdent.create (unloc x) in + let idxvars = List.map mk1 nidxs in + let tyvars = List.map mk1 nargs in + let nargs_p = { idxvars; tyvars } in let ue = EcUnify.UniEnv.create (Some nargs_p) in let ntyd = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in let decl = @@ -467,7 +467,9 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `Inline _ -> let subst = EcSubst.add_tydef - subst (xpath ove x) (newtyd.tyd_params.tyvars, body) in + subst (xpath ove x) + (newtyd.tyd_params.idxvars, + newtyd.tyd_params.tyvars, body) in let subst = (* FIXME: HACK *) diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 47df332176..a50a8f9cba 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -765,6 +765,10 @@ end = struct msg "type argument mismatch for %s `%s'" (string_of_ovkind kd) (string_of_qsymbol x) + | CE_IdxArgMism (kd, x) -> + msg "index argument mismatch for %s `%s'" + (string_of_ovkind kd) (string_of_qsymbol x) + | CE_IndexedNotYetSupported (kd, x) -> msg "cloning of indexed %s `%s' is not yet supported" (string_of_ovkind kd) (string_of_qsymbol x) diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 20c82470be..9b8a185814 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -52,3 +52,25 @@ op test1 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) op test2 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) : 'a vec<:n+(1+m)> = concat (cons x ys) zs. + +(* Phase 4 — cloning with index instantiation. + `clone with type [k] 'a vec = body` substitutes every occurrence of + the indexed type, binding the source's idxvars to the call-site + index expressions when the body references them. *) +type [k] 'a coll. + +theory ClonedT. + type [n] 'a target. +end ClonedT. + +(* Drop the index, use a non-indexed type. *) +clone ClonedT as Erased with + type [k] 'a target = int. + +(* Propagate the index through to another indexed type. *) +clone ClonedT as Forwarded with + type [k] 'a target = 'a coll<:k>. + +(* Use a polynomial of the binder. *) +clone ClonedT as Bumped with + type [k] 'a target = 'a coll<:k+1>. From 0e6382232da9b426a3bba5136938becb247889c7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 16:55:39 +0200 Subject: [PATCH 09/40] =?UTF-8?q?indexed-types:=20phase=205=20=E2=80=94=20?= =?UTF-8?q?clean=20SMT=20gating=20for=20indexed=20types?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The two assert (List.is_empty *.indices) panics in ecSmt.ml become raise CanNotTranslate, and check / execute_task catch the exception to skip the goal cleanly. The user now sees a warning ("SMT: skipped goal containing constructs not yet exported to Why3 (e.g. indexed types)") followed by "cannot prove goal", instead of an anomaly crash. Translating indexed types to Why3 stays out of scope per the original Phase-0 punt. --- memory.md | 30 ++++++++++++++++++++++++++---- src/ecSmt.ml | 45 ++++++++++++++++++++++++++++++++++++++------- 2 files changed, 64 insertions(+), 11 deletions(-) diff --git a/memory.md b/memory.md index fc2399760c..e9dada2e3c 100644 --- a/memory.md +++ b/memory.md @@ -416,10 +416,32 @@ lists. (`f<:idx, ty>`) yet; tests that need index-passing at the call site rely on inference. A Phase-6 polish could add this. -### Phase 5 — SMT gating -Replace the `assert (List.is_empty tys.indices)` calls in -[src/ecSmt.ml](src/ecSmt.ml) with a clean "indexed types not yet -supported by SMT" error. +### Phase 5 — SMT gating (DONE) + +Replaced the two `assert (List.is_empty *.indices)` panics in +[src/ecSmt.ml](src/ecSmt.ml) (`trans_ty` for `Tconstr`, +`trans_app` for `Fop`) with `raise CanNotTranslate`. Hoisted the +`CanNotTranslate` exception declaration above `trans_ty` so both +call sites are in scope. Wrapped `check`'s `init` and the inner +`make_task` call in `try/with CanNotTranslate` handlers — the user +now sees a `SMT: skipped goal containing constructs not yet +exported to Why3 (e.g. indexed types)` warning followed by +`cannot prove goal`, rather than an anomaly crash. + +Verified: `lemma … (x y : 'a vec<:1>) : x = y \/ x <> y by smt()` +fails cleanly. + +Out of scope (per the original Phase-0 punt): actually translating +indexed types to Why3 — would need monomorphisation per concrete +index used in the goal, or a polymorphic Why3 export taking int +arguments. + +Other vestigial `assert (List.is_empty *.indices)` panics survive +in [src/ecReduction.ml:796](src/ecReduction.ml#L796), +[src/ecInductive.ml:161](src/ecInductive.ml#L161), +[src/ecInductive.ml:181](src/ecInductive.ml#L181), +[src/ecMatching.ml:685](src/ecMatching.ml#L685). These are not on +the SMT path — they belong in the Phase-6 polish pass. ### Phase 6 — Polish 1. Pretty-printer for indices in `EcPrinting` (canonical form). diff --git a/src/ecSmt.ml b/src/ecSmt.ml index c7220c51e4..e2637d739e 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -364,6 +364,12 @@ let mk_tglob genv m = Hid.add genv.te_absmod m { w3am_ty = ty }; ty +(* -------------------------------------------------------------------- *) +(* Raised when a fragment of an EasyCrypt formula or type cannot be + represented in the Why3 task. Caught by the SMT-call orchestration + to skip the goal cleanly rather than crash. *) +exception CanNotTranslate + (* -------------------------------------------------------------------- *) let rec trans_ty ((genv, lenv) as env) ty = match ty.ty_node with @@ -375,8 +381,11 @@ let rec trans_ty ((genv, lenv) as env) ty = | Ttuple ts-> wty_tuple genv (trans_tys env ts) | Tconstr (p, tys) -> - (* Phase 0: indices not yet supported by SMT *) - assert (List.is_empty tys.indices); + (* Indexed types are not yet exported to Why3 — bail cleanly so + the SMT orchestration falls back to "cannot dispatch this + goal" rather than crashing on an [assert]. *) + if not (List.is_empty tys.indices) then + raise CanNotTranslate; let id = trans_pty genv p in WTy.ty_app id (trans_tys env tys.types) @@ -473,7 +482,6 @@ let trans_memtype ((genv, _) as env) mt = wty_tuple genv [ty; ty_mem] (* -------------------------------------------------------------------- *) -exception CanNotTranslate let trans_binding genv lenv (x, xty) = let lenv, wty = match xty with @@ -713,8 +721,11 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = trans_fun env bds body args | Fop (p, ts) -> - (* Phase 0: indices not yet supported by SMT *) - assert (List.is_empty ts.indices); + (* See note on Tconstr in [trans_ty] — indexed-op signatures + carry indices through their type arguments, which we cannot + yet translate. *) + if not (List.is_empty ts.indices) then + raise CanNotTranslate; let wop = trans_op genv p in let tys = List.map (trans_ty (genv,lenv)) ts.types in apply_wop genv wop tys args @@ -1702,7 +1713,19 @@ let check ?notify (pi : P.prover_infos) (hyps : LDecl.hyps) (concl : form) = "%a@." Why3.Pretty.print_task task) (fun () -> close_out stream) in - let env,hyps,tenv,decl = init hyps concl in + (* If the goal contains anything we cannot translate to Why3 + (currently: indexed types), bail out with [false] — the user + will see the standard "no provers" failure rather than a crash. *) + match + try Some (init hyps concl) + with CanNotTranslate -> + notify |> oiter (fun notify -> notify `Warning (lazy + "SMT: skipped goal containing constructs not yet exported \ + to Why3 (e.g. indexed types)")); + None + with + | None -> false + | Some (env,hyps,tenv,decl) -> let execute_task toadd = if pi.P.pr_selected then begin @@ -1716,7 +1739,15 @@ let check ?notify (pi : P.prover_infos) (hyps : LDecl.hyps) (concl : form) = (lazy (Buffer.contents buffer))) end; - let task = make_task tenv toadd decl in + (* An added hypothesis may itself mention an indexed type — skip + it cleanly the same way the goal-level path does. *) + let task = + try Some (make_task tenv toadd decl) + with CanNotTranslate -> None + in + match task with + | None -> Some false + | Some task -> let tkid = Counter.next cnt in let dumpin_opt = From 1c06b462fe62962bdc81bfaf039523c6937734e7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 17:02:49 +0200 Subject: [PATCH 10/40] =?UTF-8?q?indexed-types:=20phase=206=20=E2=80=94=20?= =?UTF-8?q?pretty-printer=20+=20cleanup?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Errors and transcripts now print 'a vec<:n> instead of 'a vec; pp_tindex handles variables, univars (?#N), constants, and the polynomial *- and +-forms with standard precedence. Two vestigial Phase-0 asserts become clean failures: - ecReduction: indexed-op heads in a user rewrite rule raise NotReducible instead of crashing (they just don't match). - ecMatching: Fop vs Fop in pattern matching uses tindex_equal plus a length check, failing cleanly rather than asserting. The two asserts in ecInductive's positivity check are intentional "should never happen" guards — Phase-3 Slice-A already refuses indexed binders on datatype/record, so they aren't reachable. Closes the roadmap in memory.md. Remaining gaps are documented (op call-site index instantiation syntax, SMT translation of indexed types, indexed datatypes) but out of scope. --- memory.md | 49 +++++++++++++++++++++++++++++++++++++----- src/ecMatching.ml | 6 ++++-- src/ecPrinting.ml | 53 +++++++++++++++++++++++++++++++++++++++------- src/ecReduction.ml | 4 +++- 4 files changed, 96 insertions(+), 16 deletions(-) diff --git a/memory.md b/memory.md index e9dada2e3c..b7b2019dde 100644 --- a/memory.md +++ b/memory.md @@ -443,11 +443,50 @@ in [src/ecReduction.ml:796](src/ecReduction.ml#L796), [src/ecMatching.ml:685](src/ecMatching.ml#L685). These are not on the SMT path — they belong in the Phase-6 polish pass. -### Phase 6 — Polish -1. Pretty-printer for indices in `EcPrinting` (canonical form). -2. Reduction error messages should print both normalised indices on - mismatch. -3. `CHANGELOG`. +### Phase 6 — Polish (DONE) + +#### What changed + +- [src/ecPrinting.ml](src/ecPrinting.ml) — new `pp_tindex_atom` / + `pp_tindex_prod` / `pp_tindex_sum` / `pp_tindex` with + `*`-tighter-than-`+` precedence. `pp_type_r`'s `Tconstr` branch + now emits a `<:e, ...>` suffix when the type application carries + indices. Errors and transcripts that formerly printed `'a vec` + for `vec<:n>` (dropping the index entirely, a Phase-0 placeholder) + now show `'a vec<:n>`. +- [src/ecReduction.ml](src/ecReduction.ml) — the Phase-0 + `assert (List.is_empty ta.indices)` in user-rewrite-rule matching + (around line 796) becomes `if not empty then raise NotReducible`. + Indexed-op heads in a rewrite rule no longer crash; they just + fail to match. +- [src/ecMatching.ml](src/ecMatching.ml) — the Phase-0 assert in + `Fop` pattern matching (line 685) becomes a proper length + + polynomial-equality check, with a clean `failure ()` on mismatch. + +#### Left as-is (deliberate) + +- The two asserts in + [src/ecInductive.ml:161](src/ecInductive.ml#L161) and + [src/ecInductive.ml:181](src/ecInductive.ml#L181) — they guard a + recursive-positivity case where the type being defined references + itself. Since Phase-3 Slice-A refuses indexed binders on + datatype/record declarations, the self-reference cannot carry + indices; the asserts are "should never happen" internal-invariant + guards. +- `IndexMismatch` error messages still use `EcTypes.dump_tindex` + (the internal serialisation). Swapping to `EcPrinting.pp_tindex` + would require ecUserMessages to gain a `PPEnv` dependency, which + is out of proportion for an edge-case message. Acceptable for now. +- `CHANGELOG` update: out of scope, that's release admin. + +#### Known remaining gaps (documented but not scheduled) + +- Explicit index-instantiation syntax at op call sites + (`f<:idx, ty>`). Tests that need this rely on inference. +- Reaching into a cloned theory's ops whose signature was touched + by an indexed-type override (Phase-4 note). +- Indexed types in SMT translation (Phase-5 punt). +- Indexed datatypes / records (Phase-3 Slice-A refusal). ## Critical path & open risks diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 76fe087247..5e849fb163 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -681,8 +681,10 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | Fop (op1, tys1), Fop (op2, tys2) -> begin if not (EcPath.p_equal op1 op2) then failure (); - (* Phase 0: indices not yet supported here *) - assert (List.is_empty tys1.indices && List.is_empty tys2.indices); + if List.compare_lengths tys1.indices tys2.indices <> 0 then + failure (); + if not (List.all2 tindex_equal tys1.indices tys2.indices) then + failure (); try List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index a6c91d6ecc..48307b3ebd 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -774,6 +774,37 @@ let is_binop name = let is_pstop name = String.length name > 0 && name.[0] = '%' +(* -------------------------------------------------------------------- *) +(* Pretty-print a tindex polynomial. Precedence: `*` binds tighter + than `+`. Atoms (variables, constants, parenthesised expressions) + never need parentheses; sums and products inherit their level. *) +let rec pp_tindex_atom (ppe : PPEnv.t) fmt (ti : tindex) = + match ti with + | TIVar id -> Format.fprintf fmt "%s" (PPEnv.local_symb ppe id) + | TIUnivar u -> Format.fprintf fmt "?#%d" u + | TIConst n -> Format.fprintf fmt "%s" (EcBigInt.to_string n) + | TIAdd _ | TIMul _ -> + Format.fprintf fmt "(%a)" (pp_tindex_sum ppe) ti + +and pp_tindex_prod (ppe : PPEnv.t) fmt (ti : tindex) = + match ti with + | TIMul (l, r) -> + Format.fprintf fmt "%a * %a" + (pp_tindex_prod ppe) l + (pp_tindex_atom ppe) r + | _ -> pp_tindex_atom ppe fmt ti + +and pp_tindex_sum (ppe : PPEnv.t) fmt (ti : tindex) = + match ti with + | TIAdd (l, r) -> + Format.fprintf fmt "%a + %a" + (pp_tindex_sum ppe) l + (pp_tindex_prod ppe) r + | _ -> pp_tindex_prod ppe fmt ti + +let pp_tindex (ppe : PPEnv.t) fmt (ti : tindex) = + pp_tindex_sum ppe fmt ti + (* -------------------------------------------------------------------- *) let rec pp_type_r (ppe : PPEnv.t) @@ -794,23 +825,29 @@ let rec pp_type_r maybe_paren outer t_prio_tpl pp fmt tys | Tconstr (name, tyargs) -> begin - let pp fmt (name, tyargs) = - match tyargs with + let pp_idx fmt = + match tyargs.indices with + | [] -> () + | is -> + Format.fprintf fmt "<:%a>" + (pp_list ",@ " (pp_tindex ppe)) is + in + let pp fmt (name, tys) = + match tys with | [] -> - pp_tyname ppe fmt name + Format.fprintf fmt "%a%t" (pp_tyname ppe) name pp_idx | [x] -> - Format.fprintf fmt "%a %a" + Format.fprintf fmt "%a %a%t" (pp_type_r ppe (t_prio_name, `Left)) x - (pp_tyname ppe) name + (pp_tyname ppe) name pp_idx | xs -> let subpp = pp_type_r ppe (min_op_prec, `NonAssoc) in - Format.fprintf fmt "%a %a" + Format.fprintf fmt "%a %a%t" (pp_paren (pp_list ",@ " subpp)) xs - (pp_tyname ppe) name + (pp_tyname ppe) name pp_idx in - (* Phase 0: indices not yet pretty-printed *) maybe_paren outer t_prio_name pp fmt (name, tyargs.types) end diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 690606b3ac..abd9145508 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -793,7 +793,9 @@ let reduce_user_gen simplify ri env hyps f = | ({ f_node = Fop (p, ta) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> - assert (List.is_empty ta.indices); + (* User rewrite-rule patterns don't yet carry index args. + Rather than crash, treat indexed-op heads as non-matching. *) + if not (List.is_empty ta.indices) then raise NotReducible; let tys' = List.map (Tvar.subst tvi) tys' in From 53ffe5671be39a252a72f8634dfc9b90c87460d5 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 20 Apr 2026 21:48:58 +0200 Subject: [PATCH 11/40] indexed-types: gap E + D-investigation fix MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit E — extend index-binder support to abbreviations and notations. Both rules now accept mixed_tyvars_decl (the bracket binder list that splits into idxvars and tyvars). pabbrev / pnotation gain *_idx fields; ecHiNotations threads them via the new ~idxparams parameter on transtyvars. abbrev my_alias [n 'a] : 'a vec<:n+1> = ... . notation %"..."% [n 'a] (...) = ... . D — investigation of the Phase-4 "T2.make_vec unknown" report showed it was a misuse of the alias `=` operator instead of the inline `<-` operator (alias creates a new name; inline propagates the body). Both modes work correctly. While tracing, fresh_tparams was discovered to freshen tyvars but not idxvars — fix this so op_tparams alpha-renaming includes both. --- src/ecHiNotations.ml | 4 ++-- src/ecParser.mly | 14 +++++++++----- src/ecParsetree.ml | 2 ++ src/ecSubst.ml | 11 +++++++++-- 4 files changed, 22 insertions(+), 9 deletions(-) diff --git a/src/ecHiNotations.ml b/src/ecHiNotations.ml index ea8959d97c..62461d6fc0 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -30,7 +30,7 @@ let trans_abbrev_opts (opts : abrvopts) = (* -------------------------------------------------------------------- *) let trans_notation_r (env : env) (nt : pnotation located) = let nt = nt.pl_desc and gloc = nt.pl_loc in - let ue = TT.transtyvars env (gloc, nt.nt_tv) in + let ue = TT.transtyvars ~idxparams:nt.nt_idx env (gloc, nt.nt_tv) in (* Translate bound idents and their types *) let bd = List.mapi (fun i (x, pty) -> @@ -75,7 +75,7 @@ let trans_notation (env : EcEnv.env) (nt : pnotation located) = (* -------------------------------------------------------------------- *) let trans_abbrev_r (env : env) (at : pabbrev located) = let at = at.pl_desc and gloc = at.pl_loc in - let ue = TT.transtyvars env (gloc, at.ab_tv) in + let ue = TT.transtyvars ~idxparams:at.ab_idx env (gloc, at.ab_tv) in let benv, xs = TT.trans_binding env ue at.ab_args in let codom = TT.transty TT.tp_relax env ue (fst at.ab_def) in let body = TT.transexpcast benv `InOp ue codom (snd at.ab_def) in diff --git a/src/ecParser.mly b/src/ecParser.mly index eea73488c9..453c1539f9 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1974,10 +1974,12 @@ nt_bindings: { bd } notation: -| locality=loc(locality) NOTATION x=loc(NOP) tv=tyvars_decl? bd=nt_bindings? +| locality=loc(locality) NOTATION x=loc(NOP) tvs=mixed_tyvars_decl? bd=nt_bindings? args=nt_arg1* codom=prefix(COLON, loc(type_exp))? EQ body=expr - { { nt_name = x; - nt_tv = tv; + { let (idxvars, tyvars) = odfl ([], []) tvs in + { nt_name = x; + nt_idx = idxvars; + nt_tv = tvs |> omap (fun _ -> tyvars); nt_bd = odfl [] bd; nt_args = args; nt_codom = ofdfl (fun () -> mk_loc (loc body) PTunivar) codom; @@ -1997,13 +1999,15 @@ abrvopts: | opts=bracket(abrvopt+) { opts } abbreviation: -| locality=loc(locality) ABBREV opts=abrvopts? x=oident tyvars=tyvars_decl? +| locality=loc(locality) ABBREV opts=abrvopts? x=oident tvs=mixed_tyvars_decl? args=ptybindings_decl? sty=prefix(COLON, loc(type_exp))? EQ b=expr { let sty = sty |> ofdfl (fun () -> mk_loc (loc b) PTunivar) in + let (idxvars, tyvars) = odfl ([], []) tvs in { ab_name = x; - ab_tv = tyvars; + ab_idx = idxvars; + ab_tv = tvs |> omap (fun _ -> tyvars); ab_args = odfl [] args; ab_def = (sty, b); ab_opts = odfl [] opts; diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index d7db71f2ce..2c5674202f 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -473,6 +473,7 @@ type ppredicate = { (* -------------------------------------------------------------------- *) type pnotation = { nt_name : psymbol; + nt_idx : psymbol list; nt_tv : ptyvardecls option; nt_bd : (psymbol * pty) list; nt_args : (psymbol * (psymbol list * pty option)) list; @@ -487,6 +488,7 @@ type abrvopts = (bool * abrvopt) list type pabbrev = { ab_name : psymbol; + ab_idx : psymbol list; ab_tv : ptyvardecls option; ab_args : ptybindings; ab_def : pty * pexpr; diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 2470c62866..4c52da5ac7 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -881,10 +881,17 @@ let fresh_tparam (s : subst) (x : EcIdent.t) = let s = add_tyvar s x (tvar newx) in (s, newx) +(* -------------------------------------------------------------------- *) +let fresh_idxparam (s : subst) (x : EcIdent.t) = + let newx = EcIdent.fresh x in + let s = { s with sb_idxvar = Mid.add x (TIVar newx) s.sb_idxvar } in + (s, newx) + (* -------------------------------------------------------------------- *) let fresh_tparams (s : subst) (tparams : ty_params) = - let s, tyvars = List.fold_left_map fresh_tparam s tparams.tyvars in - (s, { tparams with tyvars }) + let s, idxvars = List.fold_left_map fresh_idxparam s tparams.idxvars in + let s, tyvars = List.fold_left_map fresh_tparam s tparams.tyvars in + (s, { idxvars; tyvars }) (* -------------------------------------------------------------------- *) let subst_genty (s : subst) (tparams, ty) = From 8f40f5398c91bec0e36752c53c3a6f288615d55f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 08:12:58 +0200 Subject: [PATCH 12/40] =?UTF-8?q?indexed-types:=20gap=20A=20=E2=80=94=20ex?= =?UTF-8?q?plicit=20index=20instantiation=20at=20op=20call=20sites?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit op count [n 'a] : int. op test : int = count[:5]<:int>. New lexer token LBRACKETCOLON (matches `[:` glued). Grammar adds `f[:idx]`, `f[:idx]<:ty>`, alongside existing `f<:ty>`. Parsetree TVIunamed and ecUnify tvar_inst.TVIunamed are widened to (indices, types). Producers updated mechanically (PFrecord, PTHO_*, inductive constructors, scope's tycinstance loop, printer's op_symb resolution, transtvi). EcUnify.openidx now consumes user- supplied indices when given, falling back to fresh TIUnivars otherwise. select_op's filter validates either side independently when non-empty. Useful when an op's idxvar is unreachable by argument-type inference. Phase-3.5 inference still handles the common case where the index can be derived from an argument's type. The test file gets three new cases (size[:5] xs, count[:5]<:int>, inferred-only baseline). 91 declarations now compile. --- memory.md | 38 ++++++++++++++++++++++--- src/ecHiInductive.ml | 2 +- src/ecLexer.mll | 1 + src/ecParser.mly | 21 ++++++++++++-- src/ecParsetree.ml | 4 ++- src/ecPrinting.ml | 2 +- src/ecProofTyping.ml | 4 +-- src/ecScope.ml | 2 +- src/ecTyping.ml | 10 ++++--- src/ecUnify.ml | 64 +++++++++++++++++++++++++++++++----------- src/ecUnify.mli | 4 ++- tests/indexed-types.ec | 14 +++++++++ 12 files changed, 132 insertions(+), 34 deletions(-) diff --git a/memory.md b/memory.md index b7b2019dde..5bac0064bf 100644 --- a/memory.md +++ b/memory.md @@ -481,12 +481,42 @@ the SMT path — they belong in the Phase-6 polish pass. #### Known remaining gaps (documented but not scheduled) -- Explicit index-instantiation syntax at op call sites - (`f<:idx, ty>`). Tests that need this rely on inference. -- Reaching into a cloned theory's ops whose signature was touched - by an indexed-type override (Phase-4 note). - Indexed types in SMT translation (Phase-5 punt). - Indexed datatypes / records (Phase-3 Slice-A refusal). +- Polynomial unification beyond "naked TIUnivar = polynomial" + (e.g. `?u + 1 = n` requires subtraction inversion). + +### Post-Phase-6 — gaps E / D / A (DONE) + +- **E** — index binders on abbreviations and notations. + `tyvars_decl` was already shared with ops/preds/axioms via + Phase-3 Slice B; abbreviation and notation rules now use + `mixed_tyvars_decl` too. New `ab_idx` / `nt_idx` fields on + `pabbrev` / `pnotation`; `ecHiNotations` threads them via + `~idxparams` on `transtyvars`. +- **D** — investigation. The Phase-4 "T2.make_vec unknown after + clone-with-override" report turned out to be a misuse of the + alias `=` operator instead of the inline `<-` operator (alias + creates a new name that requires explicit qualification; inline + propagates the body and adopts the source signature). Both modes + work correctly. While tracing, `fresh_tparams` was found to + freshen tyvars but not idxvars — fixed so op_tparams alpha- + renaming covers both. +- **A** — explicit index instantiation at op call sites. New + lexer token `LBRACKETCOLON` (matches `[:` glued, no whitespace). + Grammar: `f[:n+1]` provides indices; `f<:int>` provides types + (existing); `f[:n+1]<:int>` does both, in that order. Parsetree + `TVIunamed` and ecUnify `tvar_inst.TVIunamed` both widened to + `(idx list * ty list)`; producers updated mechanically. + `EcUnify.openidx` now uses user-supplied indices when given, + falling back to fresh `TIUnivar`s otherwise. Filter logic in + `select_op` validates either side independently when non-empty. + Useful when the op has indices that aren't reachable by argument- + type inference (e.g. `op count [n 'a] : int` called as + `count[:5]<:int>`). + + Verified: 91 declarations in `tests/indexed-types.ec` compile, + including the new explicit-instantiation cases. ## Critical path & open risks diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 11a1e99c93..32b67f6e86 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -317,7 +317,7 @@ let trans_matchfix EcUnify.UniEnv.restore ~src:subue ~dst:ue; let ctorty = - let tvi = Some (EcUnify.TVIunamed tvi) in + let tvi = Some (EcUnify.TVIunamed ([], tvi)) in fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in let pty = EcUnify.UniEnv.fresh ue in diff --git a/src/ecLexer.mll b/src/ecLexer.mll index e5a5ced942..9cbc04067c 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -395,6 +395,7 @@ rule main = parse (* string symbols *) | ".." { [DOTDOT ] } | ".[" { [DLBRACKET] } + | "[:" { [LBRACKETCOLON] } | ".`" { [DOTTICK ] } | "{0,1}" { [RBOOL ] } diff --git a/src/ecParser.mly b/src/ecParser.mly index 453c1539f9..5a8373c327 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -437,6 +437,7 @@ %token DECLARE %token DELTA %token DLBRACKET +%token LBRACKETCOLON %token DO %token DONE %token DOT @@ -925,11 +926,27 @@ tyvar_byname1: | x=tident EQ ty=loc(type_exp) { (x, ty) } tyvar_annot: -| lt = plist1(loc(type_exp), COMMA) { TVIunamed lt } +| lt = plist1(loc(type_exp), COMMA) { TVIunamed ([], lt) } | lt = plist1(tyvar_byname1, COMMA) { TVInamed lt } +(* Explicit op-index instantiation, e.g. `f[:n+1]` or `f[:n,m]<:int>`. + The `[:` form is parsed as a single LBRACKETCOLON token by the + lexer to avoid clashes with list literals. *) +%inline idx_app: +| LBRACKETCOLON ix=plist1(pindex, COMMA) RBRACKET { ix } + %inline tvars_app: -| LTCOLON k=loc(tyvar_annot) GT { k } +| LTCOLON k=loc(tyvar_annot) GT + { k } +| ix=loc(idx_app) + { mk_loc ix.pl_loc (TVIunamed (ix.pl_desc, [])) } +| ix=idx_app LTCOLON k=loc(tyvar_annot) GT + { match k.pl_desc with + | TVIunamed ([], tys) -> + mk_loc k.pl_loc (TVIunamed (ix, tys)) + | TVIunamed (_, _) | TVInamed _ -> + parse_error k.pl_loc + (Some "cannot mix explicit indices with named-tyvar syntax") } (* -------------------------------------------------------------------- *) %inline sexpr: f=sform { mk_loc f.pl_loc (Expr f) } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 2c5674202f..4d544dde93 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -85,7 +85,9 @@ and pindex_r = and pindex = pindex_r located type ptyannot_r = - | TVIunamed of pty list + (* Explicit indices first, then explicit types. Either may be empty; + when both are empty, no instantiation was provided. *) + | TVIunamed of pindex list * pty list | TVInamed of (psymbol * pty) list and ptyannot = ptyannot_r located diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 48307b3ebd..a0806c4b16 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -233,7 +233,7 @@ module PPEnv = struct | `Expr -> fun _ op -> not (EcDecl.is_pred op) | `Form -> fun _ _ -> true in - let tvi = Some (EcUnify.TVIunamed typ) in + let tvi = Some (EcUnify.TVIunamed ([], typ)) in fun sm -> check_for_local sm; diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 48872f27b2..86b8d646ec 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -198,8 +198,8 @@ let pf_check_tvi (pe : proofenv) (typ : EcDecl.ty_params) (tvi : tvar_inst optio match tvi with | None -> () - | Some (EcUnify.TVIunamed tyargs) -> - if List.length tyargs <> List.length typ then + | Some (EcUnify.TVIunamed (_ix, tyargs)) -> + if tyargs <> [] && List.length tyargs <> List.length typ then tc_error pe "wrong number of type parameters (%d, expecting %d)" (List.length tyargs) (List.length typ) diff --git a/src/ecScope.ml b/src/ecScope.ml index a336ba8327..e9b31c464d 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2360,7 +2360,7 @@ module Ty = struct let tvi = List.map (TT.transty tp_tydecl env ue) tvi in let selected = EcUnify.select_op ~filter:(fun _ -> EcDecl.is_oper) - (Some (EcUnify.TVIunamed tvi)) env (unloc op) ue ([], None) + (Some (EcUnify.TVIunamed ([], tvi))) env (unloc op) ue ([], None) in let op = match selected with diff --git a/src/ecTyping.ml b/src/ecTyping.ml index ad7103cba4..bfc6fd909b 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1168,7 +1168,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let fty = snd (List.nth rec_ i) in let fty, _ = EcUnify.UniEnv.openty ue recty.tyd_params - (Some (EcUnify.TVIunamed rectvi)) fty + (Some (EcUnify.TVIunamed ([], rectvi))) fty in (try EcUnify.unify env ue pty fty with EcUnify.UnificationFailure _ -> assert false); @@ -1200,8 +1200,10 @@ let transpattern env ue (p : EcParsetree.plpattern) = (* -------------------------------------------------------------------- *) let transtvi env ue tvi = match tvi.pl_desc with - | TVIunamed lt -> - EcUnify.TVIunamed (List.map (transty tp_relax env ue) lt) + | TVIunamed (ix, lt) -> + EcUnify.TVIunamed + ( List.map (transtindex env ue) ix + , List.map (transty tp_relax env ue) lt ) | TVInamed lst -> let add locals (s, t) = @@ -1383,7 +1385,7 @@ let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = EcUnify.UniEnv.restore ~src:subue ~dst:ue; let ctorty = - let tvi = Some (EcUnify.TVIunamed tvi) in + let tvi = Some (EcUnify.TVIunamed ([], tvi)) in fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in let pty = EcUnify.UniEnv.fresh ue in diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 013b50daef..52791e136f 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -278,7 +278,9 @@ let subst_of_uf (uf : UF.t) = (* -------------------------------------------------------------------- *) type tvar_inst = -| TVIunamed of ty list +(* Explicit indices first, then explicit types. Either may be empty; + when both are empty, the slot is "no instantiation provided". *) +| TVIunamed of tindex list * ty list | TVInamed of (EcSymbols.symbol * ty) list type tvi = tvar_inst option @@ -380,10 +382,17 @@ module UniEnv = struct (fun s v -> Mid.add v (fresh ue) s) Mid.empty params - | Some (TVIunamed lt) -> - List.fold_left2 - (fun s v ty -> Mid.add v (fresh ~ty ue) s) - Mid.empty params lt + | Some (TVIunamed (_ix, lt)) -> + (* _ix is handled by [openidx] separately. Here we only map + tyvars to their explicit-or-fresh univars. *) + if lt = [] then + List.fold_left + (fun s v -> Mid.add v (fresh ue) s) + Mid.empty params + else + List.fold_left2 + (fun s v ty -> Mid.add v (fresh ~ty ue) s) + Mid.empty params lt | Some (TVInamed lt) -> let for1 s v = @@ -395,12 +404,32 @@ module UniEnv = struct in List.fold_left for1 Mid.empty params - (* Allocate a fresh index univar for each [idxvar] of [params], - producing the substitution map used by [openty_r]. *) - let openidx (ue : unienv) (params : ty_params) : tindex Mid.t = - List.fold_left - (fun s v -> Mid.add v (idx_fresh ue) s) - Mid.empty params.idxvars + (* Build the ident-to-tindex substitution that binds each idxvar + of [params]. When the caller provided explicit indices via + [TVIunamed (ix, _)], use those; otherwise allocate a fresh + TIUnivar so type-directed unification can assign it later. *) + let openidx (ue : unienv) (params : ty_params) (tvi : tvar_inst option) : tindex Mid.t = + let provided = + match tvi with + | Some (TVIunamed (ix, _)) when ix <> [] -> Some ix + | _ -> None + in + match provided with + | None -> + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + | Some ix -> + if List.compare_lengths ix params.idxvars <> 0 then + (* Fall back to inference rather than failing the select + loop: the caller may be trying this op among others. *) + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + else + List.fold_left2 + (fun s v ti -> Mid.add v ti s) + Mid.empty params.idxvars ix let subst_tv (subst : ty -> ty) (params : ty_params) = List.map (fun tv -> subst (tvar tv)) params.tyvars @@ -409,7 +438,7 @@ module UniEnv = struct let subst = f_subst_init ~tv:(opentvi ue params tvi) - ~idx:(openidx ue params) + ~idx:(openidx ue params tvi) () in (subst, subst_tv (ty_subst subst) params) @@ -491,11 +520,12 @@ let select_op match tvi with | None -> fun _ -> true - | Some (TVIunamed lt) -> - let len = List.length lt in - fun op -> - let tparams = op.D.op_tparams.tyvars in - List.length tparams = len + | Some (TVIunamed (ix, lt)) -> + (* Each non-empty user list must match the corresponding + arity of the candidate op. Empty means "infer this side". *) + fun op -> + (lt = [] || List.length lt = List.length op.D.op_tparams.tyvars) + && (ix = [] || List.length ix = List.length op.D.op_tparams.idxvars) | Some (TVInamed ls) -> fun op -> let tparams = List.map EcIdent.name op.D.op_tparams.tyvars in diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 582a71ed87..07fa80414c 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -12,7 +12,9 @@ exception UninstantiateUni type unienv type tvar_inst = -| TVIunamed of ty list +(* (explicit indices, explicit types). Either may be empty; the + typing layer falls back to inference for empty sides. *) +| TVIunamed of tindex list * ty list | TVInamed of (EcSymbols.symbol * ty) list type tvi = tvar_inst option diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 9b8a185814..a14f26077a 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -74,3 +74,17 @@ clone ClonedT as Forwarded with (* Use a polynomial of the binder. *) clone ClonedT as Bumped with type [k] 'a target = 'a coll<:k+1>. + +(* Gap A — explicit index instantiation at op call sites. + Syntax: f[:idx, ...] for indices, optionally followed by <:ty>. *) +op size [n 'a] (xs : 'a vec<:n>) : int. +op count [n 'a] : int. + +(* index inferred from xs's type *) +op a_test1 [n 'a] (xs : 'a vec<:n>) : int = size xs. + +(* index supplied explicitly *) +op a_test2 ['a] (xs : 'a vec<:5>) : int = size[:5] xs. + +(* both index and type explicit (no inference path for either) *) +op a_test3 : int = count[:5]<:int>. From 5b37d24e4f1d6bb7c2283d6e157a16b3420a95d9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 08:21:44 +0200 Subject: [PATCH 13/40] indexed-types: schedule remaining gaps B / C / F in memory.md Document the plan and effort estimates for the three documented-but- unscheduled gaps from the original A-F plan. Order: B (polynomial unification beyond naked TIUnivar) -> C (non-refining indexed datatypes/records) -> F (SMT translation via per-index monomorphize). --- memory.md | 44 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/memory.md b/memory.md index 5bac0064bf..1ca3b896cd 100644 --- a/memory.md +++ b/memory.md @@ -481,10 +481,48 @@ the SMT path — they belong in the Phase-6 polish pass. #### Known remaining gaps (documented but not scheduled) -- Indexed types in SMT translation (Phase-5 punt). -- Indexed datatypes / records (Phase-3 Slice-A refusal). +- Indexed types in SMT translation (Phase-5 punt) — **Gap F**. +- Indexed datatypes / records (Phase-3 Slice-A refusal) — **Gap C**. - Polynomial unification beyond "naked TIUnivar = polynomial" - (e.g. `?u + 1 = n` requires subtraction inversion). + (e.g. `?u + 1 = n` requires subtraction inversion) — **Gap B**. + +#### Plan for the remaining gaps (B → C → F) + +Original A–F plan: A, D, E landed in the post-Phase-6 batch. The +remaining three are scheduled as follows. + +- **Gap B — polynomial unification beyond naked TIUnivar.** Today + only `?u = poly` is solved. Extend `IxUni` work-list to handle + `?u + k = poly` and (more generally) any equation where exactly + one TIUnivar appears in `lhs - rhs` with coefficient ±1 — solve + `?u := ±(poly - other)` and fail if the result would be negative + or non-integer. Defer multi-univar Diophantine to a separate + constraint-set effort; not motivated by any current example. + Files: [src/ecUnify.ml](src/ecUnify.ml) (`unify_core` IxUni case). + Effort: ~0.5d. +- **Gap C — indexed datatypes / records (non-refining).** Lift the + Phase-3 Slice-A refusal in [src/ecHiInductive.ml](src/ecHiInductive.ml) + and the datatype/record paths in [src/ecScope.ml](src/ecScope.ml). + Constructor signatures may reference idxvars; pattern match does + *not* refine the index. Document explicitly that `vec<:0>` admits + a `VCons`-shaped value at the type level; matches OCaml/Haskell + parametric ADT semantics. Index-refining matches are a separate, + much bigger feature (true dependent typing) and out of scope. + Effort: ~1.5d (datatypes), records similar but smaller. +- **Gap F — SMT translation of indexed types.** Default strategy: + monomorphize per concrete index. `'a vec<:e>` with closed `e` + becomes a fresh memoized Why3 sort `vec_ 'a`; goals + with free index variables still hit `CanNotTranslate`. Add a + per-theory `[smt erase indices]` pragma as escape hatch for + theories where the user has manually discharged the index + discipline (drops indices, translates `'a vec<:e>` → `'a vec`). + Files: [src/ecSmt.ml](src/ecSmt.ml) (the two `CanNotTranslate` + raise sites, `trans_ty` Tconstr case, plus a small monomorphize + cache module). Effort: ~1d for the default; +0.5d for the pragma. + +Order: **B → C → F** (B is smallest and broadens unification; +C is the largest scope expansion but unblocks real ADT users; +F lands last to translate everything we now support). ### Post-Phase-6 — gaps E / D / A (DONE) From af4ea843abb742d538dd968b5fc7425195669463 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 08:27:46 +0200 Subject: [PATCH 14/40] =?UTF-8?q?indexed-types:=20gap=20B=20=E2=80=94=20so?= =?UTF-8?q?lve=20index=20equations=20with=20one=20TIUnivar?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Generalise the index unifier so [?u + k = poly] is solved when ?u appears with net coefficient ±1 and the residual stays non-negative. Previously only the naked-univar special case [?u = poly] worked, so e.g. [tail xs : 'a vec<:n>] (where tail expects [vec<:n+1>]) failed to unify against a caller-supplied [vec<:5>]. The new tindex_solve_for_univar walks the signed difference of the two canonical polynomials, accepting only equations where: - exactly one TIUnivar has non-zero net coefficient, - that coefficient is ±1, - every monomial mixing univars with other variables (or with a univar at degree > 1) cancels to zero on net, - the resulting value of ?u has non-negative coefficient on every remaining monomial and constant. The MVP scope deliberately excludes multi-univar Diophantine and cases like [?u + 1 = n] for free n (no symbolic guarantee n >= 1). --- src/ecAst.ml | 122 +++++++++++++++++++++++++++++++++++++++++ src/ecAst.mli | 6 ++ src/ecUnify.ml | 20 +++---- tests/indexed-types.ec | 18 ++++++ 4 files changed, 154 insertions(+), 12 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index ae9413d091..1f99011be9 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -1228,6 +1228,128 @@ let tindex_occurs_univar (u : EcUid.uid) (t : tindex) : bool = | TIAdd (l, r) | TIMul (l, r) -> walk l || walk r in walk t +(* Reconstruct a [tindex] AST from a canonical polynomial. The + canonical form's invariants (non-negative coefficients and constant) + are required; behaviour is undefined for signed inputs. The + resulting tree canonicalises back to [c] up to monomial ordering. *) +let tindex_of_canonical (c : tindex_canonical) : tindex = + let var_to_tindex = function + | TVVar id -> TIVar id + | TVUni u -> TIUnivar u + in + let pow v e = + let base = var_to_tindex v in + let rec go k = if k <= 1 then base else TIMul (base, go (k - 1)) in + go e + in + let mono_to_tindex (m : tindex_mono) (coef : EcBigInt.zint) : tindex = + let factors = List.map (fun (v, e) -> pow v e) m in + let body = + match factors with + | [] -> TIConst EcBigInt.one + | f :: r -> List.fold_left (fun acc f -> TIMul (acc, f)) f r + in + if EcBigInt.equal coef EcBigInt.one then body + else TIMul (TIConst coef, body) + in + let mons = List.map (fun (m, c) -> mono_to_tindex m c) c.cn_mons in + match mons with + | [] -> TIConst c.cn_konst + | first :: rest -> + let sum = List.fold_left (fun acc m -> TIAdd (acc, m)) first rest in + if EcBigInt.equal c.cn_konst EcBigInt.zero then sum + else TIAdd (TIConst c.cn_konst, sum) + +(* Try to solve [lhs = rhs] for a single TIUnivar. Succeeds when, in + the difference [lhs - rhs] computed as a signed polynomial, exactly + one TIUnivar [?u] has non-zero net coefficient, that coefficient + is +1 or -1, every monomial whose factors mix univars and other + variables (or contain a univar with degree > 1) has zero net + coefficient, and the resulting value of [?u] (= -(rest)/coef) has + non-negative coefficient on every remaining monomial and on the + constant term. Returns [Some (u, value)] in that case. + + The MVP scope deliberately excludes: + - multi-univar Diophantine equations (e.g. [?u + ?v = 5]); and + - cases where [?u]'s value would carry a negative coefficient + (e.g. [?u + 1 = n] when [n] is a free index variable, since we + have no symbolic guarantee that [n >= 1]). *) +let tindex_solve_for_univar (lhs : tindex) (rhs : tindex) + : (EcUid.uid * tindex) option += + let cl = tindex_canonicalize lhs in + let cr = tindex_canonicalize rhs in + + (* Walk the two sorted (mono, coef) lists in lock-step, yielding + triples (mono, lhs_coef, rhs_coef) for each monomial appearing + in either side. *) + let rec merge l r = + match l, r with + | [], _ -> List.map (fun (m, c) -> (m, EcBigInt.zero, c)) r + | _, [] -> List.map (fun (m, c) -> (m, c, EcBigInt.zero)) l + | (m1, c1) :: t1, (m2, c2) :: t2 -> + let cmp = mono_compare m1 m2 in + if cmp < 0 then (m1, c1, EcBigInt.zero) :: merge t1 r + else if cmp > 0 then (m2, EcBigInt.zero, c2) :: merge l t2 + else (m1, c1, c2) :: merge t1 t2 + in + let merged = merge cl.cn_mons cr.cn_mons in + + let exception Bail in + try + let univar = ref None in + let rev_purevar = ref [] in + List.iter (fun (m, lc, rc) -> + let net = EcBigInt.sub lc rc in + let net_zero = EcBigInt.equal net EcBigInt.zero in + let is_naked_uni = + match m with [(TVUni _, 1)] -> true | _ -> false in + let has_uni = + List.exists (fun (v, _) -> + match v with TVUni _ -> true | _ -> false) m + in + if is_naked_uni then begin + if not net_zero then begin + let u = match m with [(TVUni u, _)] -> u | _ -> assert false in + match !univar with + | None -> univar := Some (u, net) + | Some _ -> raise Bail + end + end else if has_uni then begin + if not net_zero then raise Bail + end else begin + if not net_zero then rev_purevar := (m, net) :: !rev_purevar + end + ) merged; + match !univar with + | None -> None + | Some (u, c) -> + if not (EcBigInt.equal (EcBigInt.abs c) EcBigInt.one) then None + else + let positive = EcBigInt.sign c > 0 in + let flip x = if positive then EcBigInt.neg x else x in + let net_konst = EcBigInt.sub cl.cn_konst cr.cn_konst in + let target_konst = flip net_konst in + if EcBigInt.sign target_konst < 0 then None + else + let target_mons = + List.rev_map (fun (m, net) -> + let target = flip net in + if EcBigInt.sign target < 0 then raise Bail; + (m, target) + ) !rev_purevar + in + let target_mons = + List.filter (fun (_, c) -> + not (EcBigInt.equal c EcBigInt.zero)) target_mons + in + let value = { + cn_konst = target_konst; + cn_mons = target_mons; + } in + Some (u, tindex_of_canonical value) + with Bail -> None + let canonical_hash (p : tindex_canonical) = let mono_hash (m : tindex_mono) = Why3.Hashcons.combine_list diff --git a/src/ecAst.mli b/src/ecAst.mli index 8f9e8ae00c..a368e5a2bb 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -429,6 +429,12 @@ val targs_fv : targs fv val tindex_naked_univar : tindex -> EcUid.uid option val tindex_occurs_univar : EcUid.uid -> tindex -> bool +(* Try to solve [lhs = rhs] for a single TIUnivar with coefficient ±1. + Returns [Some (u, value)] when solvable, [None] otherwise. See + [ecAst.ml] for the precise admissible scope. *) +val tindex_solve_for_univar : + tindex -> tindex -> (EcUid.uid * tindex) option + val ty_equal : ty equality val ty_hash : ty hash val ty_fv : ty fv diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 52791e136f..39cccac925 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -163,22 +163,18 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = (* Try to unify two indices. Resolves both sides through the current univar assignments, canonicalises, and compares. If equal, done. - Otherwise tries to assign a naked univar on either side to the - other side (with occurs check). Anything else fails — we do not - attempt full polynomial unification. *) + Otherwise hands off to [tindex_solve_for_univar], which solves any + equation reducible to "one TIUnivar with coefficient ±1, residual + non-negative". This subsumes the old "naked univar = polynomial" + special case and additionally handles e.g. [?u + 1 = n + 5]. *) let unify_ix t1 t2 = let r1 = resolve_tindex ue t1 in let r2 = resolve_tindex ue t2 in if tindex_equal r1 r2 then () else - let assign u t = - ue := { !ue with ue_iuf = Muid.add u t (!ue).ue_iuf } in - match tindex_naked_univar r1 with - | Some u when not (tindex_occurs_univar u r2) -> assign u r2 - | _ -> begin - match tindex_naked_univar r2 with - | Some u when not (tindex_occurs_univar u r1) -> assign u r1 - | _ -> failure () - end + match tindex_solve_for_univar r1 r2 with + | Some (u, v) when not (tindex_occurs_univar u v) -> + ue := { !ue with ue_iuf = Muid.add u v (!ue).ue_iuf } + | _ -> failure () in let doit () = diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index a14f26077a..9bb2557d1a 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -88,3 +88,21 @@ op a_test2 ['a] (xs : 'a vec<:5>) : int = size[:5] xs. (* both index and type explicit (no inference path for either) *) op a_test3 : int = count[:5]<:int>. + +(* Gap B — polynomial unification beyond naked TIUnivar. + The unifier can solve any equation where exactly one TIUnivar + appears with coefficient ±1 and the residual stays non-negative. *) + +op tail [n 'a] (xs : 'a vec<:n+1>) : 'a vec<:n>. + +(* Caller passes a vector of length 5; n must be inferred so that + n+1 = 5, i.e. n = 4. The naked-univar special case used to fail + here because ?u_n was not on its own. *) +op b_test1 ['a] (xs : 'a vec<:5>) : 'a vec<:4> = tail xs. + +(* Unification of [?u_n + 1] against [m + 5] forces ?u_n = m + 4. *) +op b_test2 [m 'a] (xs : 'a vec<:m+5>) : 'a vec<:m+4> = tail xs. + +(* Symmetric form: univar on the rhs of the equation. *) +op head [n 'a] (xs : 'a vec<:n+1>) : 'a. +op b_test3 ['a] (xs : 'a vec<:7>) : 'a = head xs. From c17422ae83b9e7fe8d84554e9b5a1774bbe63f37 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 08:48:28 +0200 Subject: [PATCH 15/40] =?UTF-8?q?indexed-types:=20gap=20C=20=E2=80=94=20no?= =?UTF-8?q?n-refining=20indexed=20datatypes=20/=20records?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Lift the Phase-3 Slice-A refusal that blocked index binders on datatype/record declarations. trans_datatype and trans_record now take an optional ~idxparams; ecScope's tydecl path threads it through the existing ~idxparams plumbing of transtyvars. Constructor and projector signature construction in ecEnv builds the result type via tconstr ~indices ~tyargs so e.g. INil is registered as 'a vec<:n>, not 'a vec. The positivity checker drops its assert (List.is_empty args.indices); indices play no role in positivity since the recursion is on the type and indices carry no embedded type information. Match elaboration in trans_branch (ecTyping) and the matchfix twin in ecHiInductive previously broke for 0-field constructors of indexed datatypes: opentys would allocate fresh index univars that appeared in no unified type, leaving them dangling at closed-check time. Fix: prepend a hand-built result type to the opened list so the freshly allocated univars are anchored to a type that participates in the subsequent unification against the scrutinee. Index refinement on match is deliberately out of scope: a vec<:0> scrutinee still admits an ICons-shaped pattern at the type level. Matches OCaml/Haskell parametric ADT semantics. Test file grows to 139 declarations covering constructor application, plain match, matchfix, indexed records, and field projection. Non-indexed datatypes/records continue to work unchanged. --- memory.md | 47 +++++++++++++++++++++++++++++++++++++++--- src/ecEnv.ml | 11 +++++++--- src/ecHiInductive.ml | 30 ++++++++++++++++++++------- src/ecHiInductive.mli | 6 ++++-- src/ecInductive.ml | 5 +++-- src/ecScope.ml | 18 +++++++--------- src/ecTyping.ml | 26 +++++++++++++++++++---- src/ecUnify.ml | 20 ++++++++++++++---- tests/indexed-types.ec | 30 +++++++++++++++++++++++++++ 9 files changed, 158 insertions(+), 35 deletions(-) diff --git a/memory.md b/memory.md index 1ca3b896cd..ce70cb3e9a 100644 --- a/memory.md +++ b/memory.md @@ -482,9 +482,6 @@ the SMT path — they belong in the Phase-6 polish pass. #### Known remaining gaps (documented but not scheduled) - Indexed types in SMT translation (Phase-5 punt) — **Gap F**. -- Indexed datatypes / records (Phase-3 Slice-A refusal) — **Gap C**. -- Polynomial unification beyond "naked TIUnivar = polynomial" - (e.g. `?u + 1 = n` requires subtraction inversion) — **Gap B**. #### Plan for the remaining gaps (B → C → F) @@ -524,6 +521,50 @@ Order: **B → C → F** (B is smallest and broadens unification; C is the largest scope expansion but unblocks real ADT users; F lands last to translate everything we now support). +### Post-Phase-6 — gaps B / C (DONE) + +- **B** — polynomial unification beyond naked TIUnivar. + New `EcAst.tindex_solve_for_univar` walks the signed difference + of two canonical polynomials and returns `Some (u, value)` when + exactly one TIUnivar has non-zero net coefficient ±1, every mixed + monomial cancels, and the residual is non-negative. Wired into + `unify_ix` *after* the original "naked univar = anything" fast + path (the fast path stays because it handles `?u = ?v` which the + new function refuses — two univars with non-zero net). MVP scope + excludes multi-univar Diophantine and `?u + 1 = n` (free n) where + the residual could be negative without symbolic guarantees. +- **C** — non-refining indexed datatypes and records. + `EcHiInductive.trans_datatype` and `trans_record` now take an + optional `~idxparams` argument; `EcScope.add_types` threads it + through both paths (the previous `no_indices_for` refusal is + removed). Constructor and projector signatures in `EcEnv` build + their result type as `tconstr ~indices ~tyargs path`, so + `INil : 'a vec<:n>` is registered correctly. The positivity + checker drops its `args.indices = []` asserts: indices play no + role in positivity since the recursion is on the type, and indices + carry no embedded type information. + + Match elaboration in `EcTyping.trans_branch` (and the matchfix + twin in `EcHiInductive`) was bug-prone for 0-field constructors: + `opentys` was being called with empty field list, allocating + fresh index univars that never appeared in any unified type and + so stayed dangling at `closed`-check time. Fix: prepend a hand- + built result type to the opened list, anchoring the freshly + allocated univars to a type that participates in the subsequent + unification against the scrutinee's index. + + Out of scope (deliberate): index refinement on match. Pattern + matching does not learn anything about the scrutinee's index from + the constructor that fired; e.g., a `vec<:0>` value still admits + an `ICons`-shaped pattern at the type level. Matches OCaml/Haskell + parametric ADT semantics. True dependent matching is a separate, + much larger feature and not on the roadmap. + + Verified: 6 new declarations in `tests/indexed-types.ec` covering + constructor application, plain match, matchfix, indexed records, + and field projection (139 declarations total). Non-indexed + datatypes and records continue to compile unchanged. + ### Post-Phase-6 — gaps E / D / A (DONE) - **E** — index binders on abbreviations and notations. diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 0c13608d96..8e8e5e32d9 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -789,8 +789,11 @@ module MC = struct let schelim = dtype.tydt_schelim in let schcase = dtype.tydt_schcase in let params = List.map tvar tyd.tyd_params.tyvars in + let indices = List.map (fun id -> TIVar id) tyd.tyd_params.idxvars in let for1 i (c, aty) = - let aty = EcTypes.toarrow aty (tconstr ~tyargs:params mypath) in + let aty = + EcTypes.toarrow aty + (tconstr ~indices ~tyargs:params mypath) in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let cop = mk_op ~opaque:optransparent (fst aty) (snd aty) @@ -830,10 +833,12 @@ module MC = struct | Record (scheme, fields) -> let params = List.map tvar tyd.tyd_params.tyvars in + let indices = List.map (fun id -> TIVar id) tyd.tyd_params.idxvars in + let self_ty = tconstr ~indices ~tyargs:params mypath in let nfields = List.length fields in let cfields = let for1 i (f, aty) = - let aty = EcTypes.tfun (tconstr ~tyargs:params mypath) aty in + let aty = EcTypes.tfun self_ty aty in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let fop = mk_op ~opaque:optransparent (fst aty) (snd aty) (Some (OP_Proj (mypath, i, nfields))) loca in @@ -854,7 +859,7 @@ module MC = struct let stname = Printf.sprintf "mk_%s" x in let stop = - let stty = toarrow (List.map snd fields) (tconstr ~tyargs:params mypath) in + let stty = toarrow (List.map snd fields) self_ty in let stty = EcSubst.freshen_type (tyd.tyd_params, stty) in mk_op ~opaque:optransparent (fst stty) (snd stty) (Some (OP_Record mypath)) loca in diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 32b67f6e86..993d8a3a7f 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -41,11 +41,13 @@ let dterror loc env e = raise (DtError (loc, env, e)) let fxerror loc env e = raise (FxError (loc, env, FXError e)) (* -------------------------------------------------------------------- *) -let trans_record (env : EcEnv.env) (name : ptydname) (rc : precord) = +let trans_record ?(idxparams : psymbol list = []) + (env : EcEnv.env) (name : ptydname) (rc : precord) += let { pl_loc = loc; pl_desc = (tyvars, name); } = name in (* Check type-parameters *) - let ue = TT.transtyvars env (loc, Some tyvars) in + let ue = TT.transtyvars ~idxparams env (loc, Some tyvars) in let tpath = EcPath.pqname (EcEnv.root env) (unloc name) in (* Check for duplicated field names *) @@ -73,13 +75,15 @@ let trans_record (env : EcEnv.env) (name : ptydname) (rc : precord) = { EI.rc_path = tpath; EI.rc_tparams = tparams; EI.rc_fields = fields; } (* -------------------------------------------------------------------- *) -let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = +let trans_datatype ?(idxparams : psymbol list = []) + (env : EcEnv.env) (name : ptydname) (dt : pdatatype) += let lc = `Global in let { pl_loc = loc; pl_desc = (tyvars, name); } = name in (* Check type-parameters / env0 is the env. augmented with an * abstract type representing the currently processed datatype. *) - let ue = TT.transtyvars env (loc, Some tyvars) in + let ue = TT.transtyvars ~idxparams env (loc, Some tyvars) in let tpath = EcPath.pqname (EcEnv.root env) (unloc name) in let env0 = let myself = { @@ -316,10 +320,22 @@ let trans_matchfix EcUnify.UniEnv.restore ~src:subue ~dst:ue; - let ctorty = + (* See [trans_branch] in ecTyping for the rationale: open + field types and a hand-built result type together so + the constructor's index univars stay anchored. *) + let result_ty = + EcTypes.tconstr indp + ~indices:(List.map (fun id -> EcAst.TIVar id) indty.tyd_params.idxvars) + ~tyargs:(List.map tvar indty.tyd_params.tyvars) in + let ctorty, pty = let tvi = Some (EcUnify.TVIunamed ([], tvi)) in - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in - let pty = EcUnify.UniEnv.fresh ue in + let opened, _ = + EcUnify.UniEnv.opentys ue indty.tyd_params tvi + (result_ty :: ctorty) in + match opened with + | r :: rest -> rest, r + | [] -> assert false + in (try EcUnify.unify env ue (toarrow ctorty pty) opty with EcUnify.UnificationFailure _ -> assert false); diff --git a/src/ecHiInductive.mli b/src/ecHiInductive.mli index 1db4bd0117..59c170e4a3 100644 --- a/src/ecHiInductive.mli +++ b/src/ecHiInductive.mli @@ -34,10 +34,12 @@ val dterror : EcLocation.t -> EcEnv.env -> dterror -> 'a val fxerror : EcLocation.t -> EcEnv.env -> EcTyping.fxerror -> 'a (* -------------------------------------------------------------------- *) -val trans_record : env -> ptydname -> precord -> record +val trans_record : + ?idxparams:psymbol list -> env -> ptydname -> precord -> record (* -------------------------------------------------------------------- *) -val trans_datatype : env -> ptydname -> pdatatype -> datatype +val trans_datatype : + ?idxparams:psymbol list -> env -> ptydname -> pdatatype -> datatype (* -------------------------------------------------------------------- *) type matchfix_t = { diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 7bae492668..395e210d16 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -158,7 +158,9 @@ and check_positivity_ident fct p params ident ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_ident fct p params ident) tys | Tconstr (q, args) when EcPath.p_equal q p -> - assert (List.is_empty args.indices); + (* Indices play no role in positivity: the recursion is on the + type, and indices are non-negative integer expressions that + carry no embedded type information. *) if not (ty_params_compat args.types params) then non_positive p (TypePositionRestriction ty) | Tconstr (q, args) -> @@ -178,7 +180,6 @@ let rec check_positivity_path fct p ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_path fct p) tys | Tconstr (q, args) when EcPath.p_equal q p -> - assert (List.is_empty args.indices); if List.exists (occurs p) args.types then non_positive p (NonPositiveOcc ty) | Tconstr (q, args) -> diff --git a/src/ecScope.ml b/src/ecScope.ml index e9b31c464d..65c63bcebb 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2234,12 +2234,6 @@ module Ty = struct check_name_available scope name; let env = env scope in - let no_indices_for kind = - if idxs <> [] then - hierror ~loc - "indexed type parameters are not yet supported on `%s' type \ - declarations" kind - in let tyd_params, tyd_type = match body with | PTYD_Abstract -> @@ -2252,8 +2246,10 @@ module Ty = struct EcUnify.UniEnv.tparams ue, Concrete body | PTYD_Datatype dt -> ( - no_indices_for "datatype"; - let datatype = EHI.trans_datatype env (mk_loc loc (args, name)) dt in + let datatype = + EHI.trans_datatype ~idxparams:idxs env + (mk_loc loc (args, name)) dt + in let ty_from_ctor ctor = EcEnv.Ty.by_path ctor env in try ELI.check_positivity ty_from_ctor datatype; @@ -2264,8 +2260,10 @@ module Ty = struct EHI.dterror loc env (EHI.DTE_NonPositive (symbol, ctx))) | PTYD_Record rt -> - no_indices_for "record"; - let record = EHI.trans_record env (mk_loc loc (args,name)) rt in + let record = + EHI.trans_record ~idxparams:idxs env + (mk_loc loc (args, name)) rt + in let scheme = ELI.indsc_of_record record in record.ELI.rc_tparams, Record (scheme, record.ELI.rc_fields) in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index bfc6fd909b..b7bdba577c 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1288,7 +1288,10 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in - let reccty = tconstr ~tyargs:(List.map tvar recty.tyd_params.tyvars) recp in + let reccty = + tconstr recp + ~indices:(List.map (fun id -> EcAst.TIVar id) recty.tyd_params.idxvars) + ~tyargs:(List.map tvar recty.tyd_params.tyvars) in let reccty, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in let tysopn = Tvar.init recty.tyd_params.tyvars rtvi in @@ -1384,10 +1387,25 @@ let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = EcUnify.UniEnv.restore ~src:subue ~dst:ue; - let ctorty = + (* Open the constructor's field types AND its result type with a + single substitution so that any fresh index univars allocated + for [indty.tyd_params.idxvars] are anchored to a type that + actually participates in unification — without this, a 0-field + constructor of an indexed datatype leaves its index univars + dangling. *) + let result_ty = + EcTypes.tconstr indp + ~indices:(List.map (fun id -> TIVar id) indty.tyd_params.idxvars) + ~tyargs:(List.map tvar indty.tyd_params.tyvars) in + let ctorty, pty = let tvi = Some (EcUnify.TVIunamed ([], tvi)) in - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in - let pty = EcUnify.UniEnv.fresh ue in + let opened, _ = + EcUnify.UniEnv.opentys ue indty.tyd_params tvi + (result_ty :: ctorty) in + match opened with + | r :: rest -> rest, r + | [] -> assert false + in (try EcUnify.unify env ue (toarrow ctorty pty) opty with EcUnify.UnificationFailure _ -> assert false); diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 39cccac925..58317af041 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -171,10 +171,22 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = let r1 = resolve_tindex ue t1 in let r2 = resolve_tindex ue t2 in if tindex_equal r1 r2 then () else - match tindex_solve_for_univar r1 r2 with - | Some (u, v) when not (tindex_occurs_univar u v) -> - ue := { !ue with ue_iuf = Muid.add u v (!ue).ue_iuf } - | _ -> failure () + let assign u t = + ue := { !ue with ue_iuf = Muid.add u t (!ue).ue_iuf } in + (* Fast path: if either side is a naked univar [?u] not occurring + in the other, assign directly. This subsumes the case [?u = ?v] + which [tindex_solve_for_univar] would refuse (it sees two + univars with non-zero net coefficient). *) + match tindex_naked_univar r1 with + | Some u when not (tindex_occurs_univar u r2) -> assign u r2 + | _ -> + match tindex_naked_univar r2 with + | Some u when not (tindex_occurs_univar u r1) -> assign u r1 + | _ -> + match tindex_solve_for_univar r1 r2 with + | Some (u, v) when not (tindex_occurs_univar u v) -> + assign u v + | _ -> failure () in let doit () = diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 9bb2557d1a..95aad2dcdd 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -106,3 +106,33 @@ op b_test2 [m 'a] (xs : 'a vec<:m+5>) : 'a vec<:m+4> = tail xs. (* Symmetric form: univar on the rhs of the equation. *) op head [n 'a] (xs : 'a vec<:n+1>) : 'a. op b_test3 ['a] (xs : 'a vec<:7>) : 'a = head xs. + +(* Gap C — non-refining indexed datatypes and records. *) + +(* Indexed datatype: constructor result type carries the index; + index unification at constructor application sites recovers it. *) +type [n] 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. + +op c_test1 : int ivec<:0> = INil. +op c_test2 (x : int) (xs : int ivec<:5>) : int ivec<:5> = ICons x xs. + +(* Plain match expression on indexed datatype. *) +op c_test3 (xs : int ivec<:5>) : int = + match xs with + | INil => 0 + | ICons y _ => y + end. + +(* Matchfix on indexed datatype with index binder on the op itself. *) +op c_test4 [n] (d : int) (xs : int ivec<:n>) : int = + with xs = INil => d + with xs = ICons y _ => y. + +(* Indexed record. Auto-generated constructor [mk_irec] and projectors + [`ivalue], [`idummy] all carry the index. *) +type [n] 'a irec = { ivalue : 'a; idummy : 'a ivec<:n> }. + +op c_test5 (x : int) (xs : int ivec<:0>) : int irec<:0> = + {| ivalue = x; idummy = xs |}. + +op c_test6 (r : int irec<:7>) : int = r.`ivalue. From a8708e6d561944ed3a8e5baf73137d89b9df03a8 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 08:52:59 +0200 Subject: [PATCH 16/40] indexed-types: document GADT/refinement limitation in memory.md Constructors of an indexed datatype are universally quantified over the index just like over type variables: INil has type forall n 'a. 'a ivec<:n>. Per-constructor result indices (GADT style) require both per-ctor result-type syntax AND index refinement on match, the latter being a much bigger dependent-typing feature. --- memory.md | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/memory.md b/memory.md index ce70cb3e9a..3858f72d31 100644 --- a/memory.md +++ b/memory.md @@ -560,6 +560,27 @@ F lands last to translate everything we now support). parametric ADT semantics. True dependent matching is a separate, much larger feature and not on the roadmap. + Also out of scope: **per-constructor result indices** (GADT-style). + Every constructor's result type is hard-wired to + `tconstr ~indices ~tyargs path` using the type's *own* idxvars + (see [src/ecEnv.ml:794-798]). So every ctor is universally + quantified over the index just like over type variables: `INil` + has type `forall n 'a. 'a ivec<:n>`, valid at every index. The + index carries no information about which constructor fired. + Achieving the GADT-style declaration + ``` + type [n] 'a vec = + | VNil : 'a vec<:0> + | VCons of 'a & 'a vec<:n> : 'a vec<:n+1> + ``` + would require (1) per-constructor result-type syntax (~1d of + parser/elaborator plumbing) AND (2) index refinement on match + (much larger — genuine dependent matching, intersects with SMT + discharge of unification, new machinery in `trans_branch` and a + refinement-aware unifier). Shipping (1) without (2) would be + worse than the current uniform-indices behavior because users + would expect refinement and not get it. + Verified: 6 new declarations in `tests/indexed-types.ec` covering constructor application, plain match, matchfix, indexed records, and field projection (139 declarations total). Non-indexed From 693888bc86b011c54bba3cb06bc54b379e7e0b4f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:05:13 +0200 Subject: [PATCH 17/40] =?UTF-8?q?indexed-types:=20gap=20F=20=E2=80=94=20SM?= =?UTF-8?q?T=20translation=20via=20per-concrete-index=20monomorphization?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the two CanNotTranslate raise sites in ecSmt for indexed Tconstr / Fop with a monomorphisation path. New helper EcAst.tindex_to_int reduces a tindex to a closed integer when possible (no free vars, no leftover univars); the SMT pipeline uses it to key two new caches (te_ty_idx, te_op_idx) by "path<:i,j,...>". trans_pty_idx / trans_tydecl_idx substitute idxvars by TIConst via EcCoreSubst.f_subst_init ~idx and emit fresh Why3 sorts named __... For indexed datatypes / records, all per-index constructor and projector variants are populated as a side-effect. trans_op_idx checks op_kind first: constructors / projectors / record-makers force their carrying type's monomorphisation (which populates te_op_idx); plain indexed operators get a fresh abstract Why3 symbol via create_op_idx. Bodies of plain indexed ops are dropped in this MVP — sound (treats the op opaquely) but limits SMT's unfolding across index instances. Goals with free index variables (e.g. an axiom binding [n]) still hit CanNotTranslate, preserving the per-goal skip behaviour: the existing try/catch around init / make_task emits the warning and the lemma falls through to "no provers" without a crash. Verified via 4 new SMT-discharge lemmas (160 declarations total in tests/indexed-types.ec) and a smoke test confirming non-indexed SMT goals are unaffected. --- memory.md | 42 ++++++- src/ecAst.ml | 10 ++ src/ecAst.mli | 5 + src/ecSmt.ml | 252 +++++++++++++++++++++++++++++++++++++++-- tests/indexed-types.ec | 21 ++++ 5 files changed, 317 insertions(+), 13 deletions(-) diff --git a/memory.md b/memory.md index 3858f72d31..b567bec53f 100644 --- a/memory.md +++ b/memory.md @@ -481,7 +481,7 @@ the SMT path — they belong in the Phase-6 polish pass. #### Known remaining gaps (documented but not scheduled) -- Indexed types in SMT translation (Phase-5 punt) — **Gap F**. +(none — Gaps B, C, F all landed.) #### Plan for the remaining gaps (B → C → F) @@ -586,6 +586,46 @@ F lands last to translate everything we now support). and field projection (139 declarations total). Non-indexed datatypes and records continue to compile unchanged. +### Post-Phase-6 — gap F (DONE) + +- **F** — SMT translation of indexed types via per-concrete-index + monomorphisation. + + The two former `CanNotTranslate` raise sites in + [src/ecSmt.ml](src/ecSmt.ml) (`trans_ty` Tconstr / `trans_app` + Fop) now check whether all indices reduce to closed integers via + the new `EcAst.tindex_to_int`. Closed indices dispatch to fresh + monomorphised symbols; non-closed indices still raise + `CanNotTranslate`, preserving the per-goal skip behaviour + (warning emitted, lemma falls through to "no provers", no crash). + + New caches in `tenv`: `te_ty_idx` and `te_op_idx`, both + string-keyed by `path<:i,j,...>`. New helpers `trans_pty_idx`, + `trans_tydecl_idx`, `trans_op_idx`, `create_op_idx`. The + declaration paths substitute idxvars by `TIConst` integers via + `EcCoreSubst.f_subst_init ~idx:...` then build a fresh Why3 + sort/lsymbol named `__...`. Constructors and + projectors of indexed datatypes/records get their per-index + variants populated as a side-effect of `trans_tydecl_idx`; + `trans_op_idx` checks `op_kind` and forces type monomorphisation + before falling back to `create_op_idx` for plain ops. + + Plain indexed operators are translated as **abstract** Why3 + symbols (no body). This is sound but limits SMT's ability to + unfold definitions across index instances. Lifting this would + require substituting idxvars in the operator's body (form/expr) + via `Fsubst.f_subst` and recursing through `trans_body`. Punted + for now — concrete bodies for indexed ops are rare in practice + and the user can add explicit lemmas if needed. + + Verified by 4 new SMT-discharge lemmas in `tests/indexed-types.ec` + (160 declarations total): a simple equality on `vec<:5>`, + equality on a constructor of an indexed datatype at index 0, + conjunction of equalities on two distinct concrete-index sorts + (`vec<:3>` and `vec<:5>`), and a use of explicit index + instantiation `vfn[:5]`. Non-indexed SMT discharge unchanged + (smoke-tested via list/match goals). + ### Post-Phase-6 — gaps E / D / A (DONE) - **E** — index binders on abbreviations and notations. diff --git a/src/ecAst.ml b/src/ecAst.ml index 1f99011be9..fa775c329d 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -1228,6 +1228,16 @@ let tindex_occurs_univar (u : EcUid.uid) (t : tindex) : bool = | TIAdd (l, r) | TIMul (l, r) -> walk l || walk r in walk t +(* If [ti] reduces to a closed non-negative integer (no [TIVar] or + [TIUnivar] anywhere), return that integer. Otherwise [None]. Used + by the SMT translation to decide whether an indexed type can be + monomorphised to a fresh Why3 sort. *) +let tindex_to_int (ti : tindex) : EcBigInt.zint option = + let c = tindex_canonicalize ti in + match c.cn_mons with + | [] -> Some c.cn_konst + | _ -> None + (* Reconstruct a [tindex] AST from a canonical polynomial. The canonical form's invariants (non-negative coefficients and constant) are required; behaviour is undefined for signed inputs. The diff --git a/src/ecAst.mli b/src/ecAst.mli index a368e5a2bb..0f9e04683e 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -435,6 +435,11 @@ val tindex_occurs_univar : EcUid.uid -> tindex -> bool val tindex_solve_for_univar : tindex -> tindex -> (EcUid.uid * tindex) option +(* Reduce [ti] to a closed non-negative integer if possible (no free + index variables and no leftover index univars). Used by the SMT + pipeline to monomorphise indexed types. *) +val tindex_to_int : tindex -> EcBigInt.zint option + val ty_equal : ty equality val ty_hash : ty hash val ty_fv : ty fv diff --git a/src/ecSmt.ml b/src/ecSmt.ml index e2637d739e..e23c6f9b5a 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -78,6 +78,11 @@ type tenv = { (*---*) tk_known_w3 : (kpattern * w3_known_op) list; (*---*) te_ty : w3ty Hp.t; (*---*) te_op : w3op Hp.t; + (* Per-index monomorphisation caches (Gap F). The key encodes the + path and the canonical integer values of the indices, so that + [vec<:3>] and [vec<:5>] map to distinct fresh Why3 symbols. *) + (*---*) te_ty_idx : (string, w3ty) Hashtbl.t; + (*---*) te_op_idx : (string, w3op) Hashtbl.t; (*---*) te_lc : w3op Hid.t; mutable te_lam : WTerm.term Mta.t; (*---*) te_gen : WTerm.term Hf.t; @@ -93,6 +98,8 @@ let empty_tenv env task (kwty, kw, kwk) = tk_known_w3 = kwk; te_ty = Hp.create 0; te_op = Hp.create 0; + te_ty_idx = Hashtbl.create 0; + te_op_idx = Hashtbl.create 0; te_lc = Hid.create 0; te_lam = Mta.empty; te_gen = Hf.create 0; @@ -370,6 +377,29 @@ let mk_tglob genv m = to skip the goal cleanly rather than crash. *) exception CanNotTranslate +(* Try to reduce an index list to a list of native ints. Returns + [None] if any index has free variables, leftover univars, or a + value too large for [int]. The Gap-F monomorphisation requires + closed indices to key the cache. *) +let tindices_to_ints (tis : tindex list) : int list option = + let rec go acc = function + | [] -> Some (List.rev acc) + | ti :: rest -> + match tindex_to_int ti with + | None -> None + | Some z -> + try go (BI.to_int z :: acc) rest + with _ -> None + in go [] tis + +let idx_key (p : path) (idxs : int list) : string = + Printf.sprintf "%s<:%s>" + (EcPath.tostring p) + (String.concat "," (List.map string_of_int idxs)) + +let idx_suffix (idxs : int list) : string = + String.concat "_" (List.map string_of_int idxs) + (* -------------------------------------------------------------------- *) let rec trans_ty ((genv, lenv) as env) ty = match ty.ty_node with @@ -381,12 +411,16 @@ let rec trans_ty ((genv, lenv) as env) ty = | Ttuple ts-> wty_tuple genv (trans_tys env ts) | Tconstr (p, tys) -> - (* Indexed types are not yet exported to Why3 — bail cleanly so - the SMT orchestration falls back to "cannot dispatch this - goal" rather than crashing on an [assert]. *) - if not (List.is_empty tys.indices) then - raise CanNotTranslate; - let id = trans_pty genv p in + let id = + if List.is_empty tys.indices then trans_pty genv p + else + (* Gap F — monomorphise per concrete index. If any index has + free variables or unresolved univars, we still cannot + translate this goal. *) + match tindices_to_ints tys.indices with + | None -> raise CanNotTranslate + | Some idxs -> trans_pty_idx genv p idxs + in WTy.ty_app id (trans_tys env tys.types) | Tfun (t1, t2) -> @@ -405,6 +439,14 @@ and trans_pty genv p = ts | None -> trans_tydecl genv (p, EcEnv.Ty.by_path p genv.te_env) +and trans_pty_idx genv p idxs = + let key = idx_key p idxs in + match Hashtbl.find_opt genv.te_ty_idx key with + | Some ts -> ts + | None -> + let tydecl = EcEnv.Ty.by_path p genv.te_env in + trans_tydecl_idx genv (p, tydecl, idxs, key) + and trans_tydecl genv (p, tydecl) = let pid = preid_p p in let lenv, tparams = lenv_of_tparams tydecl.tyd_params in @@ -473,6 +515,112 @@ and trans_tydecl genv (p, tydecl) = List.iter (fun (p, wop) -> Hp.add genv.te_op p wop) opts; ts +(* Gap F — translate an indexed instance of a type declaration. The + call site has already canonicalised the indices to a list of native + ints; we substitute every idxvar in the body by the corresponding + integer constant and then create fresh Why3 sort/op symbols, all + memoised under [(p, idxs)]. *) +and trans_tydecl_idx genv (p, tydecl, idxs, key) = + if List.compare_lengths tydecl.tyd_params.idxvars idxs <> 0 then + raise CanNotTranslate; + let idx_subst = + let mapping = + List.fold_left2 + (fun m id v -> Mid.add id (TIConst (BI.of_int v)) m) + Mid.empty tydecl.tyd_params.idxvars idxs + in + EcCoreSubst.f_subst_init ~idx:mapping () + in + let subst_ty = EcCoreSubst.ty_subst idx_subst in + + (* Idxvars are erased at the Why3 level — they have been replaced by + concrete integers. The new sort is parametrised only by tyvars. *) + let pid = + str_p (Printf.sprintf "%s_%s" + (EcPath.tostring p) (idx_suffix idxs)) in + let lenv, tparams = + lenv_of_tparams { tydecl.tyd_params with idxvars = [] } in + ignore key; + + let mangle q = pqoname (prefix q) + (Printf.sprintf "%s_%s" (basename q) (idx_suffix idxs)) in + + let ts, opts, decl = + match tydecl.tyd_type with + | Abstract -> + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + (ts, [], WDecl.create_ty_decl ts) + + | Concrete ty -> + let ty = trans_ty (genv, lenv) (subst_ty ty) in + let ts = WTy.create_tysymbol pid tparams (WTy.Alias ty) in + (ts, [], WDecl.create_ty_decl ts) + + | Datatype dt -> + let ncs = List.length dt.tydt_ctors in + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + + Hashtbl.add genv.te_ty_idx key ts; + + let wdom = + tconstr p + ~indices:(List.map (fun id -> TIVar id) []) + ~tyargs:(List.map tvar tydecl.tyd_params.tyvars) + in + (* Use the just-created [ts] directly rather than recursing + through [trans_ty], which would not find this entry yet + in the cache (the entry uses the original path's idx_key + but [wdom] above carries no indices). *) + let _ = wdom in + let wdom = WTy.ty_app ts (List.map (trans_ty (genv, lenv)) + (List.map tvar tydecl.tyd_params.tyvars)) in + + let for_ctor (c, ctys) = + let wcid = mangle (pqoname (prefix p) c) in + let wctys = List.map (fun t -> trans_ty (genv, lenv) (subst_ty t)) ctys in + let wcls = WTerm.create_lsymbol ~constr:ncs (preid_p wcid) wctys (Some wdom) in + let w3op = plain_w3op ~name:(basename wcid) tparams wcls in + ((c, w3op), (wcls, List.make (List.length ctys) None)) + in + + let opts, wdtype = List.split (List.map for_ctor dt.tydt_ctors) in + (ts, opts, WDecl.create_data_decl [ts, wdtype]) + + | Record (_, rc) -> + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + + Hashtbl.add genv.te_ty_idx key ts; + + let wdom = WTy.ty_app ts (List.map (trans_ty (genv, lenv)) + (List.map tvar tydecl.tyd_params.tyvars)) in + + let for_field (fname, fty) = + let wfid = mangle (pqoname (prefix p) fname) in + let wfty = trans_ty (genv, lenv) (subst_ty fty) in + let wcls = WTerm.create_lsymbol ~proj:true (preid_p wfid) [wdom] (Some wfty) in + let w3op = plain_w3op ~name:(basename wfid) tparams wcls in + ((fname, w3op), wcls) + in + + let wcid = mangle (EI.record_ctor_path p) in + let wctys = List.map (fun t -> trans_ty (genv, lenv) (subst_ty t)) + (List.map snd rc) in + let wcls = WTerm.create_lsymbol ~constr:1 (preid_p wcid) wctys (Some wdom) in + let w3op = plain_w3op ~name:(basename wcid) tparams wcls in + + let opts, wproj = List.split (List.map for_field rc) in + let wproj = List.map some wproj in + + (ts, (basename wcid, w3op) :: opts, WDecl.create_data_decl [ts, [wcls, wproj]]) + in + + genv.te_task <- WTask.add_decl genv.te_task decl; + Hashtbl.replace genv.te_ty_idx key ts; + List.iter (fun (cname, wop) -> + let cpath = pqoname (prefix p) cname in + Hashtbl.add genv.te_op_idx (idx_key cpath idxs) wop) opts; + ts + (* -------------------------------------------------------------------- *) let trans_memtype ((genv, _) as env) mt = match EcMemory.local_type mt with @@ -721,12 +869,15 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = trans_fun env bds body args | Fop (p, ts) -> - (* See note on Tconstr in [trans_ty] — indexed-op signatures - carry indices through their type arguments, which we cannot - yet translate. *) - if not (List.is_empty ts.indices) then - raise CanNotTranslate; - let wop = trans_op genv p in + let wop = + if List.is_empty ts.indices then trans_op genv p + else + (* Gap F — monomorphise per concrete index, just like the + type path does for [Tconstr] above. *) + match tindices_to_ints ts.indices with + | None -> raise CanNotTranslate + | Some idxs -> trans_op_idx genv p idxs + in let tys = List.map (trans_ty (genv,lenv)) ts.types in apply_wop genv wop tys args @@ -837,6 +988,83 @@ and trans_letbinding (genv, lenv) (lp, f1, f2) args = and trans_op (genv:tenv) p = try Hp.find genv.te_op p with Not_found -> create_op ~body:true genv p +(* Gap F — translate an indexed instance of an operator. Constructors + and projectors are populated as a side-effect of [trans_tydecl_idx], + so we trigger the carrying type's monomorphisation first. Plain + indexed operators get a fresh abstract Why3 symbol with idxvars + substituted by their concrete integer values; the body is dropped + in this MVP (treat the op as opaque to SMT, which is sound). *) +and trans_op_idx (genv : tenv) p idxs = + let key = idx_key p idxs in + match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> + let op = EcEnv.Op.by_path p genv.te_env in + (* For constructors / projectors / record-makers, force the + carrying type's monomorphisation: it will populate + [te_op_idx] with all the per-index ctor/proj symbols. *) + let owner = + match op.op_kind with + | OB_oper (Some (OP_Constr (q, _))) + | OB_oper (Some (OP_Proj (q, _, _))) + | OB_oper (Some (OP_Record q)) -> Some q + | _ -> None + in + (match owner with + | None -> () + | Some q -> ignore (trans_pty_idx genv q idxs)); + (match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> create_op_idx genv p idxs key) + +and create_op_idx (genv : tenv) p idxs key = + let op = EcEnv.Op.by_path p genv.te_env in + if List.compare_lengths op.op_tparams.idxvars idxs <> 0 then + raise CanNotTranslate; + + let idx_subst = + let mapping = + List.fold_left2 + (fun m id v -> Mid.add id (TIConst (BI.of_int v)) m) + Mid.empty op.op_tparams.idxvars idxs + in + EcCoreSubst.f_subst_init ~idx:mapping () + in + let op_ty' = EcCoreSubst.ty_subst idx_subst op.op_ty in + + let op_tparams' = { op.op_tparams with idxvars = [] } in + let lenv, wparams = lenv_of_tparams op_tparams' in + let dom, codom = EcEnv.Ty.signature genv.te_env op_ty' in + let textra = + List.filter + (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op_ty'))) + op_tparams'.tyvars in + let textra = + List.map (fun tv -> trans_ty (genv,lenv) (tvar tv)) textra in + let wdom = trans_tys (genv, lenv) dom in + let wcodom = + if ER.EqTest.is_bool genv.te_env codom + then None + else Some (trans_ty (genv, lenv) codom) + in + + match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> + let pid = str_p (Printf.sprintf "%s_%s" + (EcPath.tostring p) (idx_suffix idxs)) in + let ls = WTerm.create_lsymbol pid (textra@wdom) wcodom in + let name = ls.WTerm.ls_name.WIdent.id_string in + let w3op = { + w3op_fo = `LDecl ls; + w3op_ta = instantiate wparams ~textra wdom wcodom; + w3op_ho = `HO_TODO (name, textra@wdom, wcodom); + } in + Hashtbl.add genv.te_op_idx key w3op; + let decl = WDecl.create_param_decl ls in + genv.te_task <- WTask.add_decl genv.te_task decl; + w3op + (* -------------------------------------------------------------------- *) and trans_pvar ((genv, lenv) as env) pv ty mem = let pv = NormMp.norm_pvar genv.te_env pv in diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 95aad2dcdd..157ed6c1f8 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -136,3 +136,24 @@ op c_test5 (x : int) (xs : int ivec<:0>) : int irec<:0> = {| ivalue = x; idummy = xs |}. op c_test6 (r : int irec<:7>) : int = r.`ivalue. + +(* Gap F — SMT translation via per-index monomorphisation. + Concrete indices turn `vec<:3>` into a fresh Why3 sort `vec_3`. + Goals that mention only concrete indices make it through to SMT; + goals with free index variables still fall cleanly into the + [CanNotTranslate] skip (no crash, no proof, per-goal skip). *) + +op vfn [n] : int vec<:n>. + +lemma f_test1 : vfn[:5] = vfn[:5]. +proof. smt(). qed. + +lemma f_test2 : c_test1 = c_test1. +proof. smt(). qed. + +(* Two distinct concrete indices get distinct Why3 sorts. *) +op f_vec3 : int vec<:3>. +op f_vec5 : int vec<:5>. + +lemma f_test3 : f_vec3 = f_vec3 /\ f_vec5 = f_vec5. +proof. smt(). qed. From 1361235cefe374af06ea8eaf6185cd2f1271cbf6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:10:07 +0200 Subject: [PATCH 18/40] indexed-types: regression tests for lemmas with index binders MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Lock in that lemma headers accept index params via the existing [n 'a] mixed_tyvars_decl syntax (shared with op binders). Discovered no fix was needed — the original "lemma binders don't accept index params" finding was a syntax confusion: separate brackets ['a] [n] are not supported (only the combined ['a n] form), and <:n> is the type-application framing while [:n] is the op-call framing. Two new lemmas exercise: a parametric proof using [trivial], and a quantified form using [move => ; trivial]. SMT discharge of goals with bound (non-closed) indices remains correctly skipped. --- tests/indexed-types.ec | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 157ed6c1f8..cb3f4d8395 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -157,3 +157,15 @@ op f_vec5 : int vec<:5>. lemma f_test3 : f_vec3 = f_vec3 /\ f_vec5 = f_vec5. proof. smt(). qed. + +(* Lemmas can take index binders alongside type binders in the same + bracket: [n 'a] or ['a n], shared syntax with op binders. SMT + translation skips goals with bound (non-closed) indices, so these + are discharged with [trivial] rather than [smt()]. *) +lemma f_test4 ['a n] (x : 'a) (xs : 'a vec<:n>) : + cons x xs = cons x xs. +proof. trivial. qed. + +lemma f_test5 ['a n] : + forall (x : 'a) (xs : 'a vec<:n>), cons x xs = cons x xs. +proof. move => x xs; trivial. qed. From a115f7efbdd3242cc72040ab4d40cfb09bf4bbcb Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:16:39 +0200 Subject: [PATCH 19/40] indexed-types: pretty-print [n 'a] binders on type/op/pred/axiom decls The printers for type declarations, operators, predicates, abbreviations, axioms and added-ops only emitted [tparams.tyvars], silently dropping the index binders. So [type [n] word.] would print as [type word.], hiding the index parameter from the user. New helper [pp_paramsannot ppe fmt (idxvars, tyvars)] prints the combined-bracket form [n 'a] matching the input syntax. All five printers now consult both lists; the per-kind operator printers (pp_opdecl_op / _pr / _nt) take a [ty_params] record instead of a bare tyvars list, and the dispatch in pp_opdecl passes op.op_tparams. Verified against /tmp/print_idx.ec: [type [n] word.], [type [n m] 'a vec.], [op cons [n 'a] : ...], [pred ix_pr [n 'a]], and [axiom ix_ax [n 'a]] all print their index binders. --- src/ecPrinting.ml | 104 +++++++++++++++++++++++++++++++++------------- 1 file changed, 74 insertions(+), 30 deletions(-) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index a0806c4b16..048b84360f 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2301,19 +2301,29 @@ let pp_sform ppe fmt f = (* -------------------------------------------------------------------- *) let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = let ppe = PPEnv.enter_theory ppe (Option.get (EcPath.prefix x)) in + let ppe = PPEnv.add_locals ppe tyd.tyd_params.idxvars in let ppe = PPEnv.add_locals ppe tyd.tyd_params.tyvars in let name = P.basename x in + let pp_idxbinder fmt = + match tyd.tyd_params.idxvars with + | [] -> () + | ids -> + Format.fprintf fmt "[%a] " (pp_list "@ " (pp_tyvar ppe)) ids + in + let pp_prelude fmt = match tyd.tyd_params.tyvars with | [] -> - Format.fprintf fmt "type %s" name + Format.fprintf fmt "type %t%s" pp_idxbinder name | [tx] -> - Format.fprintf fmt "type %a %s" (pp_tyvar ppe) tx name + Format.fprintf fmt "type %t%a %s" + pp_idxbinder (pp_tyvar ppe) tx name | txs -> - Format.fprintf fmt "type %a %s" + Format.fprintf fmt "type %t%a %s" + pp_idxbinder (pp_paren (pp_list ",@ " (pp_tyvar ppe))) txs name and pp_body fmt = @@ -2350,6 +2360,17 @@ let pp_tyvarannot (ppe : PPEnv.t) fmt (ids: EcIdent.t list) = | [] -> () | ids -> Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar ppe)) ids +(* Mixed [n 'a] binder annotation. Idxvars print first (no apostrophe), + then tyvars (apostrophed via [pp_tyvar]). Whitespace-separated to + match the input syntax. *) +let pp_paramsannot (ppe : PPEnv.t) fmt (idxvars, tyvars) = + match idxvars, tyvars with + | [], [] -> () + | _ -> + Format.fprintf fmt "[%a]" + (pp_list "@ " (pp_tyvar ppe)) + (idxvars @ tyvars) + let pp_pvar (ppe : PPEnv.t) fmt ids = match ids with | [] -> () @@ -2427,7 +2448,11 @@ let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((nm, cp1) : CP.codepos) Format.fprintf fmt "%a%a" (pp_list "" pp_nm) nm (pp_codepos1 ppe) cp1 (* -------------------------------------------------------------------- *) -let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * EcIdent.t list * ty * prbody option) = +let pp_opdecl_pr (ppe : PPEnv.t) fmt + ((basename, tparams, ty, op) + : symbol * EcDecl.ty_params * ty * prbody option) = + let ts = tparams.tyvars in + let ppe = PPEnv.add_locals ppe tparams.idxvars in let ppe = PPEnv.add_locals ppe ts in let pp_body fmt = @@ -2475,15 +2500,21 @@ let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * EcIdent.t pp_vds (pp_list "@\n" pp_ctor) pri.pri_ctors in - if List.is_empty ts then + if List.is_empty tparams.idxvars && List.is_empty ts then Format.fprintf fmt "@[pred %a %t.@]" pp_opname ([], basename) pp_body else Format.fprintf fmt "@[pred %a %a %t.@]" - pp_opname ([], basename) (pp_tyvarannot ppe) ts pp_body + pp_opname ([], basename) + (pp_paramsannot ppe) (tparams.idxvars, ts) + pp_body (* -------------------------------------------------------------------- *) -let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = +let pp_opdecl_op (ppe : PPEnv.t) fmt + ((basename, tparams, ty, op) + : symbol * EcDecl.ty_params * ty * opbody option) = + let ts = tparams.tyvars in + let ppe = PPEnv.add_locals ppe tparams.idxvars in let ppe = PPEnv.add_locals ppe ts in let pp_body fmt = @@ -2563,17 +2594,22 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = Format.fprintf fmt "= < type-class-operator >" in - match ts with - | [] -> Format.fprintf fmt "@[op %a %t.@]" + if List.is_empty tparams.idxvars && List.is_empty ts then + Format.fprintf fmt "@[op %a %t.@]" pp_opname ([], basename) pp_body - | _ -> - Format.fprintf fmt "@[op %a %a %t.@]" - pp_opname ([], basename) (pp_tyvarannot ppe) ts pp_body + else + Format.fprintf fmt "@[op %a %a %t.@]" + pp_opname ([], basename) + (pp_paramsannot ppe) (tparams.idxvars, ts) + pp_body (* -------------------------------------------------------------------- *) -let pp_opdecl_nt (ppe : PPEnv.t) fmt - ((basename, ts, _ty, nt) : symbol * EcIdent.t list * ty * notation) +let pp_opdecl_nt (ppe : PPEnv.t) fmt + ((basename, tparams, _ty, nt) + : symbol * EcDecl.ty_params * ty * notation) = + let ts = tparams.tyvars in + let ppe = PPEnv.add_locals ppe tparams.idxvars in let ppe = PPEnv.add_locals ppe ts in let pp_body fmt = @@ -2585,12 +2621,14 @@ let pp_opdecl_nt (ppe : PPEnv.t) fmt (pp_expr subppe) nt.ont_body in - match ts with - | [] -> Format.fprintf fmt "@[abbrev %a %t.@]" + if List.is_empty tparams.idxvars && List.is_empty ts then + Format.fprintf fmt "@[abbrev %a %t.@]" pp_opname ([], basename) pp_body - | _ -> - Format.fprintf fmt "@[abbrev %a %a %t.@]" - pp_opname ([], basename) (pp_tyvarannot ppe) ts pp_body + else + Format.fprintf fmt "@[abbrev %a %a %t.@]" + pp_opname ([], basename) + (pp_paramsannot ppe) (tparams.idxvars, ts) + pp_body (* -------------------------------------------------------------------- *) let pp_opdecl @@ -2611,23 +2649,25 @@ let pp_opdecl let pp_decl fmt op = match op.op_kind with | OB_oper i -> - pp_opdecl_op ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) + pp_opdecl_op ppe fmt (P.basename x, op.op_tparams, op_ty op, i) | OB_pred i -> - pp_opdecl_pr ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) + pp_opdecl_pr ppe fmt (P.basename x, op.op_tparams, op_ty op, i) | OB_nott i -> let ppe = { ppe with PPEnv.ppe_fb = Sp.add x ppe.PPEnv.ppe_fb } in - pp_opdecl_nt ppe fmt (P.basename x, op.op_tparams.tyvars, op_ty op, i) + pp_opdecl_nt ppe fmt (P.basename x, op.op_tparams, op_ty op, i) in Format.fprintf fmt "@[%a%a%a@]" pp_locality op.op_loca pp_name x pp_decl op let pp_added_op (ppe : PPEnv.t) fmt op = + let ppe = PPEnv.add_locals ppe op.op_tparams.idxvars in let ppe = PPEnv.add_locals ppe op.op_tparams.tyvars in - match op.op_tparams.tyvars with - | [] -> Format.fprintf fmt ": @[%a@]" - (pp_type ppe) op.op_ty - | ts -> + if List.is_empty op.op_tparams.idxvars + && List.is_empty op.op_tparams.tyvars then + Format.fprintf fmt ": @[%a@]" (pp_type ppe) op.op_ty + else Format.fprintf fmt "@[%a :@ %a.@]" - (pp_tyvarannot ppe) ts (pp_type ppe) op.op_ty + (pp_paramsannot ppe) (op.op_tparams.idxvars, op.op_tparams.tyvars) + (pp_type ppe) op.op_ty (* -------------------------------------------------------------------- *) let pp_opname (ppe : PPEnv.t) fmt (p : EcPath.path) = @@ -2643,6 +2683,7 @@ let tags_of_axkind = function | `Lemma -> [] let pp_axiom ?(long=false) (ppe : PPEnv.t) fmt (x, ax) = + let ppe = PPEnv.add_locals ppe ax.ax_tparams.idxvars in let ppe = PPEnv.add_locals ppe ax.ax_tparams.tyvars in let basename = P.basename x in @@ -2650,9 +2691,12 @@ let pp_axiom ?(long=false) (ppe : PPEnv.t) fmt (x, ax) = pp_form ppe fmt ax.ax_spec and pp_name fmt = - match ax.ax_tparams.tyvars with - | [] -> Format.fprintf fmt "%s" basename - | ts -> Format.fprintf fmt "%s %a" basename (pp_tyvarannot ppe) ts + if List.is_empty ax.ax_tparams.idxvars + && List.is_empty ax.ax_tparams.tyvars then + Format.fprintf fmt "%s" basename + else + Format.fprintf fmt "%s %a" basename + (pp_paramsannot ppe) (ax.ax_tparams.idxvars, ax.ax_tparams.tyvars) and pp_tags fmt = let tags = tags_of_axkind ax.ax_kind in From 4e9999c69e777758ebe1b8c80e2f9885f9ab1ec3 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:26:11 +0200 Subject: [PATCH 20/40] indexed-types: reinterpret op-leading bracket as binder when not a tag The op grammar accepts an optional bracket-before-name for the opacity tags (opaque, smt_opaque). When users write [op [n] "_.[_]" (w : word<:n>) : bool] hoping to bind an idxvar [n], the parser greedily consumed the [n] as tags and silently discarded it, leaving [n] unbound in the type signature. Add a [disambiguate_op_brackets] helper invoked from both operator rule alternatives. If every entry in the leading bracket is in the known-tag whitelist, treat as tags (existing behaviour preserved for [op [opaque] foo], [op [opaque smt_opaque] foo], etc.). Otherwise reinterpret the bracket as a pure idxvar binder; if both the leading bracket and an after-name binder are present, raise a clear parse error rather than guessing. This fixes the canonical infix-style indexed-op declaration: type [n] word. op [n] "_.[_]" (w : word<:n>) : bool. which now parses with [n] correctly bound as an idxvar. Verified: full regression (182 decls), the original report case, and theories/datatypes/FMap.ec (heavy [opaque] tag user) still compile unchanged. --- src/ecParser.mly | 55 +++++++++++++++++++++++++++++++++++++----- tests/indexed-types.ec | 10 ++++++++ 2 files changed, 59 insertions(+), 6 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 5a8373c327..17ed443e1d 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -34,6 +34,46 @@ | `Ty x :: rest -> aux ix (x :: ty) rest in aux [] [] items + (* Whitelist of op-tag identifiers that the scope layer recognises. + Anything in the leading op-tags bracket that is not in this set + is reinterpreted as an idxvar binder, so a user-supplied + bracket-before-name is treated as an idxvar binder rather than + silently dropped as ineffective tags. *) + let known_op_tags = ["opaque"; "smt_opaque"] + + let disambiguate_op_brackets + (loc : EcLocation.t) + (raw_tags : EcParsetree.psymbol list option) + (tvs : (EcParsetree.psymbol list * EcParsetree.psymbol list) option) + : EcParsetree.psymbol list + * EcParsetree.psymbol list + * EcParsetree.psymbol list option + = + let raw_tags = EcUtils.odfl [] raw_tags in + let unknown = + List.filter + (fun t -> not (List.mem (EcLocation.unloc t) known_op_tags)) + raw_tags in + match unknown, tvs with + | [], _ -> + (* All entries in the leading bracket are recognised tags. + Use as tags; binder (if any) is the after-name [tvs]. *) + let (idxvars, tyvars) = EcUtils.odfl ([], []) tvs in + (raw_tags, idxvars, tvs |> EcUtils.omap (fun _ -> tyvars)) + | _, None -> + (* The leading bracket has at least one non-tag identifier and + there is no after-name binder — reinterpret the bracket as a + pure idxvar binder. *) + ([], raw_tags, Some []) + | _, Some _ -> + (* Both a (non-tag) leading bracket and an after-name binder + were given. We refuse rather than guess. *) + parse_error loc (Some + "ambiguous bracket placement: the bracket before the name \ + contains identifier(s) that are not recognised op tags \ + (opaque / smt_opaque), but an idxvar / type-variable binder \ + also follows the name. Pick one placement.") + let opdef_of_opbody ty b = match b with | None -> PO_abstr ty @@ -1841,14 +1881,15 @@ operator: { let gloc = EcLocation.make $startpos $endpos in let sty = sty |> ofdfl (fun () -> mk_loc (b |> omap (loc |- fst) |> odfl gloc) PTunivar) in - let (idxvars, tyvars) = odfl ([], []) tvs in + let (po_tags, idxvars, po_tyvars) = + disambiguate_op_brackets gloc tags tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; - po_tags = odfl [] tags; + po_tags = po_tags; po_idxvars = idxvars; - po_tyvars = tvs |> omap (fun _ -> tyvars); + po_tyvars = po_tyvars; po_args = odfl ([], None) args; po_def = opdef_of_opbody sty (omap (unloc |- fst) b); po_ax = obind snd b; @@ -1858,13 +1899,15 @@ operator: x=plist1(oident, COMMA) tvs=mixed_tyvars_decl? args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { let (idxvars, tyvars) = odfl ([], []) tvs in + { let gloc = EcLocation.make $startpos $endpos in + let (po_tags, idxvars, po_tyvars) = + disambiguate_op_brackets gloc tags tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; - po_tags = odfl [] tags; + po_tags = po_tags; po_idxvars = idxvars; - po_tyvars = tvs |> omap (fun _ -> tyvars); + po_tyvars = po_tyvars; po_args = odfl ([], None) args; po_def = opdef_of_opbody sty (Some (`Reft (rname, reft))); po_ax = None; diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index cb3f4d8395..2d9f5c86ad 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -169,3 +169,13 @@ proof. trivial. qed. lemma f_test5 ['a n] : forall (x : 'a) (xs : 'a vec<:n>), cons x xs = cons x xs. proof. move => x xs; trivial. qed. + +(* The op-leading bracket is normally for tags (opaque / smt_opaque). + When it contains anything else, the parser reinterprets it as an + idxvar binder so users don't have to remember the after-name + placement when defining infix-style operators. *) +op [n] "_.[_]" (w : int vec<:n>) (_ : int) : bool. + +(* Tags-before-name still work for the recognised tag set. *) +op [opaque] g_const : int = 42. +op [opaque smt_opaque] g_const2 : int = 7. From 224a724dd1f8787a580d5c9653d4f4f78ff8cbb6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:37:52 +0200 Subject: [PATCH 21/40] indexed-types: switch index binders from [n 'a] to {n} ['a] Indices and type variables now use distinct bracket families: - {n m} for index binders - ['a 'b] for type-variable binders Indices come first when both are present. Why: the previous mixed bracket [n 'a] was overloaded with the op-leading [opaque] tags bracket, requiring a content-based disambiguation that confused users when an unrecognised tag was silently rewritten as a binder. With braces vs. brackets, the parser disambiguates lexically and there is no overlap with op tags. Parser: - idxvars_decl now matches LBRACE lident+ RBRACE. - mixed_tyvars_decl and bucket_mixed are gone, replaced by a single ix_ty_binder rule that takes idxvars_decl? then tyvars_decl? and returns (idxvars, tyvars_opt). - The Gap-fix disambiguate_op_brackets helper is removed; the op rules now read tags from the leading [...] and the binder from the after-name {...} [...] pair without any reinterpretation. - All consumers (operator x2, pred x2, inductive, notation, abbrev, lemma_decl) switched to ix_ty_binder. Pretty-printer: - pp_paramsannot emits {idx} for indices and ['a] for tyvars, separated by a single space when both are non-empty. - pp_typedecl uses curly braces for the leading idx binder. Tests: tests/indexed-types.ec (159 declarations) migrated to the new syntax. Round-trip print produces text that re-parses unchanged. FMap.ec (heavy [opaque] tag user) still compiles. --- src/ecParser.mly | 135 ++++++++++++----------------------------- src/ecPrinting.ml | 28 ++++++--- tests/indexed-types.ec | 117 ++++++++++++++--------------------- 3 files changed, 107 insertions(+), 173 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 17ed443e1d..f2d41fd886 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -22,57 +22,9 @@ pty_locality = locality; } - (* Bucket a mixed `[ apostrophe-or-plain idents... ]` binder list into - (indices, type variables). *) - let bucket_mixed - (items : [`Ty of EcParsetree.psymbol | `Idx of EcParsetree.psymbol] list) - : EcParsetree.psymbol list * EcParsetree.psymbol list - = - let rec aux ix ty = function - | [] -> (List.rev ix, List.rev ty) - | `Idx x :: rest -> aux (x :: ix) ty rest - | `Ty x :: rest -> aux ix (x :: ty) rest - in aux [] [] items - - (* Whitelist of op-tag identifiers that the scope layer recognises. - Anything in the leading op-tags bracket that is not in this set - is reinterpreted as an idxvar binder, so a user-supplied - bracket-before-name is treated as an idxvar binder rather than - silently dropped as ineffective tags. *) - let known_op_tags = ["opaque"; "smt_opaque"] - - let disambiguate_op_brackets - (loc : EcLocation.t) - (raw_tags : EcParsetree.psymbol list option) - (tvs : (EcParsetree.psymbol list * EcParsetree.psymbol list) option) - : EcParsetree.psymbol list - * EcParsetree.psymbol list - * EcParsetree.psymbol list option - = - let raw_tags = EcUtils.odfl [] raw_tags in - let unknown = - List.filter - (fun t -> not (List.mem (EcLocation.unloc t) known_op_tags)) - raw_tags in - match unknown, tvs with - | [], _ -> - (* All entries in the leading bracket are recognised tags. - Use as tags; binder (if any) is the after-name [tvs]. *) - let (idxvars, tyvars) = EcUtils.odfl ([], []) tvs in - (raw_tags, idxvars, tvs |> EcUtils.omap (fun _ -> tyvars)) - | _, None -> - (* The leading bracket has at least one non-tag identifier and - there is no after-name binder — reinterpret the bracket as a - pure idxvar binder. *) - ([], raw_tags, Some []) - | _, Some _ -> - (* Both a (non-tag) leading bracket and an after-name binder - were given. We refuse rather than guess. *) - parse_error loc (Some - "ambiguous bracket placement: the bracket before the name \ - contains identifier(s) that are not recognised op tags \ - (opaque / smt_opaque), but an idxvar / type-variable binder \ - also follows the name. Pick one placement.") + (* No mixed-bucket helper: idxvars and tyvars now use distinct + bracket families ({...} vs [...]), so the parser can keep them + separate. *) let opdef_of_opbody ty b = match b with @@ -1379,12 +1331,12 @@ pindex: | a=pindex PLUS b=pindex_mul { mk_loc (EcLocation.merge a.pl_loc b.pl_loc) (PIadd (a, b)) } -(* Optional binder list of index parameters appearing right after - `type` (e.g. `type [n m] 'a vec`). Naked identifiers (no - apostrophe) inside square brackets distinguish them from type - parameters which use `'a`-style identifiers. *) +(* Index-parameter binder. Uses curly braces and naked identifiers + (e.g. `{n m}`), distinct from the square-bracket binder used for + type variables (`['a 'b]`). When both are present, the index + binder must come first: `type {n} 'a vec`. *) idxvars_decl: -| LBRACKET xs=lident+ RBRACKET { xs } +| LBRACE xs=lident+ RBRACE { xs } type_exp: | ty=simpl_type_exp { ty } @@ -1856,18 +1808,15 @@ tyvars_decl: | LBRACKET tyvars=rlist2(tident, empty) RBRACKET { tyvars } -(* Mixed binder list: each item is a tident (`'a`) bound as a type - variable, or a plain lident (`n`) bound as an integer index. Used - on operator/predicate/axiom/lemma headers, where indices and type - variables share a single set of brackets. Returns (idxvars, tyvars). *) -mixed_tyvars_item: -| x=tident { `Ty x } -| x=lident { `Idx x } - -mixed_tyvars_decl: -| LBRACKET items=rlist0(mixed_tyvars_item, COMMA) RBRACKET -| LBRACKET items=rlist2(mixed_tyvars_item, empty) RBRACKET - { bucket_mixed items } +(* Combined `{idx}` then `['a]` binder. Indices come first; both are + independently optional. Returns [(idxvars, tyvars_opt)] where + [tyvars_opt] is [None] when no [...] bracket appeared at all, + matching the legacy [tvs |> omap ...] convention so downstream + `po_tyvars`-style fields keep distinguishing "no binder given" + from "empty binder given". *) +ix_ty_binder: +| idx=idxvars_decl? ty=tyvars_decl? + { (EcUtils.odfl [] idx, ty) } op_or_const: | OP { `Op } @@ -1875,19 +1824,18 @@ op_or_const: operator: | locality=locality k=op_or_const tags=bracket(ident*)? - x=plist1(oident, COMMA) tvs=mixed_tyvars_decl? args=ptybindings_opdecl? + x=plist1(oident, COMMA) tvs=ix_ty_binder args=ptybindings_opdecl? sty=prefix(COLON, loc(type_exp))? b=seq(prefix(EQ, loc(opbody)), opax?)? { let gloc = EcLocation.make $startpos $endpos in let sty = sty |> ofdfl (fun () -> mk_loc (b |> omap (loc |- fst) |> odfl gloc) PTunivar) in - let (po_tags, idxvars, po_tyvars) = - disambiguate_op_brackets gloc tags tvs in + let (idxvars, po_tyvars) = tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; - po_tags = po_tags; + po_tags = odfl [] tags; po_idxvars = idxvars; po_tyvars = po_tyvars; po_args = odfl ([], None) args; @@ -1896,16 +1844,14 @@ operator: po_locality = locality; } } | locality=locality k=op_or_const tags=bracket(ident*)? - x=plist1(oident, COMMA) tvs=mixed_tyvars_decl? args=ptybindings_opdecl? + x=plist1(oident, COMMA) tvs=ix_ty_binder args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { let gloc = EcLocation.make $startpos $endpos in - let (po_tags, idxvars, po_tyvars) = - disambiguate_op_brackets gloc tags tvs in + { let (idxvars, po_tyvars) = tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; - po_tags = po_tags; + po_tags = odfl [] tags; po_idxvars = idxvars; po_tyvars = po_tyvars; po_args = odfl ([], None) args; @@ -1972,29 +1918,29 @@ predicate: pp_def = PPabstr []; pp_locality = locality; } } -| locality=locality PRED x=oident tvs=mixed_tyvars_decl? COLON sty=pred_tydom - { let (idxvars, tyvars) = odfl ([], []) tvs in +| locality=locality PRED x=oident tvs=ix_ty_binder COLON sty=pred_tydom + { let (idxvars, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; - pp_tyvars = tvs |> omap (fun _ -> tyvars); + pp_tyvars = pp_tyvars; pp_def = PPabstr sty; pp_locality = locality; } } -| locality=locality PRED x=oident tvs=mixed_tyvars_decl? p=ptybindings? EQ f=form - { let (idxvars, tyvars) = odfl ([], []) tvs in +| locality=locality PRED x=oident tvs=ix_ty_binder p=ptybindings? EQ f=form + { let (idxvars, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; - pp_tyvars = tvs |> omap (fun _ -> tyvars); + pp_tyvars = pp_tyvars; pp_def = PPconcr (odfl [] p, f); pp_locality = locality; } } -| locality=locality INDUCTIVE x=oident tvs=mixed_tyvars_decl? p=ptybindings? +| locality=locality INDUCTIVE x=oident tvs=ix_ty_binder p=ptybindings? EQ b=indpred_def - { let (idxvars, tyvars) = odfl ([], []) tvs in + { let (idxvars, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; - pp_tyvars = tvs |> omap (fun _ -> tyvars); + pp_tyvars = pp_tyvars; pp_def = PPind (odfl [] p, b); pp_locality = locality; } } @@ -2034,12 +1980,12 @@ nt_bindings: { bd } notation: -| locality=loc(locality) NOTATION x=loc(NOP) tvs=mixed_tyvars_decl? bd=nt_bindings? +| locality=loc(locality) NOTATION x=loc(NOP) tvs=ix_ty_binder bd=nt_bindings? args=nt_arg1* codom=prefix(COLON, loc(type_exp))? EQ body=expr - { let (idxvars, tyvars) = odfl ([], []) tvs in + { let (idxvars, nt_tv) = tvs in { nt_name = x; nt_idx = idxvars; - nt_tv = tvs |> omap (fun _ -> tyvars); + nt_tv = nt_tv; nt_bd = odfl [] bd; nt_args = args; nt_codom = ofdfl (fun () -> mk_loc (loc body) PTunivar) codom; @@ -2059,15 +2005,15 @@ abrvopts: | opts=bracket(abrvopt+) { opts } abbreviation: -| locality=loc(locality) ABBREV opts=abrvopts? x=oident tvs=mixed_tyvars_decl? +| locality=loc(locality) ABBREV opts=abrvopts? x=oident tvs=ix_ty_binder args=ptybindings_decl? sty=prefix(COLON, loc(type_exp))? EQ b=expr { let sty = sty |> ofdfl (fun () -> mk_loc (loc b) PTunivar) in - let (idxvars, tyvars) = odfl ([], []) tvs in + let (idxvars, ab_tv) = tvs in { ab_name = x; ab_idx = idxvars; - ab_tv = tvs |> omap (fun _ -> tyvars); + ab_tv = ab_tv; ab_args = odfl [] args; ab_def = (sty, b); ab_opts = odfl [] opts; @@ -2082,12 +2028,11 @@ mempred_binding: lemma_decl: | x=ident - tvs=mixed_tyvars_decl? + tvs=ix_ty_binder predvars=mempred_binding? pd=pgtybindings? COLON f=form - { let (idxvars, tyvars) = odfl ([], []) tvs in - let tyvars = tvs |> omap (fun _ -> tyvars) in + { let (idxvars, tyvars) = tvs in (x, idxvars, tyvars, predvars, pd, f) } axiom_tc: diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 048b84360f..6197df061b 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2309,7 +2309,7 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = match tyd.tyd_params.idxvars with | [] -> () | ids -> - Format.fprintf fmt "[%a] " (pp_list "@ " (pp_tyvar ppe)) ids + Format.fprintf fmt "{%a} " (pp_list "@ " (pp_tyvar ppe)) ids in let pp_prelude fmt = @@ -2360,16 +2360,28 @@ let pp_tyvarannot (ppe : PPEnv.t) fmt (ids: EcIdent.t list) = | [] -> () | ids -> Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar ppe)) ids -(* Mixed [n 'a] binder annotation. Idxvars print first (no apostrophe), - then tyvars (apostrophed via [pp_tyvar]). Whitespace-separated to - match the input syntax. *) +(* Combined `{n} ['a]` binder annotation. Indices print in curly + braces (first), then type variables in square brackets. Each part + is omitted entirely when empty, and a single space is inserted + between them when both are present. *) let pp_paramsannot (ppe : PPEnv.t) fmt (idxvars, tyvars) = + let pp_idx fmt = + match idxvars with + | [] -> () + | _ -> + Format.fprintf fmt "{%a}" (pp_list "@ " (pp_tyvar ppe)) idxvars + in + let pp_ty fmt = + match tyvars with + | [] -> () + | _ -> + Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar ppe)) tyvars + in match idxvars, tyvars with | [], [] -> () - | _ -> - Format.fprintf fmt "[%a]" - (pp_list "@ " (pp_tyvar ppe)) - (idxvars @ tyvars) + | _ , [] -> pp_idx fmt + | [], _ -> pp_ty fmt + | _ , _ -> Format.fprintf fmt "%t %t" pp_idx pp_ty let pp_pvar (ppe : PPEnv.t) fmt ids = match ids with diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 2d9f5c86ad..02f4b5cc7c 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -1,15 +1,16 @@ (* -------------------------------------------------------------------- *) (* Phase-3 Slice A — concrete syntax for indexed types. - Indices live in [...] (no apostrophe); applications use <:...:>. *) + Index binders use `{...}` and come first; type-variable binders + stay in `[...]`. Type-application indices use `<:...>`. *) (* Bare indexed type (no type parameters). *) -type [n] vec0. +type {n} vec0. (* Indexed and parametric. *) -type [n] 'a vec. +type {n} 'a vec. (* Multiple indices, multiple type parameters. *) -type [n m] ('a, 'b) mat. +type {n m} ('a, 'b) mat. (* Fully-applied (no free index variable): integer literals. *) type three_vec = int vec<:3>. @@ -21,67 +22,58 @@ type tagged = int vec<:1+1>. type two_three = int vec<:2*3>. (* Index variables in scope, used in the body. *) -type [n] 'a my_vec = 'a vec<:n>. -type [n m] 'a my_pair = 'a vec<:n+m>. - -(* Phase-3 Slice B — indices on operator / predicate / axiom binders. - Indexed application at use sites is not yet supported (it would - need TIUnivar-based index inference); the binders themselves - parse and typecheck. *) -op ix_op [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>. -pred ix_pr [n 'a] : 'a vec<:n>. -axiom ix_ax [n 'a] : true. - -(* Phase-3.5 — index inference at op-application sites. - Allocates fresh TIUnivars for each idxvar of the op being called - and unifies them against the call site via polynomial-normal-form - equality. *) -op concat [n m 'a] (xs : 'a vec<:n>) (ys : 'a vec<:m>) : 'a vec<:n+m>. -op cons [n 'a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. +type {n} 'a my_vec = 'a vec<:n>. +type {n m} 'a my_pair = 'a vec<:n+m>. + +(* Phase-3 Slice B — indices on operator / predicate / axiom binders. *) +op ix_op {n} ['a] (xs : 'a vec<:n>) : 'a vec<:n+1>. +pred ix_pr {n} ['a] : 'a vec<:n>. +axiom ix_ax {n} ['a] : true. + +(* Phase-3.5 — index inference at op-application sites. *) +op concat {n m} ['a] (xs : 'a vec<:n>) (ys : 'a vec<:m>) : 'a vec<:n+m>. +op cons {n} ['a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. (* Direct call: ?u_n in cons unifies with caller's n. *) -op single [n 'a] (x : 'a) (ys : 'a vec<:n>) : 'a vec<:n+1> = cons x ys. +op single {n} ['a] (x : 'a) (ys : 'a vec<:n>) : 'a vec<:n+1> = cons x ys. (* Annotated result type identical to the inferred one. *) -op test1 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) +op test1 {n m} ['a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) : 'a vec<:(n+1)+m> = concat (cons x ys) zs. (* Same body, but the annotated result type differs by associativity: (n+1)+m vs n+(1+m). Polynomial normalisation makes them equal. *) -op test2 [n m 'a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) +op test2 {n m} ['a] (x : 'a) (ys : 'a vec<:n>) (zs : 'a vec<:m>) : 'a vec<:n+(1+m)> = concat (cons x ys) zs. -(* Phase 4 — cloning with index instantiation. - `clone with type [k] 'a vec = body` substitutes every occurrence of - the indexed type, binding the source's idxvars to the call-site - index expressions when the body references them. *) -type [k] 'a coll. +(* Phase 4 — cloning with index instantiation. *) +type {k} 'a coll. theory ClonedT. - type [n] 'a target. + type {n} 'a target. end ClonedT. (* Drop the index, use a non-indexed type. *) clone ClonedT as Erased with - type [k] 'a target = int. + type {k} 'a target = int. (* Propagate the index through to another indexed type. *) clone ClonedT as Forwarded with - type [k] 'a target = 'a coll<:k>. + type {k} 'a target = 'a coll<:k>. (* Use a polynomial of the binder. *) clone ClonedT as Bumped with - type [k] 'a target = 'a coll<:k+1>. + type {k} 'a target = 'a coll<:k+1>. (* Gap A — explicit index instantiation at op call sites. Syntax: f[:idx, ...] for indices, optionally followed by <:ty>. *) -op size [n 'a] (xs : 'a vec<:n>) : int. -op count [n 'a] : int. +op size {n} ['a] (xs : 'a vec<:n>) : int. +op count {n} ['a] : int. (* index inferred from xs's type *) -op a_test1 [n 'a] (xs : 'a vec<:n>) : int = size xs. +op a_test1 {n} ['a] (xs : 'a vec<:n>) : int = size xs. (* index supplied explicitly *) op a_test2 ['a] (xs : 'a vec<:5>) : int = size[:5] xs. @@ -89,29 +81,22 @@ op a_test2 ['a] (xs : 'a vec<:5>) : int = size[:5] xs. (* both index and type explicit (no inference path for either) *) op a_test3 : int = count[:5]<:int>. -(* Gap B — polynomial unification beyond naked TIUnivar. - The unifier can solve any equation where exactly one TIUnivar - appears with coefficient ±1 and the residual stays non-negative. *) - -op tail [n 'a] (xs : 'a vec<:n+1>) : 'a vec<:n>. +(* Gap B — polynomial unification beyond naked TIUnivar. *) +op tail {n} ['a] (xs : 'a vec<:n+1>) : 'a vec<:n>. (* Caller passes a vector of length 5; n must be inferred so that - n+1 = 5, i.e. n = 4. The naked-univar special case used to fail - here because ?u_n was not on its own. *) + n+1 = 5, i.e. n = 4. *) op b_test1 ['a] (xs : 'a vec<:5>) : 'a vec<:4> = tail xs. (* Unification of [?u_n + 1] against [m + 5] forces ?u_n = m + 4. *) -op b_test2 [m 'a] (xs : 'a vec<:m+5>) : 'a vec<:m+4> = tail xs. +op b_test2 {m} ['a] (xs : 'a vec<:m+5>) : 'a vec<:m+4> = tail xs. (* Symmetric form: univar on the rhs of the equation. *) -op head [n 'a] (xs : 'a vec<:n+1>) : 'a. +op head {n} ['a] (xs : 'a vec<:n+1>) : 'a. op b_test3 ['a] (xs : 'a vec<:7>) : 'a = head xs. (* Gap C — non-refining indexed datatypes and records. *) - -(* Indexed datatype: constructor result type carries the index; - index unification at constructor application sites recovers it. *) -type [n] 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. +type {n} 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. op c_test1 : int ivec<:0> = INil. op c_test2 (x : int) (xs : int ivec<:5>) : int ivec<:5> = ICons x xs. @@ -124,26 +109,20 @@ op c_test3 (xs : int ivec<:5>) : int = end. (* Matchfix on indexed datatype with index binder on the op itself. *) -op c_test4 [n] (d : int) (xs : int ivec<:n>) : int = +op c_test4 {n} (d : int) (xs : int ivec<:n>) : int = with xs = INil => d with xs = ICons y _ => y. -(* Indexed record. Auto-generated constructor [mk_irec] and projectors - [`ivalue], [`idummy] all carry the index. *) -type [n] 'a irec = { ivalue : 'a; idummy : 'a ivec<:n> }. +(* Indexed record. *) +type {n} 'a irec = { ivalue : 'a; idummy : 'a ivec<:n> }. op c_test5 (x : int) (xs : int ivec<:0>) : int irec<:0> = {| ivalue = x; idummy = xs |}. op c_test6 (r : int irec<:7>) : int = r.`ivalue. -(* Gap F — SMT translation via per-index monomorphisation. - Concrete indices turn `vec<:3>` into a fresh Why3 sort `vec_3`. - Goals that mention only concrete indices make it through to SMT; - goals with free index variables still fall cleanly into the - [CanNotTranslate] skip (no crash, no proof, per-goal skip). *) - -op vfn [n] : int vec<:n>. +(* Gap F — SMT translation via per-index monomorphisation. *) +op vfn {n} : int vec<:n>. lemma f_test1 : vfn[:5] = vfn[:5]. proof. smt(). qed. @@ -158,24 +137,22 @@ op f_vec5 : int vec<:5>. lemma f_test3 : f_vec3 = f_vec3 /\ f_vec5 = f_vec5. proof. smt(). qed. -(* Lemmas can take index binders alongside type binders in the same - bracket: [n 'a] or ['a n], shared syntax with op binders. SMT +(* Lemmas accept the same `{n} ['a]` binder syntax as ops. SMT translation skips goals with bound (non-closed) indices, so these are discharged with [trivial] rather than [smt()]. *) -lemma f_test4 ['a n] (x : 'a) (xs : 'a vec<:n>) : +lemma f_test4 {n} ['a] (x : 'a) (xs : 'a vec<:n>) : cons x xs = cons x xs. proof. trivial. qed. -lemma f_test5 ['a n] : +lemma f_test5 {n} ['a] : forall (x : 'a) (xs : 'a vec<:n>), cons x xs = cons x xs. proof. move => x xs; trivial. qed. -(* The op-leading bracket is normally for tags (opaque / smt_opaque). - When it contains anything else, the parser reinterprets it as an - idxvar binder so users don't have to remember the after-name - placement when defining infix-style operators. *) -op [n] "_.[_]" (w : int vec<:n>) (_ : int) : bool. +(* Index binders come AFTER the operator name, like type binders. + No ambiguity with the leading [opaque] tag bracket because indices + use a different bracket family. *) +op "_.[_]" {n} (w : int vec<:n>) (_ : int) : bool. -(* Tags-before-name still work for the recognised tag set. *) +(* Tags use the existing leading bracket. *) op [opaque] g_const : int = 42. op [opaque smt_opaque] g_const2 : int = 7. From f75a3016ab3bd2e8bfc0ceefacd1734ffa804755 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 09:48:45 +0200 Subject: [PATCH 22/40] indexed-types: bound idxvars are also int-typed formula locals When an axiom / lemma / op / pred / abbreviation / notation binds an idxvar [n] via {n}, the same ident now also resolves as an int-typed local in the body of that declaration. Previously [n] was only reachable in tindex positions like vec<:n>; using it as an integer term (e.g. mkseq f n) failed with "unknown variable n". This realises the Phase-2 design choice that idxvars and formula-locals share a namespace: an idxvar is exactly an integer binding, and the indexer / formula machinery agree on the ident. New helper EcTyping.bind_idx_locals env ue pulls the idxvars out of the unienv's tparams and binds each as a (id, tint) local in env. Called immediately after every transtyvars ~idxparams site: ecScope.add_r (axiom/lemma), ecScope op processing, ecHiPredicates.trans_preddecl_r, ecHiNotations.trans_notation_r, and ecHiNotations.trans_abbrev_r. Verified with the original report case and a new regression in tests/indexed-types.ec exercising [size (id_bits[:n] v) = n + 0]. --- src/ecHiNotations.ml | 2 ++ src/ecHiPredicates.ml | 1 + src/ecScope.ml | 2 ++ src/ecTyping.ml | 13 +++++++++++++ src/ecTyping.mli | 5 +++++ tests/indexed-types.ec | 11 +++++++++++ 6 files changed, 34 insertions(+) diff --git a/src/ecHiNotations.ml b/src/ecHiNotations.ml index 62461d6fc0..509766bbdd 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -31,6 +31,7 @@ let trans_abbrev_opts (opts : abrvopts) = let trans_notation_r (env : env) (nt : pnotation located) = let nt = nt.pl_desc and gloc = nt.pl_loc in let ue = TT.transtyvars ~idxparams:nt.nt_idx env (gloc, nt.nt_tv) in + let env = TT.bind_idx_locals env ue in (* Translate bound idents and their types *) let bd = List.mapi (fun i (x, pty) -> @@ -76,6 +77,7 @@ let trans_notation (env : EcEnv.env) (nt : pnotation located) = let trans_abbrev_r (env : env) (at : pabbrev located) = let at = at.pl_desc and gloc = at.pl_loc in let ue = TT.transtyvars ~idxparams:at.ab_idx env (gloc, at.ab_tv) in + let env = TT.bind_idx_locals env ue in let benv, xs = TT.trans_binding env ue at.ab_args in let codom = TT.transty TT.tp_relax env ue (fst at.ab_def) in let body = TT.transexpcast benv `InOp ue codom (snd at.ab_def) in diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index 3b53282722..e1ab371b29 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -42,6 +42,7 @@ let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = let pr = pr.pl_desc and loc = pr.pl_loc in let ue = TT.transtyvars ~idxparams:pr.pp_idxvars env (loc, pr.pp_tyvars) in + let env = TT.bind_idx_locals env ue in let tp = TT.tp_relax in let dom, body = diff --git a/src/ecScope.ml b/src/ecScope.ml index 65c63bcebb..6331c848b3 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -975,6 +975,7 @@ module Ax = struct let loc = ax.pl_loc and ax = ax.pl_desc in let ue = TT.transtyvars ~idxparams:ax.pa_idxvars env (loc, ax.pa_tyvars) in + let env = TT.bind_idx_locals env ue in let (pconcl, tintro) = match ax.pa_vars with @@ -1280,6 +1281,7 @@ module Op = struct let eenv = env scope in let ue = TT.transtyvars ~idxparams:op.po_idxvars eenv (loc, op.po_tyvars) in + let eenv = TT.bind_idx_locals eenv ue in let lc = op.po_locality in let args = fst op.po_args @ odfl [] (snd op.po_args) in let (ty, body, refts) = diff --git a/src/ecTyping.ml b/src/ecTyping.ml index b7bdba577c..a5dfdffc69 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -518,6 +518,19 @@ let transtyvars in EcUnify.UniEnv.create params +(* Bind every idxvar of [ue] as an int-typed formula-local in [env]. + This lets a bound idxvar [n] be referenced both as an index (in + `vec<:n>` positions, via [ue_idxnamed]) and as an integer term in + the body of an axiom / lemma / op / predicate. The ident is the + same in both roles, so substitutions stay coherent. *) +let bind_idx_locals (env : EcEnv.env) (ue : EcUnify.unienv) : EcEnv.env = + let idxs = (EcUnify.UniEnv.tparams ue).idxvars in + if List.is_empty idxs then env + else + EcEnv.Var.bind_locals + (List.map (fun id -> (id, tint)) idxs) + env + (* -------------------------------------------------------------------- *) exception TymodCnvFailure of tymod_cnv_failure diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 98967ae7ec..3e2d3808c6 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -197,6 +197,11 @@ val transtyvars: ?idxparams:psymbol list -> env -> (EcLocation.t * ptyparams option) -> EcUnify.unienv +(* Bind every idxvar of the unienv as an int-typed formula-local in + the env, so that a bound idxvar [n] can also appear as an integer + term in the body of the surrounding declaration. *) +val bind_idx_locals : env -> EcUnify.unienv -> env + (* -------------------------------------------------------------------- *) val transty : typolicy -> env -> EcUnify.unienv -> pty -> ty diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 02f4b5cc7c..dbf27d58a2 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -156,3 +156,14 @@ op "_.[_]" {n} (w : int vec<:n>) (_ : int) : bool. (* Tags use the existing leading bracket. *) op [opaque] g_const : int = 42. op [opaque smt_opaque] g_const2 : int = 7. + +(* Bound idxvars are visible as int-typed formula locals in the body + of axioms / lemmas / ops / preds / abbreviations. The same ident + plays both roles: index in `vec<:n>` positions, and integer term + in the surrounding formula. *) +require import AllCore List. + +op id_bits {n} : int vec<:n> -> int list. + +axiom id_size {n} (v : int vec<:n>) : + size (id_bits[:n] v) = n + 0. From 525119d0bfb5c378af6f7b126e0e81e0c0836f06 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 10:21:35 +0200 Subject: [PATCH 23/40] =?UTF-8?q?indexed-types:=20rewrite/apply=20on=20ind?= =?UTF-8?q?exed=20lemmas=20=E2=80=94=20substitute=20idx-univars?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two related fixes that together let `rewrite L` and `apply L` work on lemmas declared over indexed types. 1. PTGlobal carries indices. The proof-term head `PTGlobal of EcPath.path * (ty list)` becomes `PTGlobal of EcPath.path * (tindex list) * (ty list)`. The constructor `ptglobal` and the alias `paglobal` gain an optional `?idxs` argument (default `[]`, so non-indexed call sites are source-compatible). `EcEnv.Ax.instantiate` also gains `?idxs`, substituting the lemma's idxvars in the spec. Without this, the proof checker re-instantiated only tyvars and the residual idxvars in the body broke conversion against the goal. 2. Closing a unienv now substitutes index-univars too. New helper `EcUnify.UniEnv.close_subst : unienv -> f_subst` builds a complete `f_subst` carrying both `~tu` (type-univars, as before) and `~iu` (index-univars). Used at the axiom-saving and op-saving sites in ecScope. Previously `Tuni.subst (close ue)` left every `TIUnivar` in the saved AST untouched, so even after the unifier resolved `?u_n := n_lem` the operator-type signatures inside the axiom's body still carried `?u_n`. Two `bits w` nodes that printed identically had different fresh univars and failed `is_conv`. Supporting infra: - `EcUnify.UniEnv.openidx` is exposed in the .mli (was private). Both `pt_of_uglobal_r` and `process_named_pterm` in ecProofTerm now open the lemma's idxvars to fresh `TIUnivar`s alongside its tyvars and thread both maps through `f_subst_init` to substitute the spec. - `EcMatching.MEV.assubst` adds `~iu:(iu_assubst ue)` so concretize resolves index-univars in the proof term and its formula together. - `EcMatching` `Fop` matching uses `unify_idx` for index lists (exposed in `EcUnify`) instead of structural `tindex_equal`. Verified: the user's `bits_cat` rewrite, `exact (test_eq w)` apply, and a new regression in tests/indexed-types.ec all work; full regression (184 decls) passes; non-indexed lemmas/rewrites unchanged. --- src/ecCoreGoal.ml | 10 +++++----- src/ecCoreGoal.mli | 10 +++++++--- src/ecEnv.ml | 26 ++++++++++++++++++++++++-- src/ecEnv.mli | 3 ++- src/ecLowGoal.ml | 5 ++--- src/ecMatching.ml | 12 +++++++++--- src/ecProofTerm.ml | 37 ++++++++++++++++++++++++++----------- src/ecScope.ml | 6 ++---- src/ecUnify.ml | 19 +++++++++++++++++++ src/ecUnify.mli | 13 +++++++++++++ tests/indexed-types.ec | 14 ++++++++++++++ 11 files changed, 123 insertions(+), 32 deletions(-) diff --git a/src/ecCoreGoal.ml b/src/ecCoreGoal.ml index 74ff095f5b..6fd33724d5 100644 --- a/src/ecCoreGoal.ml +++ b/src/ecCoreGoal.ml @@ -51,7 +51,7 @@ and pt_head = | PTCut of EcFol.form * cutsolve option | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * (tindex list) * (ty list) | PTTerm of proofterm and cutsolve = [`Done | `Smt | `DoneSmt] @@ -81,8 +81,8 @@ let pamemory = fun x -> PAMemory x let pamodule = fun x -> PAModule x (* -------------------------------------------------------------------- *) -let ptglobal ?(args = []) ~tys p = - PTApply { pt_head = PTGlobal (p, tys); pt_args = args; } +let ptglobal ?(args = []) ?(idxs = []) ~tys p = + PTApply { pt_head = PTGlobal (p, idxs, tys); pt_args = args; } let ptlocal ?(args = []) x = PTApply { pt_head = PTLocal x; pt_args = args; } @@ -94,8 +94,8 @@ let ptcut ?(args = []) ?(cutsolve : cutsolve option) f = PTApply { pt_head = PTCut (f, cutsolve); pt_args = args; } (* -------------------------------------------------------------------- *) -let paglobal ?args ~tys p = - PASub (Some (ptglobal ?args ~tys p)) +let paglobal ?args ?idxs ~tys p = + PASub (Some (ptglobal ?args ?idxs ~tys p)) let palocal ?args x = PASub (Some (ptlocal ?args x)) diff --git a/src/ecCoreGoal.mli b/src/ecCoreGoal.mli index f574b49bf3..0963254272 100644 --- a/src/ecCoreGoal.mli +++ b/src/ecCoreGoal.mli @@ -53,7 +53,7 @@ and pt_head = | PTCut of EcFol.form * cutsolve option | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * (tindex list) * (ty list) | PTTerm of proofterm and cutsolve = [`Done | `Smt | `DoneSmt] @@ -82,12 +82,16 @@ val pamemory : EcMemory.memory -> pt_arg val pamodule : EcPath.mpath * EcModules.module_sig -> pt_arg (* -------------------------------------------------------------------- *) -val paglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> pt_arg +val paglobal : + ?args:pt_arg list -> ?idxs:tindex list -> tys:ty list + -> EcPath.path -> pt_arg val palocal : ?args:pt_arg list -> EcIdent.t -> pt_arg val pahandle : ?args:pt_arg list -> handle -> pt_arg (* -------------------------------------------------------------------- *) -val ptglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> proofterm +val ptglobal : + ?args:pt_arg list -> ?idxs:tindex list -> tys:ty list + -> EcPath.path -> proofterm val ptlocal : ?args:pt_arg list -> EcIdent.t -> proofterm val pthandle : ?args:pt_arg list -> handle -> proofterm val ptcut : ?args:pt_arg list -> ?cutsolve:cutsolve -> EcFol.form -> proofterm diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 8e8e5e32d9..1425668fae 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2794,10 +2794,32 @@ module Ax = struct let rebind name ax env = MC.bind_axiom name ax env - let instantiate p tys env = + let instantiate ?(idxs : tindex list = []) p tys env = match by_path_opt p env with | Some ({ ax_spec = f } as ax) -> - Tvar.f_subst ~freshen:true ax.ax_tparams.tyvars tys f + let tparams = ax.ax_tparams in + if List.compare_lengths idxs tparams.idxvars <> 0 + && not (List.is_empty idxs) then + raise (LookupFailure (`Path p)); + let idx_map = + if List.is_empty idxs then EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.idxvars idxs + in + let tv_map = + if List.compare_lengths tys tparams.tyvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.tyvars tys + in + let fs = + EcCoreSubst.Fsubst.f_subst_init + ~freshen:true ~tv:tv_map ~idx:idx_map () in + EcCoreSubst.Fsubst.f_subst fs f | _ -> raise (LookupFailure (`Path p)) let iter ?name f (env : env) = diff --git a/src/ecEnv.mli b/src/ecEnv.mli index b69186e298..553b03bfce 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -168,7 +168,8 @@ module Ax : sig val iter : ?name:qsymbol -> (path -> t -> unit) -> env -> unit val all : ?check:(path -> t -> bool) -> ?name:qsymbol -> env -> (path * t) list - val instantiate : path -> EcTypes.ty list -> env -> form + val instantiate : + ?idxs:EcAst.tindex list -> path -> EcTypes.ty list -> env -> form end (* -------------------------------------------------------------------- *) diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 360ff21b64..7aa654da86 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -165,10 +165,10 @@ module LowApply = struct with LDecl.LdeclError _ -> raise InvalidProofTerm end - | PTGlobal (p, tys) -> + | PTGlobal (p, idxs, tys) -> (* FIXME: poor API ==> poor error recovery *) let env = LDecl.toenv (hyps_of_ckenv tc) in - (pt, EcEnv.Ax.instantiate p tys env, subgoals) + (pt, EcEnv.Ax.instantiate ~idxs p tys env, subgoals) | PTTerm pt -> let pt, ax, subgoals = check_ `Elim pt subgoals tc in @@ -680,7 +680,6 @@ let tt_apply ?(cutsolver : cutsolver option) (pt : proofterm) (tc : tcenv) = (* let env = FApi.tc_env tc in let ppe = EcPrinting.PPEnv.ofenv env in - (* FIXME: add this to the exception *) Format.eprintf "%a@.should be convertible to:@.%a@.but is not@." (EcPrinting.pp_form ppe) ax (EcPrinting.pp_form ppe) concl; diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 5e849fb163..8c68f443ce 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -461,7 +461,11 @@ module MEV = struct v let assubst ue ev env = - let subst = f_subst_init ~tu:(EcUnify.UniEnv.assubst ue) () in + let subst = + f_subst_init + ~tu:(EcUnify.UniEnv.assubst ue) + ~iu:(EcUnify.UniEnv.iu_assubst ue) + () in let subst = EV.fold (fun x m s -> Fsubst.f_bind_mem s x m) ev.evm_mem subst in let subst = EV.fold (fun x mp s -> EcFol.f_bind_mod s x mp env) ev.evm_mod subst in let seen = ref Sid.empty in @@ -683,9 +687,11 @@ let f_match_core opts hyps (ue, ev) f1 f2 = failure (); if List.compare_lengths tys1.indices tys2.indices <> 0 then failure (); - if not (List.all2 tindex_equal tys1.indices tys2.indices) then + if List.compare_lengths tys1.types tys2.types <> 0 then failure (); - try List.iter2 (EcUnify.unify env ue) tys1.types tys2.types + try + List.iter2 (EcUnify.unify_idx env ue) tys1.indices tys2.indices; + List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index d296cf4857..6647f53ae3 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -137,7 +137,10 @@ and concretize_e_head ((CPTEnv subst) as cptenv) head = | PTCut (f, s) -> PTCut (Fsubst.f_subst subst f, s) | PTHandle h -> PTHandle h | PTLocal x -> PTLocal x - | PTGlobal (p, tys) -> PTGlobal (p, List.map (ty_subst subst) tys) + | PTGlobal (p, idxs, tys) -> + PTGlobal (p, + List.map (EcCoreSubst.tindex_subst subst) idxs, + List.map (ty_subst subst) tys) | PTTerm pt -> PTTerm (concretize_e_pt cptenv pt) and concretize_e_pt ((CPTEnv subst) as cptenv) pt = @@ -223,12 +226,18 @@ let pt_of_uglobal_r ptenv p = let typ, ax = (ax.EcDecl.ax_tparams, ax.EcDecl.ax_spec) in (* FIXME: TC HOOK *) - let fs = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in - let ax = Fsubst.f_subst_tvar ~freshen:true fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ.tyvars in + let tv = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in + let ix = EcUnify.UniEnv.openidx ptenv.pte_ue typ None in + let ax = + let fs = + EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx:ix () in + EcCoreSubst.Fsubst.f_subst fs ax + in + let idxs = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in + let typ = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys:typ p; + ptev_pt = ptglobal ~idxs ~tys:typ p; ptev_ax = ax; } (* -------------------------------------------------------------------- *) @@ -513,11 +522,17 @@ let process_named_pterm pe (tvi, fp) = PT.pf_check_tvi pe.pte_pe typ tvi; (* FIXME: TC HOOK *) - let fs = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in - let ax = Fsubst.f_subst_tvar ~freshen:false fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ.tyvars in + let tv = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in + let ix = EcUnify.UniEnv.openidx pe.pte_ue typ tvi in + let ax = + let fs = + EcCoreSubst.Fsubst.f_subst_init ~freshen:false ~tv ~idx:ix () in + EcCoreSubst.Fsubst.f_subst fs ax + in + let typ_out = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in + let idxs_out = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in - (p, (typ, ax)) + (p, (idxs_out, typ_out, ax)) (* ------------------------------------------------------------------ *) let process_pterm_cut ~prcut pe pt = @@ -525,8 +540,8 @@ let process_pterm_cut ~prcut pe pt = match pt with | FPNamed (fp, tyargs) -> begin match process_named_pterm pe (tyargs, fp) with - | (`Local x, ([] , ax)) -> (PTLocal x, ax) - | (`Global p, (typ, ax)) -> (PTGlobal (p, typ), ax) + | (`Local x, ([], [] , ax)) -> (PTLocal x, ax) + | (`Global p, (idxs, typ, ax)) -> (PTGlobal (p, idxs, typ), ax) | _ -> assert false end diff --git a/src/ecScope.ml b/src/ecScope.ml index 6331c848b3..c1944b98bd 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -997,8 +997,7 @@ module Ax = struct if not (EcUnify.UniEnv.closed ue) then hierror "the formula contains free type variables"; - let uidmap = EcUnify.UniEnv.close ue in - let fs = Tuni.subst uidmap in + let fs = EcUnify.UniEnv.close_subst ue in let concl = Fsubst.f_subst fs concl in let tparams = EcUnify.UniEnv.tparams ue in @@ -1319,8 +1318,7 @@ module Op = struct if not (EcUnify.UniEnv.closed ue) then hierror ~loc "this operator type contains free type variables"; - let uidmap = EcUnify.UniEnv.close ue in - let ts = Tuni.subst uidmap in + let ts = EcUnify.UniEnv.close_subst ue in let fs = Fsubst.f_subst ts in let ty = ty_subst ts ty in let tparams = EcUnify.UniEnv.tparams ue in diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 58317af041..e3e759fd80 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -485,6 +485,19 @@ module UniEnv = struct let iu_assubst (ue : unienv) : tindex Muid.t = (!ue).ue_iuf + (* Build a full [f_subst] that resolves both type-univars and + index-univars in one shot. Use this where the legacy + [Tuni.subst (close ue)] is followed by an [f_subst] application + to a type or formula that may carry indexed types — without the + idx-univar substitution, [TIUnivar] nodes survive into the saved + AST and break later matching. *) + let close_subst (ue : unienv) : f_subst = + if not (closed ue) then raise UninstantiateUni; + f_subst_init + ~tu:(subst_of_uf (!ue).ue_uf) + ~iu:(!ue).ue_iuf + () + let tparams (ue : unienv) : ty_params = { idxvars = List.rev (!ue).ue_idxdecl; tyvars = List.rev (!ue).ue_decl; } @@ -494,6 +507,12 @@ end let unify (env : EcEnv.env) (ue : unienv) (t1 : ty) (t2 : ty) = unify_core env ue (`TyUni (t1, t2)) +(* Index unification — same engine, different problem kind. Used by + the matching engine to match [Tconstr (p, {indices=...; types=...})] + patterns where indices may carry univars. *) +let unify_idx (env : EcEnv.env) (ue : unienv) (i1 : tindex) (i2 : tindex) = + unify_core env ue (`IxUni (i1, i2)) + (* -------------------------------------------------------------------- *) let tfun_expected ue ?retty psig = let retty = ofdfl (fun () -> UniEnv.fresh ue) retty in diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 07fa80414c..6bd79476c7 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -30,6 +30,10 @@ module UniEnv : sig val getnamed_idx : unienv -> symbol -> EcIdent.t option val repr : unienv -> ty -> ty val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t + (* Allocate a tindex for each idxvar of [params]: a fresh TIUnivar + when [tvi] supplies no explicit indices, the user-provided index + otherwise. *) + val openidx : unienv -> ty_params -> tvi -> tindex EcIdent.Mid.t val openty : unienv -> ty_params -> tvi -> ty -> ty * ty list val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * ty list val closed : unienv -> bool @@ -38,11 +42,20 @@ module UniEnv : sig (* Index-univar resolved assignment map (Phase 3.5). *) val iu_close : unienv -> tindex Muid.t val iu_assubst : unienv -> tindex Muid.t + (* Build a complete [f_subst] resolving both type-univars and + index-univars. Use this in place of [Tuni.subst (close ue)] + when the substituted form may carry indexed types. *) + val close_subst : unienv -> EcCoreSubst.f_subst val tparams : unienv -> ty_params end val unify : EcEnv.env -> unienv -> ty -> ty -> unit +(* Index unification — same engine as [unify], for index polynomials. + Solves naked-univar assignments and Gap-B "?u + k = poly" cases; + raises [UnificationFailure (`IxUni _)] on failure. *) +val unify_idx : EcEnv.env -> unienv -> tindex -> tindex -> unit + val tfun_expected : unienv -> ?retty:ty -> EcTypes.ty list -> EcTypes.ty type sbody = ((EcIdent.t * ty) list * expr) Lazy.t diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index dbf27d58a2..6410632daa 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -167,3 +167,17 @@ op id_bits {n} : int vec<:n> -> int list. axiom id_size {n} (v : int vec<:n>) : size (id_bits[:n] v) = n + 0. + +(* Rewrite tactic on indexed lemmas: opening an indexed lemma must + substitute through both type-univars AND index-univars in its + stored body, otherwise residual TIUnivars leak into operator + signatures and the matcher sees two distinct nodes that print + identically but fail to unify. *) +op cat_words {m n} (wm : int vec<:m>) (wn : int vec<:n>) : int vec<:m+n>. + +axiom cat_words_self {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + cat_words wm wn = cat_words wm wn. + +lemma cat_test {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + cat_words wm wn = cat_words wm wn. +proof. rewrite cat_words_self. trivial. qed. From ce74882ac5031decf01759e815249ffc916320ec Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 10:51:06 +0200 Subject: [PATCH 24/40] =?UTF-8?q?indexed-types:=20rewrite=20under=20op-unf?= =?UTF-8?q?old=20=E2=80=94=20propagate=20idxvars=20through=20Fop=20targs?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Three intertwined fixes for the user's [bits_cat] case: lemma catE {m n} (wm : word<:m>) (wn : word<:n>) (i : int) : 0 <= i < m + n => (wm ++ wn).[i] = if i < m then wm.[i] else wn.[i-m]. proof. move=> rgi @/"_.[_]". rewrite bits_cat. 1. Op application records call-site indices in Fop targs. `EcUnify.openty_r` now returns `(subst, ixs, tvs)` (was `(subst, tvs)`); `select_op` returns `(path, idxs, tys) * top * subue * sbody` (was `(path, tys)`); `EcTyping.OpSelect.opsel.\`Op` and `opmatch.\`Op` carry `path * tindex list * ty list`. `form_of_opselect` builds `f_op p ~indices:ixs ~tyargs:tys ty`. Without this the call- site indices were lost on Fop nodes — every `Fop` carried `targs.indices = []` regardless of how the op was applied. 2. Op unfolding substitutes both tyvars and idxvars in the body. `EcEnv.Op.reduce` was substituting only `tparams.tyvars`; now it builds an `f_subst` with both `~tv` and `~idx` maps so that every nested `Fop` in the unfolded body has its `targs.indices` and `f_ty` rewritten to use the call-site indices. 3. Matcher does not unify Fop indices on the head. The polynomial-against-polynomial `bits` head match (`?u_m + ?u_n` against `m + n`) is genuinely ambiguous when considered in isolation — multiple multi-univar Diophantine solutions. The Fop matcher now only unifies type arguments and trusts the surrounding `Fapp` arg matching to constrain indices via per-arg f_ty unification (matching `(++) wm wn` first sets `?u_m := m, ?u_n := n` individually, then `bits`'s polynomial head trivially matches by reduction). Every consumer of the new triple form was updated: ecHiInductive, ecPrinting, ecScope (3 sites), ecTyping (4 sites), ecUserMessages. Verified: full regression (202 decls) + new `unfold_then_rewrite` test exercising the bug pattern. --- src/ecEnv.ml | 21 ++++++++++++++++++++- src/ecHiInductive.ml | 2 +- src/ecMatching.ml | 8 +++++++- src/ecPrinting.ml | 2 +- src/ecScope.ml | 6 +++--- src/ecTyping.ml | 28 ++++++++++++++-------------- src/ecTyping.mli | 2 +- src/ecUnify.ml | 26 +++++++++++++++++++------- src/ecUnify.mli | 5 ++++- src/ecUserMessages.ml | 4 ++-- tests/indexed-types.ec | 18 ++++++++++++++++++ 11 files changed, 90 insertions(+), 32 deletions(-) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 1425668fae..67c2c9c77c 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2704,7 +2704,26 @@ module Op = struct let reduce ?mode ?nargs env p (tys : EcAst.targs) = let op, f = core_reduce ?mode ?nargs env p in - Tvar.f_subst ~freshen:true op.op_tparams.tyvars tys.types f + let tparams = op.op_tparams in + let tv = + if List.compare_lengths tys.types tparams.tyvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.tyvars tys.types + in + let idx = + if List.compare_lengths tys.indices tparams.idxvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.idxvars tys.indices + in + let fs = + EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx () in + EcCoreSubst.Fsubst.f_subst fs f let is_projection env p = try EcDecl.is_proj (by_path p env) diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 993d8a3a7f..434c0aa141 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -299,7 +299,7 @@ let trans_matchfix | _ :: _ :: _ -> fxerror cname.pl_loc env TT.FXE_CtorAmbiguous - | [(cp, tvi), opty, subue, _] -> + | [(cp, _idxs, tvi), opty, subue, _] -> let ctor = oget (EcEnv.Op.by_path_opt cp env) in let (indp, ctoridx) = EcDecl.operator_as_ctor ctor in let indty = oget (EcEnv.Ty.by_path_opt indp env) in diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 8c68f443ce..e4b303aca7 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -689,8 +689,14 @@ let f_match_core opts hyps (ue, ev) f1 f2 = failure (); if List.compare_lengths tys1.types tys2.types <> 0 then failure (); + (* Indices on Fop are redundant with f_ty (which is unified + at the surrounding Fapp via arg matching). Trying to unify + them here forces a polynomial-against-polynomial match + before the constraints from arg matching are available, + leading to ambiguous multi-univar Diophantine. We unify + the type arguments only and let the args provide the + remaining constraints. *) try - List.iter2 (EcUnify.unify_idx env ue) tys1.indices tys2.indices; List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 6197df061b..c90e8b78a9 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -239,7 +239,7 @@ module PPEnv = struct check_for_local sm; let ue = EcUnify.UniEnv.create None in match EcUnify.select_op ~hidden:true ~filter tvi ppe.ppe_env sm ue dom with - | [(p1, _), _, _, _] -> p1 + | [(p1, _, _), _, _, _] -> p1 | _ -> raise (EcEnv.LookupFailure (`QSymbol sm)) in let exists sm = diff --git a/src/ecScope.ml b/src/ecScope.ml index c1944b98bd..40f0e3b09d 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2366,9 +2366,9 @@ module Ty = struct | op1::op2::_ -> hierror ~loc:op.pl_loc "ambiguous operator (%s / %s)" - (EcPath.tostring (fst (proj4_1 op1))) - (EcPath.tostring (fst (proj4_1 op2))) - | [((p, _), _, _, _)] -> + (EcPath.tostring (proj3_1 (proj4_1 op1))) + (EcPath.tostring (proj3_1 (proj4_1 op2))) + | [((p, _, _), _, _, _)] -> let op = EcEnv.Op.by_path p env in let opty = Tvar.subst diff --git a/src/ecTyping.ml b/src/ecTyping.ml index a5dfdffc69..678f032673 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -22,7 +22,7 @@ module NormMp = EcEnv.NormMp (* -------------------------------------------------------------------- *) type opmatch = [ - | `Op of EcPath.path * EcTypes.ty list + | `Op of EcPath.path * EcAst.tindex list * EcTypes.ty list | `Lc of EcIdent.t | `Var of EcTypes.prog_var | `Proj of EcTypes.prog_var * EcMemory.proj_arg @@ -335,7 +335,7 @@ module OpSelect = struct type opsel = [ | `Pv of EcMemory.memory option * pvsel - | `Op of (EcPath.path * ty list) + | `Op of (EcPath.path * tindex list * ty list) | `Lc of EcIdent.ident | `Nt of EcUnify.sbody ] @@ -377,13 +377,13 @@ let gen_select_op | `Form -> fun _ _ -> true in - let by_scope opsc ((p, _), _, _, _) = + let by_scope opsc ((p, _, _), _, _, _) = EcPath.p_equal opsc (oget (EcPath.prefix p)) - and by_current ((p, _), _, _, _) = + and by_current ((p, _, _), _, _, _) = EcPath.isprefix ~prefix:(oget (EcPath.prefix p)) ~path:(EcEnv.root env) - and by_tc ((p, _), _, _, _) = + and by_tc ((p, _, _), _, _, _) = match oget (EcEnv.Op.by_path_opt p env) with | { op_kind = OB_oper (Some OP_TC) } -> false | _ -> true @@ -447,7 +447,7 @@ let select_proj env opsc name ue tvi recty = match ops, opsc with | _ :: _ :: _, Some opsc -> List.filter - (fun ((p, _), _, _) -> + (fun ((p, _, _), _, _) -> EcPath.p_equal opsc (oget (EcPath.prefix p))) ops @@ -1141,7 +1141,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let exn = UnknownRecFieldName (unloc name) in tyerror name.pl_loc env exn - | Some ((fp, _tvi), opty, subue, _) -> + | Some ((fp, _ixs, _tvi), opty, subue, _) -> let field = oget (EcEnv.Op.by_path_opt fp env) in let (recp, fieldidx, _) = EcDecl.operator_as_proj field in EcUnify.UniEnv.restore ~src:subue ~dst:ue; @@ -1283,7 +1283,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = let exn = UnknownRecFieldName (unloc rf.rf_name) in tyerror rf.rf_name.pl_loc env exn - | Some ((fp, _tvi), opty, subue, _) -> + | Some ((fp, _ixs, _tvi), opty, subue, _) -> let field = oget (EcEnv.Op.by_path_opt fp env) in let (recp, fieldidx, _) = EcDecl.operator_as_proj field in EcUnify.UniEnv.restore ~src:subue ~dst:ue; @@ -1378,7 +1378,7 @@ let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = | _ :: _ :: _ -> tyerror cname.pl_loc env (InvalidMatch FXE_CtorAmbiguous) - | [(cp, tvi), opty, subue, _] -> + | [(cp, _idxs, tvi), opty, subue, _] -> let ctor = oget (EcEnv.Op.by_path_opt cp env) in let (indp, ctoridx) = EcDecl.operator_as_ctor ctor in let indty = oget (EcEnv.Ty.by_path_opt indp env) in @@ -1689,8 +1689,8 @@ let form_of_opselect in (f_lambda flam (Fsubst.f_subst subst body), args) | (`Op _ | `Lc _ | `Pv _) as sel -> let op = match sel with - | `Op (p, tys) -> f_op p ~tyargs:tys ty - | `Lc id -> f_local id ty + | `Op (p, idxs, tys) -> f_op p ~indices:idxs ~tyargs:tys ty + | `Lc id -> f_local id ty | `Pv (me, pv) -> var_or_proj (fun x ty -> (f_pvar x ty (oget me)).inv) f_proj pv ty @@ -2886,7 +2886,7 @@ and translvalue ue (env : EcEnv.env) lvalue = let esig = Tuni.subst_dom uidmap esig in tyerror x.pl_loc env (UnknownVarOrOp (name, esig)) - | [`Op (p, tys), opty, subue, _] -> + | [`Op (p, _idxs, tys), opty, subue, _] -> EcUnify.UniEnv.restore ~src:subue ~dst:ue; let uidmap = UE.assubst ue in let esig = Tuni.subst_dom uidmap esig in @@ -3496,12 +3496,12 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = | _ :: _ :: _ -> tyerror x.pl_loc env (AmbiguousProj (unloc x)) - | [(op, tvi), pty, subue] -> + | [(op, ixs, tvi), pty, subue] -> EcUnify.UniEnv.restore ~src:subue ~dst:ue; let rty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (tfun subf.f_ty rty) pty with EcUnify.UnificationFailure _ -> assert false); - f_app (f_op op ~tyargs:tvi pty) [subf] rty + f_app (f_op op ~indices:ixs ~tyargs:tvi pty) [subf] rty end | PFproji (psubf, i) -> begin diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 3e2d3808c6..9407cdfe6f 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -14,7 +14,7 @@ open EcMatching.Position (* -------------------------------------------------------------------- *) type opmatch = [ - | `Op of EcPath.path * EcTypes.ty list + | `Op of EcPath.path * EcAst.tindex list * EcTypes.ty list | `Lc of EcIdent.t | `Var of EcTypes.prog_var | `Proj of EcTypes.prog_var * EcMemory.proj_arg diff --git a/src/ecUnify.ml b/src/ecUnify.ml index e3e759fd80..296ad3c328 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -442,20 +442,31 @@ module UniEnv = struct let subst_tv (subst : ty -> ty) (params : ty_params) = List.map (fun tv -> subst (tvar tv)) params.tyvars + (* Open the index params: build the [TIVar -> TIVar/TIUnivar] map, + then resolve each idxvar through it (so explicit user-supplied + indices come back as-is). Returned in [params.idxvars] order. *) + let subst_ix (idxmap : tindex Mid.t) (params : ty_params) = + List.map (fun id -> + Option.value (Mid.find_opt id idxmap) ~default:(TIVar id)) + params.idxvars + let openty_r (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = + let idxmap = openidx ue params tvi in let subst = f_subst_init ~tv:(opentvi ue params tvi) - ~idx:(openidx ue params tvi) + ~idx:idxmap () in - (subst, subst_tv (ty_subst subst) params) + let ixs = subst_ix idxmap params in + let tys = subst_tv (ty_subst subst) params in + (subst, ixs, tys) let opentys (ue : unienv) (params : ty_params) (tvi : tvar_inst option) (tys : ty list) = - let (subst, tvs) = openty_r ue params tvi in + let (subst, _, tvs) = openty_r ue params tvi in (List.map (ty_subst subst) tys, tvs) let openty (ue : unienv) (params : ty_params) (tvi : tvar_inst option) (ty : ty)= - let (subst, tvs) = openty_r ue params tvi in + let (subst, _, tvs) = openty_r ue params tvi in (ty_subst subst ty, tvs) let repr (ue : unienv) (t : ty) : ty = @@ -522,7 +533,8 @@ let tfun_expected ue ?retty psig = type sbody = ((EcIdent.t * ty) list * expr) Lazy.t (* -------------------------------------------------------------------- *) -type select_result = (EcPath.path * ty list) * ty * unienv * sbody option +type select_result = + (EcPath.path * tindex list * ty list) * ty * unienv * sbody option (* -------------------------------------------------------------------- *) let select_op @@ -569,7 +581,7 @@ let select_op let subue = UniEnv.copy ue in try - let (tip, tvs) = UniEnv.openty_r subue op.D.op_tparams tvi in + let (tip, ixs, tvs) = UniEnv.openty_r subue op.D.op_tparams tvi in let top = ty_subst tip op.D.op_ty in let texpected = tfun_expected subue ?retty psig in @@ -588,7 +600,7 @@ let select_op | _ -> None - in Some ((path, tvs), top, subue, bd) + in Some ((path, ixs, tvs), top, subue, bd) with E.Failure -> None diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 6bd79476c7..39f2d99650 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -60,7 +60,10 @@ val tfun_expected : unienv -> ?retty:ty -> EcTypes.ty list -> EcTypes.ty type sbody = ((EcIdent.t * ty) list * expr) Lazy.t -type select_result = (EcPath.path * ty list) * ty * unienv * sbody option +(* The first triple is [path * call-site indices * call-site types], + each in declaration order of the operator's tparams. *) +type select_result = + (EcPath.path * tindex list * ty list) * ty * unienv * sbody option val select_op : ?hidden:bool diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index a50a8f9cba..50f8a21f01 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -427,8 +427,8 @@ end = struct ("local variable", Cb (id, EcPrinting.pp_local env)) | `Proj (pv, _) -> ("variable proj.", Cb (pv, EcPrinting.pp_pv env)) - | `Op op -> - ("operator", Cb ((op, ue), pp_op)) + | `Op (p, _idxs, tys) -> + ("operator", Cb (((p, tys), ue), pp_op)) in msg " [%s]: %a@\n" title pp x) matches end diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 6410632daa..d250202cf7 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -181,3 +181,21 @@ axiom cat_words_self {m n} (wm : int vec<:m>) (wn : int vec<:n>) : lemma cat_test {m n} (wm : int vec<:m>) (wn : int vec<:n>) : cat_words wm wn = cat_words wm wn. proof. rewrite cat_words_self. trivial. qed. + +(* Op unfolding propagates idxvar substitution into nested op + signatures. Without this, the body's nested-op f_types still + reference the unfolded op's bound idxvar (instead of the call-site + value), and a follow-up rewrite cannot match those nested ops. + Mirrors the user's [(_.[_])] / [(++)] / [bits_cat] case. *) +op size_of {n} (xs : int vec<:n>) : int. + +(* Op whose body uses [size_of], itself indexed. Unfolding [via_size] + must rewrite [size_of]'s f_ty to use the call-site index. *) +op via_size {n} (xs : int vec<:n>) : int = size_of xs. + +axiom size_of_self {n} (xs : int vec<:n>) : + size_of xs = size_of xs. + +lemma unfold_then_rewrite {n} (xs : int vec<:n>) : + via_size xs = via_size xs. +proof. move=> @/via_size. rewrite size_of_self. trivial. qed. From 142d028b4d046e7a706315017bddcb6a12801ca7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 11:37:57 +0200 Subject: [PATCH 25/40] indexed-types: substitute idxvars in formula-locals on op-unfold and apply When a lemma or op binds [{n}] and uses [n] both as a tindex AND as an int term in its body (e.g. [size_bits {n} (w : word<:n>) : size (bits w) = n]), substitution must reach BOTH namespaces: - the tindex side ([TIVar n_lem] in [bits]'s targs), and - the formula-local side ([Flocal n_lem] on the RHS). Without the second part, opening the lemma at index [m] leaves a dangling [Flocal n_lem] in the rewrite RHS, the goal becomes [size (bits wm) = Flocal n_lem] (printed misleadingly as [... = n] since both n_lem and m_caller share the name "n"), and the proof cannot close. Same issue for [Op.reduce] when an op's body uses an idxvar as int. Fixes: 1. New [EcCoreFol.f_of_tindex : tindex -> form] projects a tindex into the int-formula world. [TIVar id -> Flocal id : int], [TIConst k -> f_int k], [TIAdd/TIMul -> f_int_add / f_int_mul]. Asserts on residual [TIUnivar]. 2. [EcEnv.Op.reduce] (op-unfolding) and [EcEnv.Ax.instantiate] (lemma application) now also bind [n_lem -> f_of_tindex idx] in [fs_loc] alongside the existing [fs_idx] binding. 3. [EcProofTerm.pt_env] gains a [pte_idx_link] field recording each lemma's [(idxvar ident, fresh tindex univar uid)] pairs; [concretize_env] uses it to bridge the two namespaces during proof-term concretization (when [?u_pat] resolves to [TIVar m_caller], the corresponding [Flocal n_lem] in the body gets bound to [Flocal m_caller]). Verified: the user's [size_bits] / [bits_cat] / [catE] proof works, plus a new regression case in tests/indexed-types.ec covering the "idxvar used as int term in lemma RHS" pattern (214 decls total). --- src/ecCoreFol.ml | 12 ++++++++++ src/ecCoreFol.mli | 5 +++++ src/ecEnv.ml | 29 ++++++++++++++++++++++++ src/ecProofTerm.ml | 50 ++++++++++++++++++++++++++++++++++++++---- src/ecProofTerm.mli | 7 ++++++ tests/indexed-types.ec | 12 ++++++++++ 6 files changed, 111 insertions(+), 4 deletions(-) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index b35a690327..2eb44c9ee2 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -386,6 +386,18 @@ let rec f_int (n : BI.zint) = | s when 0 <= s -> mk_form (Fint n) tint | _ -> f_int_opp (f_int (~^ n)) +(* Project a tindex into the int-formula world. Idxvars share the + formula-locals namespace (Phase 2): a [TIVar id] becomes a + [Flocal id : int]. Index univars [TIUnivar u] are not directly + expressible; the caller must have resolved them first. *) +let rec f_of_tindex (ti : tindex) : form = + match ti with + | TIVar id -> f_local id tint + | TIConst k -> f_int k + | TIAdd (l, r) -> f_int_add (f_of_tindex l) (f_of_tindex r) + | TIMul (l, r) -> f_int_mul (f_of_tindex l) (f_of_tindex r) + | TIUnivar _ -> assert false + (* -------------------------------------------------------------------- *) let f_i0 = f_int BI.zero let f_i1 = f_int BI.one diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index fd182db51d..89e6ebb3dd 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -185,6 +185,11 @@ val f_int_mul : form -> form -> form val f_int_pow : form -> form -> form val f_int_edivz : form -> form -> form +(* Project a [tindex] into the int-formula world. Idxvars share the + formula-locals namespace (Phase 2): [TIVar id] -> [Flocal id : int]. + Asserts on residual [TIUnivar]s — caller must resolve first. *) +val f_of_tindex : tindex -> form + (* -------------------------------------------------------------------- *) val f_none : ty -> form val f_some : form -> form diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 67c2c9c77c..c9a9f80a4f 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2723,6 +2723,21 @@ module Op = struct in let fs = EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx () in + (* Idxvars also occupy the formula-locals namespace (Phase 2): + bind each idxvar's int-typed [Flocal] to the call-site index + projected into the int-formula world (so e.g. an idxvar [n] + that the body uses as an int term gets resolved to [m+1] when + called at index [m+1]). *) + let fs = + if List.compare_lengths tys.indices tparams.idxvars <> 0 + then fs + else + List.fold_left2 + (fun s id v -> + EcCoreSubst.Fsubst.f_bind_local s id + (EcCoreFol.f_of_tindex v)) + fs tparams.idxvars tys.indices + in EcCoreSubst.Fsubst.f_subst fs f let is_projection env p = @@ -2838,6 +2853,20 @@ module Ax = struct let fs = EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv:tv_map ~idx:idx_map () in + (* Idxvars share the formula-locals namespace (Phase 2): also + bind each idxvar's int [Flocal] to the call-site index + projected into the int-formula world. Without this the + lemma's body's [Flocal n_lem] (when [n] was used as int + inside the proposition) survives unsubstituted. *) + let fs = + if List.is_empty idxs then fs + else + List.fold_left2 + (fun s id v -> + EcCoreSubst.Fsubst.f_bind_local s id + (EcCoreFol.f_of_tindex v)) + fs tparams.idxvars idxs + in EcCoreSubst.Fsubst.f_subst fs f | _ -> raise (LookupFailure (`Path p)) diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 6647f53ae3..6e2fe681b4 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -19,6 +19,16 @@ type pt_env = { pte_hy : LDecl.hyps; pte_ue : EcUnify.unienv; pte_ev : EcMatching.mevmap ref; + (* Idxvars opened by [pt_of_uglobal_r] live in two namespaces + simultaneously: the lemma's body references them in tindex + positions (substituted via [fs_idx] to a fresh [TIUnivar]) and + in formula positions as int-typed [Flocal]. The tindex side + resolves through the unifier; the formula side does not, so + [concretize] would leave dangling [Flocal n_lem] nodes. We + record the (lemma idxvar ident, fresh tindex univar) pairs + here so [concretize_env] can synthesise the missing form + bindings once the tindex univar is resolved. *) + pte_idx_link : (EcIdent.t * EcUid.uid) list ref; } type pt_ev = { @@ -82,18 +92,22 @@ let ptenv pe hyps (ue, ev) = { pte_pe = pe; pte_hy = hyps; pte_ue = EcUnify.UniEnv.copy ue; - pte_ev = ref ev; } + pte_ev = ref ev; + pte_idx_link = ref []; } (* -------------------------------------------------------------------- *) let copy pe = - ptenv pe.pte_pe pe.pte_hy (pe.pte_ue, !(pe.pte_ev)) + let cp = ptenv pe.pte_pe pe.pte_hy (pe.pte_ue, !(pe.pte_ev)) in + cp.pte_idx_link := !(pe.pte_idx_link); + cp (* -------------------------------------------------------------------- *) let ptenv_of_penv (hyps : LDecl.hyps) (pe : proofenv) = { pte_pe = pe; pte_hy = hyps; pte_ue = PT.unienv_of_hyps hyps; - pte_ev = ref EcMatching.MEV.empty; } + pte_ev = ref EcMatching.MEV.empty; + pte_idx_link = ref []; } (* -------------------------------------------------------------------- *) let rec get_head_symbol (pt : pt_env) (f : form) = @@ -111,7 +125,25 @@ let can_concretize (pt : pt_env) = (* -------------------------------------------------------------------- *) let concretize_env pe = - CPTEnv (EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) (LDecl.toenv pe.pte_hy)) + let subst = EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) + (LDecl.toenv pe.pte_hy) in + (* For each (idxvar ident, tindex univar) link recorded by + [pt_of_uglobal_r]: if the tindex univar resolved to a [TIVar + concrete] in the unifier, add a form-level binding + [n_lem -> Flocal concrete] (typed int) so dangling references + in the lemma's body get resolved alongside the tindex side. *) + let iu = EcUnify.UniEnv.iu_assubst pe.pte_ue in + let subst = + List.fold_left (fun s (id, u) -> + match EcUid.Muid.find_opt u iu with + | Some (EcAst.TIVar tid) -> + EcCoreSubst.Fsubst.f_bind_local s id (f_local tid tint) + | Some (EcAst.TIConst k) -> + EcCoreSubst.Fsubst.f_bind_local s id (f_int k) + | _ -> s) + subst !(pe.pte_idx_link) + in + CPTEnv subst (* -------------------------------------------------------------------- *) let concretize_e_form_gen (CPTEnv subst) ids f = @@ -233,6 +265,16 @@ let pt_of_uglobal_r ptenv p = EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx:ix () in EcCoreSubst.Fsubst.f_subst fs ax in + (* Record (idxvar ident, tindex univar uid) for each lemma idxvar + so [concretize_env] can synthesise the corresponding form-level + binding [Flocal n_lem -> Flocal concrete] once the tindex univar + resolves to a [TIVar concrete]. *) + List.iter (fun id -> + match EcIdent.Mid.find_opt id ix with + | Some (EcAst.TIUnivar u) -> + ptenv.pte_idx_link := (id, u) :: !(ptenv.pte_idx_link) + | _ -> ()) + typ.idxvars; let idxs = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in let typ = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in diff --git a/src/ecProofTerm.mli b/src/ecProofTerm.mli index 8f54208794..a467fdcb9c 100644 --- a/src/ecProofTerm.mli +++ b/src/ecProofTerm.mli @@ -35,6 +35,13 @@ type pt_env = { pte_hy : LDecl.hyps; (* local context *) pte_ue : EcUnify.unienv; (* unification env. *) pte_ev : mevmap ref; (* metavar env. *) + (* Link from a lemma's idxvar idents to their fresh tindex-univar + uids. Used by [concretize_env] to bridge tindex resolution and + formula-locals: when [?u_id := TIVar concrete] is set in [pte_ue], + [Flocal n_lem] in the lemma's body is rewritten to [Flocal + concrete] (typed int) by adding a corresponding [fs_loc] entry + to the substitution. *) + pte_idx_link : (EcIdent.t * EcUid.uid) list ref; } type pt_ev = { diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index d250202cf7..d8f01633ef 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -199,3 +199,15 @@ axiom size_of_self {n} (xs : int vec<:n>) : lemma unfold_then_rewrite {n} (xs : int vec<:n>) : via_size xs = via_size xs. proof. move=> @/via_size. rewrite size_of_self. trivial. qed. + +(* When a lemma's body uses an idxvar [n] both as a tindex and as an + int term (via Phase-2's shared namespace), opening the lemma must + substitute BOTH the tindex side ([TIVar n_lem]) and the formula- + local side ([Flocal n_lem]). Otherwise the rewrite leaves a + dangling [Flocal n_lem] in the goal. *) +op size_v {n} (xs : int vec<:n>) : int. +axiom size_v_eq_n {n} (xs : int vec<:n>) : size_v xs = n. + +lemma rewrite_with_int_form {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + size_v wm = m. +proof. rewrite size_v_eq_n. trivial. qed. From 4fda8d0aaa726c8f44572fae33ef391bb8e91e40 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 11:49:56 +0200 Subject: [PATCH 26/40] indexed-types: process_named_pterm also bridges idxvar formula-locals The previous fix for [pt_of_uglobal_r] (the no-instantiation lemma opener) wasn't carried over to [process_named_pterm] (the explicit [lemma[:idx]] / [lemma<:ty>] opener). Result: [have := mkK[:m + n]] on a lemma whose body uses [n] as an int term left a dangling [Flocal n_lem], breaking the proof checker with InvalidGoalShape. [process_named_pterm] now mirrors [pt_of_uglobal_r]: - For idxvars whose [openidx] returned a concrete [tindex] (because the user supplied [[:idx]]), bind [Flocal n_lem -> f_of_tindex idx] in [fs_loc] directly. The substitution flows into the formula immediately. - For idxvars whose [openidx] returned a fresh [TIUnivar] (the no-instantiation case), record [(n_lem, ?u)] in [pte_idx_link] so [concretize_env] can synthesise the form binding once unification resolves the univar. Same mechanism as [pt_of_uglobal_r]. Verified with the user's [have := mkK[:m + n]] case, plus a new regression in tests/indexed-types.ec exercising the explicit-index [have :=] pattern (227 decls total). --- src/ecProofTerm.ml | 25 +++++++++++++++++++++++++ tests/indexed-types.ec | 13 +++++++++++++ 2 files changed, 38 insertions(+) diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 6e2fe681b4..11bd66dd79 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -569,8 +569,33 @@ let process_named_pterm pe (tvi, fp) = let ax = let fs = EcCoreSubst.Fsubst.f_subst_init ~freshen:false ~tv ~idx:ix () in + (* Idxvars are also int-typed formula locals (Phase 2): substitute + [Flocal n_lem] alongside [TIVar n_lem]. For univar instantiations, + defer to [pte_idx_link] (populated below) so [concretize_env] + can fill the form binding once unification resolves the + univar. *) + let fs = + EcIdent.Mid.fold + (fun id ti s -> + match ti with + | EcAst.TIUnivar _ -> s + | _ -> + EcCoreSubst.Fsubst.f_bind_local s id + (EcCoreFol.f_of_tindex ti)) + ix fs + in EcCoreSubst.Fsubst.f_subst fs ax in + (* Same link mechanism as [pt_of_uglobal_r]: if [openidx] allocated + a fresh [TIUnivar] for any idxvar (because the user did not + supply an explicit index), record it so [concretize_env] can + bridge the tindex / formula-local namespaces. *) + List.iter (fun id -> + match EcIdent.Mid.find_opt id ix with + | Some (EcAst.TIUnivar u) -> + pe.pte_idx_link := (id, u) :: !(pe.pte_idx_link) + | _ -> ()) + typ.idxvars; let typ_out = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in let idxs_out = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index d8f01633ef..f2cdccc4fc 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -211,3 +211,16 @@ axiom size_v_eq_n {n} (xs : int vec<:n>) : size_v xs = n. lemma rewrite_with_int_form {m n} (wm : int vec<:m>) (wn : int vec<:n>) : size_v wm = m. proof. rewrite size_v_eq_n. trivial. qed. + +(* `have := lemma[:idx]` with explicit index instantiation must + substitute the idxvar in BOTH tindex positions and formula-locals. + The explicit-index path is process_named_pterm, distinct from the + no-index pt_of_uglobal_r path. *) +op vec_at {n} (xs : int vec<:n>) (i : int) : int. + +axiom vec_at_n_int {n} (xs : int vec<:n>) : + vec_at xs 0 = n + n. + +lemma test_have {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + true. +proof. have := vec_at_n_int[:m + n]. trivial. qed. From 54b80ceb36198daf28491bfb897127f45786ebf7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 11:57:11 +0200 Subject: [PATCH 27/40] indexed-types: best-effort idx unification on Fop heads in matcher The previous fix made the matcher's Fop case skip index unification entirely, since polynomial-against-polynomial unification with multiple univars (e.g. [bits[:?u_m + ?u_n]] vs [bits[:m + n]]) is genuinely ambiguous in isolation. But that broke the simpler single-univar case: [rewrite mkK] (where mkK has one bound idxvar) no longer constrains [?u_pat] from the [mk[:?u_pat]] head, so the univar stays unresolved and the matcher concludes "nothing to rewrite". Make the index unification best-effort: try to unify each pair, and if a particular pair fails (multi-univar case), silently continue and let arg matching constrain the residual univars later. The single-univar case (handled by Gap-B's naked-univar fast path) goes through normally. Type unification on Fop heads stays mandatory. Verified: the user's [rewrite mkK] case now works, alongside the earlier [bits_cat] / [catE] cases (240 decls). --- src/ecMatching.ml | 20 +++++++++++++------- tests/indexed-types.ec | 13 +++++++++++++ 2 files changed, 26 insertions(+), 7 deletions(-) diff --git a/src/ecMatching.ml b/src/ecMatching.ml index e4b303aca7..7387362895 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -689,13 +689,19 @@ let f_match_core opts hyps (ue, ev) f1 f2 = failure (); if List.compare_lengths tys1.types tys2.types <> 0 then failure (); - (* Indices on Fop are redundant with f_ty (which is unified - at the surrounding Fapp via arg matching). Trying to unify - them here forces a polynomial-against-polynomial match - before the constraints from arg matching are available, - leading to ambiguous multi-univar Diophantine. We unify - the type arguments only and let the args provide the - remaining constraints. *) + (* Index unification on Fop heads is best-effort: a single + naked TIUnivar (e.g. [mk[:?u]] vs [mk[:m+n]]) binds via + my Gap-B path, but a polynomial-against-polynomial with + multiple univars (e.g. [bits[:?u_m + ?u_n]] vs + [bits[:m + n]]) is genuinely ambiguous in isolation — + defer to arg matching, which typically constrains the + individual univars first. So we try, but tolerate + failures here. Type unification of [tys1.types] is + still mandatory. *) + List.iter2 (fun i1 i2 -> + try EcUnify.unify_idx env ue i1 i2 + with EcUnify.UnificationFailure _ -> ()) + tys1.indices tys2.indices; try List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index f2cdccc4fc..03431ef4cc 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -224,3 +224,16 @@ axiom vec_at_n_int {n} (xs : int vec<:n>) : lemma test_have {m n} (wm : int vec<:m>) (wn : int vec<:n>) : true. proof. have := vec_at_n_int[:m + n]. trivial. qed. + +(* Bare [rewrite L] (no explicit index) on an indexed lemma whose + pattern is a single-univar Fop application (e.g. mk[:?u]): the + matcher's Fop case must attempt index unification so [?u] gets + bound to the goal's index polynomial. *) +op build {n} : int -> int vec<:n>. +op extract {n} : int vec<:n> -> int. + +axiom buildK {n} (k : int) : extract (build[:n] k) = k. + +lemma test_bare_rewrite {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + extract (build[:m + n] 42) = 42. +proof. rewrite buildK. trivial. qed. From 7fd04a6eaaeb65eddcd5b063f66de55e0ec26e5b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 12:39:26 +0200 Subject: [PATCH 28/40] indexed-types: skip form-side idxvar binding when tindex still has univars MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [Ax.instantiate], [Op.reduce], and [process_named_pterm] all bind [Flocal n_lem -> f_of_tindex idx] alongside the [TIVar n_lem -> idx] tindex substitution. But the call site can supply an [idx] that still contains an unresolved [TIUnivar] — happens when the matcher invokes [Ax.instantiate] before the surrounding unification has pinned the univar (e.g. on a chain like [apply: inj_bits; rewrite bits_cat. rewrite bits_cat]). The asserting [f_of_tindex] then crashes with the Phase-2 assert. New [EcCoreFol.f_of_tindex_opt : tindex -> form option] returns [None] when [ti] still contains [TIUnivar]. The three substitution sites use it to silently skip the form-side binding in that case; the form-side then gets resolved later by [pte_idx_link] at [concretize_env] time, once the univar is pinned. The asserting variant [f_of_tindex] stays for callers that have proven all univars are resolved. Verified: the user's [catA] / [apply: inj_bits; rewrite bits_cat] proof works (255 decls in tests/indexed-types.ec). --- src/ecCoreFol.ml | 30 ++++++++++++++++++++++-------- src/ecCoreFol.mli | 7 +++++-- src/ecEnv.ml | 10 ++++++---- src/ecProofTerm.ml | 8 +++----- tests/indexed-types.ec | 15 +++++++++++++++ 5 files changed, 51 insertions(+), 19 deletions(-) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 2eb44c9ee2..228c21e980 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -388,15 +388,29 @@ let rec f_int (n : BI.zint) = (* Project a tindex into the int-formula world. Idxvars share the formula-locals namespace (Phase 2): a [TIVar id] becomes a - [Flocal id : int]. Index univars [TIUnivar u] are not directly - expressible; the caller must have resolved them first. *) -let rec f_of_tindex (ti : tindex) : form = + [Flocal id : int]. Returns [None] if [ti] still contains any + [TIUnivar] (the projection cannot represent them); callers can + then decide to skip the form-side binding rather than crash. *) +let rec f_of_tindex_opt (ti : tindex) : form option = match ti with - | TIVar id -> f_local id tint - | TIConst k -> f_int k - | TIAdd (l, r) -> f_int_add (f_of_tindex l) (f_of_tindex r) - | TIMul (l, r) -> f_int_mul (f_of_tindex l) (f_of_tindex r) - | TIUnivar _ -> assert false + | TIVar id -> Some (f_local id tint) + | TIConst k -> Some (f_int k) + | TIAdd (l, r) -> begin + match f_of_tindex_opt l, f_of_tindex_opt r with + | Some l, Some r -> Some (f_int_add l r) + | _ -> None + end + | TIMul (l, r) -> begin + match f_of_tindex_opt l, f_of_tindex_opt r with + | Some l, Some r -> Some (f_int_mul l r) + | _ -> None + end + | TIUnivar _ -> None + +let f_of_tindex (ti : tindex) : form = + match f_of_tindex_opt ti with + | Some f -> f + | None -> assert false (* -------------------------------------------------------------------- *) let f_i0 = f_int BI.zero diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 89e6ebb3dd..93ce927749 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -187,8 +187,11 @@ val f_int_edivz : form -> form -> form (* Project a [tindex] into the int-formula world. Idxvars share the formula-locals namespace (Phase 2): [TIVar id] -> [Flocal id : int]. - Asserts on residual [TIUnivar]s — caller must resolve first. *) -val f_of_tindex : tindex -> form + The option variant returns [None] if [ti] still contains any + [TIUnivar]; the asserting variant crashes in that case (use it + when the caller is sure all univars are resolved). *) +val f_of_tindex_opt : tindex -> form option +val f_of_tindex : tindex -> form (* -------------------------------------------------------------------- *) val f_none : ty -> form diff --git a/src/ecEnv.ml b/src/ecEnv.ml index c9a9f80a4f..1c2479a7cc 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2734,8 +2734,9 @@ module Op = struct else List.fold_left2 (fun s id v -> - EcCoreSubst.Fsubst.f_bind_local s id - (EcCoreFol.f_of_tindex v)) + match EcCoreFol.f_of_tindex_opt v with + | Some f -> EcCoreSubst.Fsubst.f_bind_local s id f + | None -> s) fs tparams.idxvars tys.indices in EcCoreSubst.Fsubst.f_subst fs f @@ -2863,8 +2864,9 @@ module Ax = struct else List.fold_left2 (fun s id v -> - EcCoreSubst.Fsubst.f_bind_local s id - (EcCoreFol.f_of_tindex v)) + match EcCoreFol.f_of_tindex_opt v with + | Some f -> EcCoreSubst.Fsubst.f_bind_local s id f + | None -> s) fs tparams.idxvars idxs in EcCoreSubst.Fsubst.f_subst fs f diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 11bd66dd79..965265a6bd 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -577,11 +577,9 @@ let process_named_pterm pe (tvi, fp) = let fs = EcIdent.Mid.fold (fun id ti s -> - match ti with - | EcAst.TIUnivar _ -> s - | _ -> - EcCoreSubst.Fsubst.f_bind_local s id - (EcCoreFol.f_of_tindex ti)) + match EcCoreFol.f_of_tindex_opt ti with + | Some f -> EcCoreSubst.Fsubst.f_bind_local s id f + | None -> s) ix fs in EcCoreSubst.Fsubst.f_subst fs ax diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 03431ef4cc..9bc8ecc799 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -237,3 +237,18 @@ axiom buildK {n} (k : int) : extract (build[:n] k) = k. lemma test_bare_rewrite {m n} (wm : int vec<:m>) (wn : int vec<:n>) : extract (build[:m + n] 42) = 42. proof. rewrite buildK. trivial. qed. + +(* When [Ax.instantiate] / [Op.reduce] is invoked with idxs that + still contain unresolved [TIUnivar]s (because matching hasn't + pinned them yet), [f_of_tindex_opt] returns [None] and the form- + side binding is silently skipped — the form-side stays + unsubstituted and gets resolved later via [pte_idx_link]. The + asserting variant of [f_of_tindex] used to crash here. *) +op midx {n} (xs : int vec<:n>) (k : int) : int. + +axiom midx_self {n} (xs : int vec<:n>) (k : int) : + midx xs k = midx xs k. + +lemma test_chain {m n} (wm : int vec<:m>) (wn : int vec<:n>) : + midx wm 1 = midx wm 1. +proof. rewrite midx_self. rewrite midx_self. trivial. qed. From af6f983ec482b6af9299241aaba940ac23eb148c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 12:45:56 +0200 Subject: [PATCH 29/40] indexed-types: show active index variables in proof state [h_tvar] is a [ty_params] record carrying both [tyvars] and [idxvars], but the goal/hyps printers only displayed the type variables. Lemmas with index binders (e.g. [{m n}]) showed an empty "Type variables: " line and no clue that [m, n] were in scope as int-typed indices. [pp_goal1] and [pp_hyps] now register the idxvars in the printer env (via [PPEnv.add_locals]) and emit an "Index variables: m, n" line above the existing "Type variables:" line whenever there is at least one idxvar. The line is omitted entirely when no idxvars are bound, so non-indexed lemmas look unchanged. Verified: full regression (255 decls) passes; the line appears during interactive proofs of any lemma with [{...}] binders. --- src/ecPrinting.ml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index c90e8b78a9..25c5b67cdb 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3313,12 +3313,20 @@ module PPGoal = struct in (ppe, (id, pdk)) let pp_goal1 ?(pphyps = true) ?prpo ?(idx) (ppe : PPEnv.t) fmt (hyps, concl) = + let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.idxvars in let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.tyvars in let ppe, pps = List.map_fold pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in idx |> oiter (Format.fprintf fmt "Goal #%d@\n"); if pphyps then begin + begin + match hyps.EcBaseLogic.h_tvar.idxvars with + | [] -> () + | ix -> + Format.fprintf fmt "Index variables: %a@\n\n%!" + (pp_list ", " (pp_tyvar ppe)) ix + end; begin match hyps.EcBaseLogic.h_tvar.tyvars with | [] -> Format.fprintf fmt "Type variables: @\n\n%!" @@ -3359,11 +3367,18 @@ end (* -------------------------------------------------------------------- *) let pp_hyps (ppe : PPEnv.t) fmt hyps = let hyps = EcEnv.LDecl.tohyps hyps in + let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.idxvars in let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar.tyvars in let ppe, pps = List.map_fold PPGoal.pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in + begin match hyps.EcBaseLogic.h_tvar.idxvars with + | [] -> () + | ix -> + Format.fprintf fmt "Index variables: %a@\n\n%!" + (pp_list ", " (pp_tyvar ppe)) ix + end; begin match hyps.EcBaseLogic.h_tvar.tyvars with | [] -> Format.fprintf fmt "Type variables: @\n\n%!" | tv -> From 6b66b8c69a3755a35b1c0dfed252f79307515d49 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 14:44:25 +0200 Subject: [PATCH 30/40] indexed-types: expose [0 <= n] as a proof hypothesis for each idxvar MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Idxvars are non-negative integers by Phase-2 design. Expose this in proofs by wrapping the goal — at proof-start time, not at lemma-save time — with one [0 <= n_i =>] implication per idxvar. The user introduces them on demand via [move=> Hn_i]. The wrapping is pushed INSIDE the lemma's [pa_vars] forall (not at the very top) so the existing auto-introduction of [pa_vars] still fires. So [lemma foo {n} (xs : T<:n>) : P] still auto-intros [xs]; the [0 <= n =>] hypothesis appears next, available via [move=>]. The implications never leak into the saved [ax_spec]: only the proof goal sees them. Lemma application by other lemmas does not require discharging [0 <= n] — the indexed-type discipline guarantees it. Also extend [EcSmt.lenv_of_tparams_for_hyp] to register each idxvar as a top-level int constant in [te_lc], so [smt()] can talk about the bound idxvars (else [trans_app]'s [Flocal] case would hit [oget None]). Verified: full regression (271 decls) plus three new test cases — [idx_ge0_simple] (no [pa_vars]), [idx_ge0_smt] (multi-idxvar, discharged via [smt()]), and [idx_with_args] ([pa_vars] auto-intro still works alongside the new implications). --- src/ecScope.ml | 22 +++++++++++++++++++++- src/ecSmt.ml | 20 +++++++++++++++++++- tests/indexed-types.ec | 16 ++++++++++++++++ 3 files changed, 56 insertions(+), 2 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 40f0e3b09d..f8b4ebc265 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -950,7 +950,27 @@ module Ax = struct | false -> PSNoCheck | true -> let hyps = EcEnv.LDecl.init (env scope) axd.ax_tparams in - let proof = EcCoreGoal.start hyps axd.ax_spec in + (* Idxvars are non-negative integers by Phase-2 design. Make + this fact available in the proof by inserting [0 <= n_i =>] + implications immediately INSIDE the lemma's outermost + foralls (not at the very top), so the existing + auto-introduction of [pa_vars] still works as before. The + user introduces the new hypotheses on demand via + [move=> Hn_i]. The implications never leak into the saved + [ax_spec] — only the proof goal sees them. *) + let mk_imps body = + List.fold_right (fun id acc -> + let h = f_int_le f_i0 (f_local id tint) in + f_imp h acc) + axd.ax_tparams.idxvars body + in + let rec push f = + match f.f_node with + | Fquant (Lforall, bds, body) -> + f_forall bds (push body) + | _ -> mk_imps f + in + let proof = EcCoreGoal.start hyps (push axd.ax_spec) in PSCheck proof in let puc = diff --git a/src/ecSmt.ml b/src/ecSmt.ml index e23c6f9b5a..b7bef7a30e 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -285,7 +285,25 @@ let lenv_of_tparams_for_hyp genv (ts : ty_params) = genv.te_task <- WTask.add_ty_decl genv.te_task ts; { env with le_tv = Mid.add id (WTy.ty_app ts []) env.le_tv }, ts in - List.map_fold trans_tv empty_lenv ts.tyvars + let env, tysyms = List.map_fold trans_tv empty_lenv ts.tyvars in + (* Idxvars are int-typed formula locals (Phase 2): declare each as + a Why3 param of type [int] so [trans_app]'s [Flocal] case can + resolve them. Without this, an idxvar referenced as an int term + in the goal causes [oget None] inside [trans_app]. *) + (* Register each idxvar as an int-typed top-level constant via the + local-context [te_lc] map (the same path [LD_var] bindings take). + [trans_app]'s [Flocal] case checks [te_lc] before [le_lv]. *) + List.iter (fun (id : EcIdent.t) -> + let ls = WTerm.create_lsymbol (preid id) [] (Some WTy.ty_int) in + let w3op = { + w3op_fo = `LDecl ls; + w3op_ta = (fun _ -> ([], [], Some WTy.ty_int)); + w3op_ho = `HO_TODO (EcIdent.name id, [], Some WTy.ty_int); + } in + genv.te_task <- WTask.add_decl genv.te_task (WDecl.create_param_decl ls); + Hid.add genv.te_lc id w3op) + ts.idxvars; + (env, tysyms) (* -------------------------------------------------------------------- *) let instantiate tparams ~textra targs tres tys = diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 9bc8ecc799..5033ea9099 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -252,3 +252,19 @@ axiom midx_self {n} (xs : int vec<:n>) (k : int) : lemma test_chain {m n} (wm : int vec<:m>) (wn : int vec<:n>) : midx wm 1 = midx wm 1. proof. rewrite midx_self. rewrite midx_self. trivial. qed. + +(* Each idxvar is a non-negative integer by Phase-2 design. The proof + goal is wrapped (inside the lemma's [pa_vars] forall) with one + [0 <= n_i =>] implication per idxvar; the user introduces them + on demand via [move=>]. The implications never leak into the + saved [ax_spec] — only the proof goal sees them. *) +lemma idx_ge0_simple {n} : 0 <= n. +proof. move=> Hn. trivial. qed. + +lemma idx_ge0_smt {m n} : 0 <= m + n. +proof. move=> Hm Hn. smt(). qed. + +(* Backward compat: [pa_vars] auto-intro still works because the + implications are pushed inside the forall, not at the top. *) +lemma idx_with_args {n} (xs : int vec<:n>) : 0 <= n. +proof. move=> Hn. trivial. qed. From 18863b462fda489359ee43302ae3e151d90e67ac Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 16:14:47 +0200 Subject: [PATCH 31/40] indexed-types: record multi-univar Diophantine as a deliberate non-goal The Gap-B MVP scope already excluded multi-univar Diophantine but memory.md framed it as a defer. It's actually a non-goal: equations like [?m + ?n = 5] have no canonical nat solution, so the unifier correctly refuses rather than guess. Document the workaround (explicit [:...] instantiation) and the only sensible future direction (constraint-accumulate-and-commit), gated on a motivating use case. --- memory.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/memory.md b/memory.md index b567bec53f..ccbeada7c4 100644 --- a/memory.md +++ b/memory.md @@ -533,6 +533,19 @@ F lands last to translate everything we now support). new function refuses — two univars with non-zero net). MVP scope excludes multi-univar Diophantine and `?u + 1 = n` (free n) where the residual could be negative without symbolic guarantees. + + **Multi-univar Diophantine is a deliberate non-goal, not a punt.** + Equations like `?m + ?n = 5` admit every `(k, 5-k)` for + `0 <= k <= 5` as a nat solution — no canonical answer, nothing + to "prefer". Guessing one would be wrong; the unifier correctly + refuses. The MVP workaround is explicit index instantiation at + the call site: `make_sum[:2, 3]` instead of bare `make_sum`. If + ever revisited, the only sensible option is + **constraint-accumulate-and-commit** — collect `?m + ?n = 5` as + a pending equation and commit once a later context (arg type, + scrutinee, …) pins one univar and makes the solution unique. + Worth building only if a real use case surfaces; until then, + explicit `[:...]` is the answer. - **C** — non-refining indexed datatypes and records. `EcHiInductive.trans_datatype` and `trans_record` now take an optional `~idxparams` argument; `EcScope.add_types` threads it From 303b0b30905622fcebaf3b756722fdb18d079642 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 20:27:41 +0200 Subject: [PATCH 32/40] indexed-types: defer IxUni problems, retry after each assignment MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit FIFO queue order caused the type unifier to fail spuriously on polynomial index equations whose univars got resolved later in the queue. Concrete case: unifying word<:n*m> -> word<:m> array<:n> (lhs) against word<:?m_pack> array<:?n_pack> -> word<:?n_pack * ?m_pack> (pack's opened type, from the user's [packK : cancel unpack pack] lemma). Decomposition pushed [IxUni(n*m, ?n_pack * ?m_pack)] BEFORE the per-component [IxUni(m, ?m_pack)] and [IxUni(n, ?n_pack)]. The mixed-monomial case with unresolved univars is ambiguous in isolation so unify_ix failed — aborting the whole unification. Fix: when unify_ix fails, add the problem to a [deferred] list instead of raising. After the main queue drains, retry the deferred problems; each successful assignment triggers another drain pass. Only fail if a full pass makes no progress. Verified: the user's [packK] lemma ([cancel unpack[:m, n] pack]) typechecks; full regression (292 decls) passes. Does NOT solve genuinely multi-univar cases like [?m + ?n = 5] — those are still refused (no canonical solution) per the design note in memory.md. --- src/ecUnify.ml | 39 +++++++++++++++++++++++++++++++++++++-- tests/indexed-types.ec | 21 +++++++++++++++++++++ 2 files changed, 58 insertions(+), 2 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 296ad3c328..9db5f8751d 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -189,11 +189,38 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = | _ -> failure () in + (* Problems that [unify_ix] couldn't solve in the current state — + typically because a dependent TIUnivar is still unresolved. They + get retried after every successful assignment; we fail only when + a full pass makes no progress. *) + let deferred = ref [] in + + let try_unify_ix t1 t2 = + try unify_ix t1 t2 + with UnificationFailure _ -> deferred := (t1, t2) :: !deferred + in + + let rec drain_deferred () = + let todo = !deferred in + deferred := []; + let progressed = ref false in + List.iter (fun (t1, t2) -> + let before = !deferred in + (try + unify_ix t1 t2; + progressed := true + with UnificationFailure _ -> + deferred := (t1, t2) :: before); + ignore before + ) todo; + if !progressed && !deferred <> [] then drain_deferred () + in + let doit () = while not (Queue.is_empty pb_q) do match Queue.pop pb_q with | `IxUni (t1, t2) -> - unify_ix t1 t2 + try_unify_ix t1 t2 | `TyUni (t1, t2) -> begin let (t1, t2) = (getvar t1, getvar t2) in @@ -241,7 +268,15 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = | _, _ -> failure () end end - done + done; + (* After the primary queue drains, retry any [IxUni] problems + that were deferred (typically because a dependent univar was + not yet assigned). Each round either resolves at least one or + fails the remaining. *) + drain_deferred (); + if !deferred <> [] then + let (i1, i2) = List.hd !deferred in + raise (UnificationFailure (`IxUni (i1, i2))) in doit () diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 5033ea9099..3895c6dc55 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -268,3 +268,24 @@ proof. move=> Hm Hn. smt(). qed. implications are pushed inside the forall, not at the top. *) lemma idx_with_args {n} (xs : int vec<:n>) : 0 <= n. proof. move=> Hn. trivial. qed. + +(* FIFO unification order used to fail on mixed-monomial index + equations where a dependent univar is resolved later in the queue + (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either + univar has been pinned by separate equations). The unifier now + defers such IxUni problems and retries them after every + assignment, so chains of index equations resolve regardless of + queue order. Mirrors the [packK] case from the Word library. *) +type {n} warr. +type {n} wvec. + +op pack_pm {m n} (xs : wvec<:m>) (ys : warr<:n>) : wvec<:m * n>. +op unpack_pm {m n} (ys : wvec<:m * n>) : wvec<:m> * warr<:n>. + +(* The univars [?m, ?n] each get pinned by a separate [IxUni] on + [wvec<:?m> = wvec<:m>] and [warr<:?n> = warr<:n>]; then the + polynomial output [wvec<:?m * ?n> = wvec<:m * n>] retries and + succeeds via [tindex_equal] after substitution. *) +lemma pack_mult {m n} (x : wvec<:m>) (y : warr<:n>) (z : wvec<:m * n>) : + z = pack_pm x y => z = pack_pm x y. +proof. admit. qed. From 2c92dff5809b56ea26ca417d1269442b3348e881 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 20:41:31 +0200 Subject: [PATCH 33/40] indexed-types: opt-in [0 <= n] hypothesis via `+` marker on idxvars MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The previous default of auto-injecting [0 <= n =>] for every idxvar in a lemma's proof goal was too intrusive — users who don't need the hypothesis paid the cost of an extra [move=>] to skip it. Make it opt-in instead: a trailing `+` on the idxvar name in the binder marks it as "inject the [0 <= n] hypothesis", everything else stays as-is. Examples: lemma foo {n} : ... (* no hypothesis *) lemma bar {n+} : ... (* [0 <= n] available via [move=> Hn] *) lemma baz {m+ n} : ... (* only [0 <= m] is injected *) Parser: new [idxvar_item] rule matches [lident PLUS] or plain [lident]; [idxvars_decl] returns [(psymbol * bool) list]; [ix_ty_binder] returns [(idxs, nonneg_subset, tyvars_opt)]. Parsetree: new [paxiom.pa_idxvars_nneg : psymbol list] records the `+`-marked idxvars. Scope: [start_lemma] / [start_lemma_with_proof] gain an optional [?nneg_idxs] argument; [add_r] looks up the marked names against the axiom's [ax_tparams.idxvars] and threads the list through. Only those idxvars get a [0 <= n =>] implication injected inside the [pa_vars] forall. Non-lemma binders (op / pred / type / etc.) accept the `+` syntax but ignore it. Regression updated to use `+` where the hypothesis was relied on. --- src/ecParser.mly | 76 ++++++++++++++++++++++++++---------------- src/ecParsetree.ml | 20 ++++++----- src/ecScope.ml | 39 ++++++++++++++-------- tests/indexed-types.ec | 25 ++++++++------ 4 files changed, 99 insertions(+), 61 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index f2d41fd886..d9c7ba0c1d 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -84,15 +84,16 @@ let pflist loc ti (es : pformula list) : pformula = List.fold_right (fun e1 e2 -> pf_cons loc ti e1 e2) es (pf_nil loc ti) - let mk_axiom ~locality (x, idx, ty, pv, vd, f) k = - { pa_name = x; - pa_idxvars = idx; - pa_tyvars = ty; - pa_pvars = pv; - pa_vars = vd; - pa_formula = f; - pa_kind = k; - pa_locality = locality; } + let mk_axiom ~locality (x, idx, nonneg, ty, pv, vd, f) k = + { pa_name = x; + pa_idxvars = idx; + pa_idxvars_nneg = nonneg; + pa_tyvars = ty; + pa_pvars = pv; + pa_vars = vd; + pa_formula = f; + pa_kind = k; + pa_locality = locality; } let mk_simplify l = if l = [] then @@ -1334,9 +1335,17 @@ pindex: (* Index-parameter binder. Uses curly braces and naked identifiers (e.g. `{n m}`), distinct from the square-bracket binder used for type variables (`['a 'b]`). When both are present, the index - binder must come first: `type {n} 'a vec`. *) + binder must come first: `type {n} 'a vec`. + + A trailing `+` on an identifier marks it as "non-negative by + assumption": on lemma / axiom binders this adds a [0 <= n] + hypothesis to the proof goal. Ignored on other binder sites. *) +idxvar_item: +| x=lident PLUS { (x, true) } +| x=lident { (x, false) } + idxvars_decl: -| LBRACE xs=lident+ RBRACE { xs } +| LBRACE xs=idxvar_item+ RBRACE { xs } type_exp: | ty=simpl_type_exp { ty } @@ -1708,7 +1717,8 @@ typarams: { (xs : ptyparams) } %inline tyd_name: -| idx=loption(idxvars_decl) tya=typarams x=ident { (idx, tya, x) } +| idx=loption(idxvars_decl) tya=typarams x=ident + { (List.map fst idx, tya, x) } dt_ctor_def: | x=oident { (x, []) } @@ -1809,14 +1819,22 @@ tyvars_decl: { tyvars } (* Combined `{idx}` then `['a]` binder. Indices come first; both are - independently optional. Returns [(idxvars, tyvars_opt)] where - [tyvars_opt] is [None] when no [...] bracket appeared at all, - matching the legacy [tvs |> omap ...] convention so downstream - `po_tyvars`-style fields keep distinguishing "no binder given" - from "empty binder given". *) + independently optional. Returns [(idxvars, nonneg, tyvars_opt)] + where: + - [idxvars] is the idxvar names in order. + - [nonneg] is the subset of idxvars marked with a trailing `+`. + Used by lemma / axiom processing to inject [0 <= n] hypotheses; + other consumers ignore it. + - [tyvars_opt] is [None] when no [...] bracket appeared at all, + matching the legacy [tvs |> omap ...] convention so downstream + `po_tyvars`-style fields keep distinguishing "no binder given" + from "empty binder given". *) ix_ty_binder: | idx=idxvars_decl? ty=tyvars_decl? - { (EcUtils.odfl [] idx, ty) } + { let items = EcUtils.odfl [] idx in + let idxs = List.map fst items in + let nonneg = items |> List.filter snd |> List.map fst in + (idxs, nonneg, ty) } op_or_const: | OP { `Op } @@ -1830,7 +1848,7 @@ operator: { let gloc = EcLocation.make $startpos $endpos in let sty = sty |> ofdfl (fun () -> mk_loc (b |> omap (loc |- fst) |> odfl gloc) PTunivar) in - let (idxvars, po_tyvars) = tvs in + let (idxvars, _nonneg, po_tyvars) = tvs in { po_kind = k; po_name = List.hd x; @@ -1847,7 +1865,7 @@ operator: x=plist1(oident, COMMA) tvs=ix_ty_binder args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { let (idxvars, po_tyvars) = tvs in + { let (idxvars, _nonneg, po_tyvars) = tvs in { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; @@ -1919,7 +1937,7 @@ predicate: pp_locality = locality; } } | locality=locality PRED x=oident tvs=ix_ty_binder COLON sty=pred_tydom - { let (idxvars, pp_tyvars) = tvs in + { let (idxvars, _nonneg, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -1927,7 +1945,7 @@ predicate: pp_locality = locality; } } | locality=locality PRED x=oident tvs=ix_ty_binder p=ptybindings? EQ f=form - { let (idxvars, pp_tyvars) = tvs in + { let (idxvars, _nonneg, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -1937,7 +1955,7 @@ predicate: | locality=locality INDUCTIVE x=oident tvs=ix_ty_binder p=ptybindings? EQ b=indpred_def - { let (idxvars, pp_tyvars) = tvs in + { let (idxvars, _nonneg, pp_tyvars) = tvs in { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -1982,7 +2000,7 @@ nt_bindings: notation: | locality=loc(locality) NOTATION x=loc(NOP) tvs=ix_ty_binder bd=nt_bindings? args=nt_arg1* codom=prefix(COLON, loc(type_exp))? EQ body=expr - { let (idxvars, nt_tv) = tvs in + { let (idxvars, _nonneg, nt_tv) = tvs in { nt_name = x; nt_idx = idxvars; nt_tv = nt_tv; @@ -2009,7 +2027,7 @@ abbreviation: args=ptybindings_decl? sty=prefix(COLON, loc(type_exp))? EQ b=expr { let sty = sty |> ofdfl (fun () -> mk_loc (loc b) PTunivar) in - let (idxvars, ab_tv) = tvs in + let (idxvars, _nonneg, ab_tv) = tvs in { ab_name = x; ab_idx = idxvars; @@ -2032,8 +2050,8 @@ lemma_decl: predvars=mempred_binding? pd=pgtybindings? COLON f=form - { let (idxvars, tyvars) = tvs in - (x, idxvars, tyvars, predvars, pd, f) } + { let (idxvars, nonneg, tyvars) = tvs in + (x, idxvars, nonneg, tyvars, predvars, pd, f) } axiom_tc: | /* empty */ { PLemma None } @@ -2051,7 +2069,7 @@ axiom: | l=locality HOARE x=ident pd=pgtybindings? COLON p=loc( hoare_body(none)) ao=axiom_tc | l=locality EHOARE x=ident pd=pgtybindings? COLON p=loc( ehoare_body(none)) ao=axiom_tc | l=locality PHOARE x=ident pd=pgtybindings? COLON p=loc(phoare_body(none)) ao=axiom_tc - { mk_axiom ~locality:l (x, [], None, None, pd, p) ao } + { mk_axiom ~locality:l (x, [], [], None, None, pd, p) ao } proofend: | QED { `Qed } @@ -3689,7 +3707,7 @@ cltyparams: clone_override: | TYPE idx=loption(idxvars_decl) ps=cltyparams x=qident mode=opclmode t=loc(type_exp) - { (x, PTHO_Type (`BySyntax (idx, ps, t), mode)) } + { (x, PTHO_Type (`BySyntax (List.map fst idx, ps, t), mode)) } | OP x=qoident tyvars=bracket(tident*)? p=ptybinding1* sty=ioption(prefix(COLON, loc(type_exp))) diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 4d544dde93..eb631fc280 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -1078,14 +1078,18 @@ type paxiom_kind = type mempred_binding = PT_MemPred of psymbol list type paxiom = { - pa_name : psymbol; - pa_pvars : mempred_binding option; - pa_idxvars : psymbol list; - pa_tyvars : ptyparams option; - pa_vars : pgtybindings option; - pa_formula : pformula; - pa_kind : paxiom_kind; - pa_locality : locality; + pa_name : psymbol; + pa_pvars : mempred_binding option; + pa_idxvars : psymbol list; + (* Subset of [pa_idxvars] tagged with a trailing `+` in the binder + (e.g. [{n+ m}] marks [n]). For each such idxvar, [start_lemma] + wraps the proof goal with a [0 <= n =>] hypothesis. *) + pa_idxvars_nneg : psymbol list; + pa_tyvars : ptyparams option; + pa_vars : pgtybindings option; + pa_formula : pformula; + pa_kind : paxiom_kind; + pa_locality : locality; } (* -------------------------------------------------------------------- *) diff --git a/src/ecScope.ml b/src/ecScope.ml index f8b4ebc265..775deefb36 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -944,25 +944,24 @@ module Ax = struct sc_locdoc = DocState.add_item scope.sc_locdoc; } (* ------------------------------------------------------------------ *) - let start_lemma scope (cont, axflags) check ?name (axd, ctxt) = + let start_lemma ?(nneg_idxs : EcIdent.t list = []) scope (cont, axflags) + check ?name (axd, ctxt) + = let puc = match check with | false -> PSNoCheck | true -> let hyps = EcEnv.LDecl.init (env scope) axd.ax_tparams in - (* Idxvars are non-negative integers by Phase-2 design. Make - this fact available in the proof by inserting [0 <= n_i =>] - implications immediately INSIDE the lemma's outermost - foralls (not at the very top), so the existing - auto-introduction of [pa_vars] still works as before. The - user introduces the new hypotheses on demand via - [move=> Hn_i]. The implications never leak into the saved - [ax_spec] — only the proof goal sees them. *) + (* For each idxvar marked with `+` in the lemma binder, inject + a [0 <= n =>] hypothesis INSIDE the outermost foralls of + the goal (so [pa_vars] auto-intro still fires). Unmarked + idxvars get no such hypothesis. The implications never + leak into the saved [ax_spec]. *) let mk_imps body = List.fold_right (fun id acc -> let h = f_int_le f_i0 (f_local id tint) in f_imp h acc) - axd.ax_tparams.idxvars body + nneg_idxs body in let rec push f = match f.f_node with @@ -1046,16 +1045,25 @@ module Ax = struct let pucflags = { puc_smt = axd.ax_smt; puc_local = local; } in let pucflags = (([], None), pucflags) in + (* Map each `+`-marked idxvar name to its EcIdent.t (matching + by name against the just-created [tparams.idxvars]). *) + let nneg_idxs = + let names = List.map unloc ax.pa_idxvars_nneg in + List.filter + (fun id -> List.mem (EcIdent.name id) names) + tparams.idxvars + in + match tc with | None -> let scope = - start_lemma scope ~name:(unloc ax.pa_name) + start_lemma ~nneg_idxs scope ~name:(unloc ax.pa_name) pucflags check (axd, None) in let scope = snd (Tactics.process1_r false `Check scope tintro) in None, scope | Some tc -> - start_lemma_with_proof scope + start_lemma_with_proof ~nneg_idxs scope (Some tintro) pucflags (mode, mk_loc loc tc) check ~name:(unloc ax.pa_name) axd end @@ -1129,10 +1137,13 @@ module Ax = struct (None, { scope with sc_env = puc.puc_init }) (* ------------------------------------------------------------------ *) - and start_lemma_with_proof scope tintro pucflags (mode, tc) check ?name axd = + and start_lemma_with_proof + ?(nneg_idxs : EcIdent.t list = []) scope tintro pucflags (mode, tc) + check ?name axd + = let { pl_loc = loc; pl_desc = tc } = tc in - let scope = start_lemma scope pucflags check ?name (axd, None) in + let scope = start_lemma ~nneg_idxs scope pucflags check ?name (axd, None) in let scope = tintro |> ofold (fun t sc -> snd (Tactics.process1_r false `Check sc t)) diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 3895c6dc55..c0c03359b0 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -253,22 +253,27 @@ lemma test_chain {m n} (wm : int vec<:m>) (wn : int vec<:n>) : midx wm 1 = midx wm 1. proof. rewrite midx_self. rewrite midx_self. trivial. qed. -(* Each idxvar is a non-negative integer by Phase-2 design. The proof - goal is wrapped (inside the lemma's [pa_vars] forall) with one - [0 <= n_i =>] implication per idxvar; the user introduces them - on demand via [move=>]. The implications never leak into the - saved [ax_spec] — only the proof goal sees them. *) -lemma idx_ge0_simple {n} : 0 <= n. +(* A trailing `+` on an idxvar name opts in to a [0 <= n =>] + hypothesis in the proof goal (inserted inside the lemma's + [pa_vars] forall). Without `+`, no hypothesis is added. Marks + never leak into the saved [ax_spec] — only the proof goal + sees them. *) +lemma idx_ge0_simple {n+} : 0 <= n. proof. move=> Hn. trivial. qed. -lemma idx_ge0_smt {m n} : 0 <= m + n. +lemma idx_ge0_smt {m+ n+} : 0 <= m + n. proof. move=> Hm Hn. smt(). qed. -(* Backward compat: [pa_vars] auto-intro still works because the - implications are pushed inside the forall, not at the top. *) -lemma idx_with_args {n} (xs : int vec<:n>) : 0 <= n. +(* [pa_vars] auto-intro still works: the implications are pushed + inside the forall, not at the top. *) +lemma idx_with_args {n+} (xs : int vec<:n>) : 0 <= n. proof. move=> Hn. trivial. qed. +(* Without `+`, no hypothesis is injected — the lemma's body must + be provable as-is. *) +lemma idx_no_marker {n} : true. +proof. trivial. qed. + (* FIFO unification order used to fail on mixed-monomial index equations where a dependent univar is resolved later in the queue (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either From fe9757f809c75c2d7ba0369ea85a1ecc799b52e0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Apr 2026 21:02:15 +0200 Subject: [PATCH 34/40] indexed-types: reject `+` marker on non-lemma binders MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Silently ignoring the [+] idxvar marker outside lemma / axiom binders was misleading — the mark looked accepted but did nothing. Raise a parse error instead so the user sees exactly where the marker is meaningless. New helper [reject_nonneg_marker] in the parser prologue, called from every non-lemma consumer of [ix_ty_binder] (operator, pred, inductive predicate, notation, abbreviation) plus the type-decl sites ([tyd_name], [clone_override.type]). Each produces a clear parse error mentioning both the idxvar name and the declaration kind: type {n+} word. (* parse error: the `+' marker on idxvar `n' only applies to lemma / axiom binders, not to type declarations *) Verified with a fresh rejection test per declaration kind, plus the full regression (304 decls). --- src/ecParser.mly | 46 +++++++++++++++++++++++++++++++++--------- tests/indexed-types.ec | 7 +++++++ 2 files changed, 44 insertions(+), 9 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index d9c7ba0c1d..e4bc1cc005 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -26,6 +26,23 @@ bracket families ({...} vs [...]), so the parser can keep them separate. *) + (* Trailing `+` on an idxvar name only makes sense on lemma / + axiom binders (where it injects [0 <= n =>] into the proof + goal). Non-lemma consumers must reject it explicitly so the + mark is never silently dropped. *) + let reject_nonneg_marker + (where : string) + (nonneg : EcParsetree.psymbol list) + = + match nonneg with + | [] -> () + | x :: _ -> + parse_error (EcLocation.loc x) (Some + (Printf.sprintf + "the `+' marker on idxvar `%s' only applies to lemma / \ + axiom binders, not to %s declarations" + (EcLocation.unloc x) where)) + let opdef_of_opbody ty b = match b with | None -> PO_abstr ty @@ -1718,7 +1735,9 @@ typarams: %inline tyd_name: | idx=loption(idxvars_decl) tya=typarams x=ident - { (List.map fst idx, tya, x) } + { let nonneg = idx |> List.filter snd |> List.map fst in + reject_nonneg_marker "type" nonneg; + (List.map fst idx, tya, x) } dt_ctor_def: | x=oident { (x, []) } @@ -1848,7 +1867,8 @@ operator: { let gloc = EcLocation.make $startpos $endpos in let sty = sty |> ofdfl (fun () -> mk_loc (b |> omap (loc |- fst) |> odfl gloc) PTunivar) in - let (idxvars, _nonneg, po_tyvars) = tvs in + let (idxvars, nonneg, po_tyvars) = tvs in + reject_nonneg_marker "operator" nonneg; { po_kind = k; po_name = List.hd x; @@ -1865,7 +1885,8 @@ operator: x=plist1(oident, COMMA) tvs=ix_ty_binder args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { let (idxvars, _nonneg, po_tyvars) = tvs in + { let (idxvars, nonneg, po_tyvars) = tvs in + reject_nonneg_marker "operator" nonneg; { po_kind = k; po_name = List.hd x; po_aliases = List.tl x; @@ -1937,7 +1958,8 @@ predicate: pp_locality = locality; } } | locality=locality PRED x=oident tvs=ix_ty_binder COLON sty=pred_tydom - { let (idxvars, _nonneg, pp_tyvars) = tvs in + { let (idxvars, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "predicate" nonneg; { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -1945,7 +1967,8 @@ predicate: pp_locality = locality; } } | locality=locality PRED x=oident tvs=ix_ty_binder p=ptybindings? EQ f=form - { let (idxvars, _nonneg, pp_tyvars) = tvs in + { let (idxvars, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "predicate" nonneg; { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -1955,7 +1978,8 @@ predicate: | locality=locality INDUCTIVE x=oident tvs=ix_ty_binder p=ptybindings? EQ b=indpred_def - { let (idxvars, _nonneg, pp_tyvars) = tvs in + { let (idxvars, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "inductive predicate" nonneg; { pp_name = x; pp_idxvars = idxvars; pp_tyvars = pp_tyvars; @@ -2000,7 +2024,8 @@ nt_bindings: notation: | locality=loc(locality) NOTATION x=loc(NOP) tvs=ix_ty_binder bd=nt_bindings? args=nt_arg1* codom=prefix(COLON, loc(type_exp))? EQ body=expr - { let (idxvars, _nonneg, nt_tv) = tvs in + { let (idxvars, nonneg, nt_tv) = tvs in + reject_nonneg_marker "notation" nonneg; { nt_name = x; nt_idx = idxvars; nt_tv = nt_tv; @@ -2027,7 +2052,8 @@ abbreviation: args=ptybindings_decl? sty=prefix(COLON, loc(type_exp))? EQ b=expr { let sty = sty |> ofdfl (fun () -> mk_loc (loc b) PTunivar) in - let (idxvars, _nonneg, ab_tv) = tvs in + let (idxvars, nonneg, ab_tv) = tvs in + reject_nonneg_marker "abbreviation" nonneg; { ab_name = x; ab_idx = idxvars; @@ -3707,7 +3733,9 @@ cltyparams: clone_override: | TYPE idx=loption(idxvars_decl) ps=cltyparams x=qident mode=opclmode t=loc(type_exp) - { (x, PTHO_Type (`BySyntax (List.map fst idx, ps, t), mode)) } + { let nonneg = idx |> List.filter snd |> List.map fst in + reject_nonneg_marker "clone-with-type" nonneg; + (x, PTHO_Type (`BySyntax (List.map fst idx, ps, t), mode)) } | OP x=qoident tyvars=bracket(tident*)? p=ptybinding1* sty=ioption(prefix(COLON, loc(type_exp))) diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index c0c03359b0..5f797e2c04 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -274,6 +274,13 @@ proof. move=> Hn. trivial. qed. lemma idx_no_marker {n} : true. proof. trivial. qed. +(* The `+` marker is rejected on non-lemma binders. Kept as a + comment (uncommenting would produce a clear parse error): + type {n+} foo. (* parse error: type *) + op f {n+} : foo -> int. (* parse error: operator *) + pred p {n+} : foo. (* parse error: predicate *) + abbrev a {n+} : int = 5. (* parse error: abbreviation *) *) + (* FIFO unification order used to fail on mixed-monomial index equations where a dependent univar is resolved later in the queue (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either From 50c82aae19f917b29c9fad3b20c439cb7f813476 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 08:10:16 +0200 Subject: [PATCH 35/40] indexed-types: subst tactic skips idxvars in formula FV iteration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [LowSubst.is_eq_for_subst] walks a formula's free variables and calls [LDecl.by_id] for each to check whether the local has a definition that needs unfolding. But idxvars live in [h_tvar.idxvars], not [h_local], so [by_id] would error out with [unknown identifier `n/...`, please report] — crashing the [subst] tactic and any [move=> ->] / [move=> ->>] that destructured a hypothesis mentioning a bound idxvar. Fix: the [add] helper now consults [h_tvar.idxvars] first and skips ([by_id] is only meaningful for proper locals / hypotheses). Idxvars are constants from the perspective of substitution — they have no body to walk through, so skipping them is sound. Verified with the user's [eqP] proof and a new regression case that uses [move=> ->] on a hypothesis [xs = ys] where both have type [int vec<:n>] (the idxvar [n] would previously crash the substitution). --- src/ecLowGoal.ml | 3 +++ tests/indexed-types.ec | 13 +++++++++++++ 2 files changed, 16 insertions(+) diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 7aa654da86..2a3c924989 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -1876,12 +1876,15 @@ module LowSubst = struct match aout with | None -> None | Some(side,v,f) -> + let idxvars = + Sid.of_list (LDecl.tohyps hyps).h_tvar.idxvars in let rec add fv x _ = if Sid.mem x fv then fv else (* check if x is a declared module *) let fv = Sid.add x fv in if EcEnv.Mod.by_mpath_opt (EcPath.mident x) env <> None then fv + else if Sid.mem x idxvars then fv else match LDecl.by_id x hyps with | LD_var (_, Some f) -> add_f fv f | _ -> fv diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 5f797e2c04..d8d67e35d4 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -281,6 +281,19 @@ proof. trivial. qed. pred p {n+} : foo. (* parse error: predicate *) abbrev a {n+} : int = 5. (* parse error: abbreviation *) *) +(* Subst-tactic resolution used to crash with [unknown identifier + `n/...`] when the formula's free-variable iteration encountered + an idxvar (which lives in [h_tvar.idxvars], not [h_local], so + [LDecl.by_id] errored out). Now those idxvar idents are skipped + during the FV walk. *) +op some_op {n} (xs : int vec<:n>) : bool list. + +axiom some_op_eq {n} (xs : int vec<:n>) : some_op xs = some_op xs. + +lemma test_subst_idx {n} (xs ys : int vec<:n>) : + xs = ys => some_op xs = some_op ys. +proof. by move=> ->. qed. + (* FIFO unification order used to fail on mixed-monomial index equations where a dependent univar is resolved later in the queue (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either From 9adc523c81e5ea1316ff80cefbff8d062dc8865a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 08:12:39 +0200 Subject: [PATCH 36/40] indexed-types: document the idxvar-namespace fragility in memory.md MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Idxvars occupy a hybrid namespace by Phase-2 design: listed in [h_tvar.idxvars] like type params, but also semantically int-typed locals usable in formulas. Every pass that walks formulas / locals / hypotheses has to be taught about this. We've patched seven such sites individually (bind_idx_locals, Op.reduce, pte_idx_link, lenv_of_tparams_for_hyp, LowSubst.add, Fop matcher, deferred IxUni) — each fix small and correct, but the pattern keeps recurring. Document the pattern, the existing patch sites, and three architectural directions to consider if the bug-of-the-week becomes a problem: (1) unify idxvars with formula-locals at AST level, (2) add a [Findex of tindex] form constructor, (3) status quo with an audit checklist for new passes. --- memory.md | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/memory.md b/memory.md index ccbeada7c4..a51ec885bc 100644 --- a/memory.md +++ b/memory.md @@ -671,6 +671,66 @@ F lands last to translate everything we now support). Verified: 91 declarations in `tests/indexed-types.ec` compile, including the new explicit-instantiation cases. +## Idxvars: architectural fragility (TODO: principled treatment) + +The Phase-2 design has idxvars occupy a **hybrid namespace**: +- listed in `h_tvar.idxvars` like type parameters (so they appear + in `ax_tparams`, get printed as "Index variables: …" in the + proof state, etc.); +- but **also** semantically int-typed locals usable in formulas + (per `bind_idx_locals`), in tindex positions (`vec<:n>`), and + bridged at concretize time via `pte_idx_link`. + +Every pass that walks formulas / locals / hypotheses has to be +taught about this hybridness. Each one has been patched ad-hoc: + +- `EcTyping.bind_idx_locals` — register as int local at typecheck. +- `EcEnv.Op.reduce` / `Ax.instantiate` — substitute `Flocal n_lem` + via `f_of_tindex` alongside the tindex substitution. +- `EcProofTerm.pte_idx_link` — record `(idxvar ident, fresh univar)` + pairs so `concretize_env` can synthesise the form binding once + unification pins the univar. +- `EcSmt.lenv_of_tparams_for_hyp` — register each idxvar as an + int constant in `te_lc` so `trans_app`'s `Flocal` case finds it. +- `EcLowGoal.LowSubst.is_eq_for_subst` — skip idxvars during the + formula's free-variable walk (else `LDecl.by_id` errors with + "unknown identifier"). +- `EcMatching` matcher — best-effort index unification on `Fop` + heads, defer-and-retry on mixed-monomial failure. +- `EcUnify.unify_core` — deferred IxUni queue, retry after every + assignment. + +Each fix is small and correct, but the pattern (forget about +idxvars somewhere → mysterious crash → patch the one site) keeps +recurring. Every future feature that touches the form/local/hyp +machinery will need similar care. + +**Architectural directions to consider** (not scheduled): + +1. **Unify idxvars and formula-locals at the AST level.** Make + idxvars "just" int-typed `LD_var` hypotheses with no body, + stored alongside ordinary locals. Carry the "is-idxvar" tag + on the hyp itself rather than a separate `h_tvar.idxvars` + field. Then every existing local-walking pass just works. + Trade-off: tparams.idxvars no longer mirrors tparams.tyvars, + so existing code paths that treat them analogously need a + different anchor. + +2. **A dedicated `Findex` form constructor.** `Findex of tindex` + typed as int, eagerly used wherever an idxvar appears as an + int term. Substitution rules walk into the `tindex` via + `tindex_subst`. Removes the need for `pte_idx_link` and the + `f_of_tindex` partiality. Trade-off: introducing a new `f_node` + variant is wide and touches every form pattern-match. + +3. **Status quo with an audit checklist.** Document the seven + patch sites above as a "when adding a pass that touches forms, + check these" checklist. Cheapest, but the bug-of-the-week + pattern continues. + +If a fourth user surfaces a fourth crash of this shape, (1) or (2) +becomes worth the upfront cost. + ## Critical path & open risks - Phases 0 → 1 → 2 are sequential; the rest can branch. From 8bda965038fba2b92bc4a95b50407d47d1908401 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 08:21:07 +0200 Subject: [PATCH 37/40] indexed-types: register idxvars as int locals in the proof env MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit [LDecl.init] only registers tyvars; idxvars stayed in [h_tvar.idxvars] but the proof env's local context didn't list them as int [LD_var]s. So a tactic argument like [exists n] (where [n] is a bound idxvar used as the existential witness) failed with [unknown variable or constant: `n']. [start_lemma] now passes [idx_locals] — one [(id, LD_var (tint, None))] per idxvar — as [~locals] to [LDecl.init], so the proof env knows about them from the start. The user can now use idxvars as values anywhere in tactic arguments. This is the seventh patch site for the idxvar-namespace fragility documented in memory.md. Verified with the user's [wordW] proof ([exists (mkseq (fun i => w.[i]) n)]) and a new regression test exercising [exists n] as the witness. --- src/ecScope.ml | 13 ++++++++++++- tests/indexed-types.ec | 10 ++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 775deefb36..b825c63ea2 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -951,7 +951,18 @@ module Ax = struct match check with | false -> PSNoCheck | true -> - let hyps = EcEnv.LDecl.init (env scope) axd.ax_tparams in + (* Idxvars need to be available in the proof env as int + locals so the user can reference them in tactic + arguments (e.g. as the witness in [exists e]). They + already appear in [tparams.idxvars] but [LDecl.init] + only registers tyvars; pass them as preset locals. *) + let idx_locals = + List.map + (fun id -> (id, EcBaseLogic.LD_var (tint, None))) + axd.ax_tparams.idxvars in + let hyps = + EcEnv.LDecl.init (env scope) ~locals:idx_locals + axd.ax_tparams in (* For each idxvar marked with `+` in the lemma binder, inject a [0 <= n =>] hypothesis INSIDE the outermost foralls of the goal (so [pa_vars] auto-intro still fires). Unmarked diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index d8d67e35d4..0820fc7cfe 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -294,6 +294,16 @@ lemma test_subst_idx {n} (xs ys : int vec<:n>) : xs = ys => some_op xs = some_op ys. proof. by move=> ->. qed. +(* Idxvars must be available in the proof env as int locals so the + user can reference them as values in tactic arguments (e.g. + the witness in [exists e]). [LDecl.init] only registers tyvars + by default; [start_lemma] now passes idxvars as preset locals. *) +op some_thunk {n} : int -> int. + +lemma test_idx_in_witness {n} (x : int) : + exists (k : int), some_thunk[:n] k = some_thunk[:n] n. +proof. exists n. trivial. qed. + (* FIFO unification order used to fail on mixed-monomial index equations where a dependent univar is resolved later in the queue (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either From 3e986b2a5a751a9f76b409f68141ad8f87782c32 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 08:27:29 +0200 Subject: [PATCH 38/40] indexed-types: register idxvars in env at LDecl.init, not in h_local MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The previous patch added idxvars to [h_local] via [LDecl.init ~locals], creating a duplicate binding for [n]: once as a tparam ([h_tvar.idxvars]) and once as a regular local ([h_local]). That's the wrong design — idxvars should stay solely as tparams. Fix: [LDecl.init] now registers each idxvar via [Var.bind_local id tint] directly in [le_env] (the env exposed via [toenv]) without adding them to [h_local]. Name lookups (e.g. for tactic arguments like [exists n]) resolve the idxvar through the env path; the canonical record stays single (in [h_tvar.idxvars] only). Same observable behaviour as the previous patch (327 decls pass) without the duplication. --- src/ecEnv.ml | 16 +++++++++++++--- src/ecScope.ml | 13 +------------ 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 1c2479a7cc..6a48b0ebf0 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -3525,9 +3525,19 @@ module LDecl = struct (* ------------------------------------------------------------------ *) let init env ?(locals = []) tparams = let buildenv env = - List.fold_right - (fun (x, k) env -> add_local_env x k env) - locals env + let env = + List.fold_right + (fun (x, k) env -> add_local_env x k env) + locals env + in + (* Idxvars are NOT added to [h_local] — they remain solely + tparams. But the env exposed via [toenv] must resolve them + as int values (so a tactic argument [exists n] can refer to + a bound idxvar). Register each idxvar as an int local in + the env only; [h_local] stays clean. *) + List.fold_left + (fun env id -> Var.bind_local id EcTypes.tint env) + env tparams.idxvars in { le_init = env; diff --git a/src/ecScope.ml b/src/ecScope.ml index b825c63ea2..775deefb36 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -951,18 +951,7 @@ module Ax = struct match check with | false -> PSNoCheck | true -> - (* Idxvars need to be available in the proof env as int - locals so the user can reference them in tactic - arguments (e.g. as the witness in [exists e]). They - already appear in [tparams.idxvars] but [LDecl.init] - only registers tyvars; pass them as preset locals. *) - let idx_locals = - List.map - (fun id -> (id, EcBaseLogic.LD_var (tint, None))) - axd.ax_tparams.idxvars in - let hyps = - EcEnv.LDecl.init (env scope) ~locals:idx_locals - axd.ax_tparams in + let hyps = EcEnv.LDecl.init (env scope) axd.ax_tparams in (* For each idxvar marked with `+` in the lemma binder, inject a [0 <= n =>] hypothesis INSIDE the outermost foralls of the goal (so [pa_vars] auto-intro still fires). Unmarked From 5ac1f7fcf682ef8cbc1ca3b21f18d87a96ff7ec4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 09:40:19 +0200 Subject: [PATCH 39/40] indexed-types: `_` placeholder for inferred indices in [op[:...]] Users can now write [op[:_, m]] to fill some index positions explicitly while letting the typechecker infer the rest. Each [_] allocates a fresh [TIUnivar] in the unienv; the surrounding context (call-site argument types, polynomial-equation deferred retry, etc.) pins the univar via the existing unification path. Parser: new [PIhole] variant in [pindex_r], matched by [UNDERSCORE] in [pindex_atom]. Typer: [transtindex] for [PIhole] calls [EcUnify.UniEnv.idx_fresh] (now exposed in the .mli). Examples: op concat {m n} ['a] : 'a vec<:m> -> 'a vec<:n> -> 'a vec<:m+n>. concat[:_, 5] xs ys (* infer first, [5] explicit *) concat[:m, _] xs ys (* [m] explicit, infer second *) concat[:_, _] xs ys (* equivalent to [concat xs ys] *) Useful when the type-directed inference is ambiguous on one position but pinned on another by an annotation. Verified with three new test cases (345 decls total). --- src/ecParser.mly | 1 + src/ecParsetree.ml | 11 +++++++---- src/ecTyping.ml | 5 +++++ src/ecUnify.mli | 3 +++ tests/indexed-types.ec | 18 ++++++++++++++++++ 5 files changed, 34 insertions(+), 4 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index e4bc1cc005..ce574aab0a 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1337,6 +1337,7 @@ pindex_atom: | x=lident { mk_loc x.pl_loc (PIvar x) } | n=loc(UINT) { mk_loc n.pl_loc (PIint n.pl_desc) } +| u=loc(UNDERSCORE) { mk_loc u.pl_loc PIhole } | LPAREN p=pindex RPAREN { p } pindex_mul: diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index eb631fc280..0fa149c823 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -78,10 +78,13 @@ and pty = pty_r located sub-grammar (only +, *, non-negative literals, and identifiers bound as indices). *) and pindex_r = - | PIvar of psymbol - | PIint of zint - | PIadd of pindex * pindex - | PImul of pindex * pindex + | PIvar of psymbol + | PIint of zint + | PIadd of pindex * pindex + | PImul of pindex * pindex + (* `_` placeholder — let the system infer this index by + allocating a fresh [TIUnivar] at typecheck time. *) + | PIhole and pindex = pindex_r located type ptyannot_r = diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 678f032673..63d77f3ea1 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1105,6 +1105,11 @@ and transtindex (env : EcEnv.env) (ue : EcUnify.unienv) (pi : pindex) : tindex = TIAdd (transtindex env ue a, transtindex env ue b) | PImul (a, b) -> TIMul (transtindex env ue a, transtindex env ue b) + | PIhole -> + (* `_` placeholder: allocate a fresh [TIUnivar] in [ue]. The + deferred-retry unifier will pin it via the surrounding + context. *) + EcUnify.UniEnv.idx_fresh ue let transty_for_decl env ty = let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 39f2d99650..b776ad0956 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -25,6 +25,9 @@ module UniEnv : sig val copy : unienv -> unienv (* constant time *) val restore : dst:unienv -> src:unienv -> unit (* constant time *) val fresh : ?ty:ty -> unienv -> ty + (* Allocate a fresh [TIUnivar] in [ue]. Used by the typer to + translate `_` placeholders in pindex positions. *) + val idx_fresh : unienv -> tindex val getnamed : unienv -> symbol -> EcIdent.t (* Indices are declared up front: returns [None] when no binding. *) val getnamed_idx : unienv -> symbol -> EcIdent.t option diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec index 0820fc7cfe..d700ec06f9 100644 --- a/tests/indexed-types.ec +++ b/tests/indexed-types.ec @@ -304,6 +304,24 @@ lemma test_idx_in_witness {n} (x : int) : exists (k : int), some_thunk[:n] k = some_thunk[:n] n. proof. exists n. trivial. qed. +(* `_` placeholder in pindex position lets the user opt out of + one or more indices in an explicit instantiation [op[:e1, e2]] + while keeping inference for the rest. Each [_] allocates a + fresh [TIUnivar] which the surrounding context pins. *) +op append2 {m n} ['a] (xs : 'a vec<:m>) (ys : 'a vec<:n>) : 'a vec<:m+n>. + +op test_hole_first {m} ['a] (xs : 'a vec<:m>) (ys : 'a vec<:5>) + : 'a vec<:m+5> + = append2[:_, 5] xs ys. + +op test_hole_second {m} ['a] (xs : 'a vec<:m>) (ys : 'a vec<:5>) + : 'a vec<:m+5> + = append2[:m, _] xs ys. + +op test_hole_both {m n} ['a] (xs : 'a vec<:m>) (ys : 'a vec<:n>) + : 'a vec<:m+n> + = append2[:_, _] xs ys. + (* FIFO unification order used to fail on mixed-monomial index equations where a dependent univar is resolved later in the queue (e.g. unifying [n*m] against [?n_pack * ?m_pack] before either From 4e93167d5119b94c1fe73c457842bd2d7ab22cca Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 22 Apr 2026 11:23:15 +0200 Subject: [PATCH 40/40] indexed-types: bridge form-evar / tindex-univar via fresh evars When opening a lemma whose body references an idxvar `n` as both an index (TIVar) and an int-typed Flocal (Phase-2 hybrid namespace), the matcher used to compare the lemma's `Flocal n_lem` against the caller's `Flocal m_caller` and fail (distinct idents). Tactics like `rewrite usesN` and `rewrite packE` therefore reported "nothing to rewrite" whenever the axiom referenced `n` as an int term. Fix in two parts: 1. [pt_of_uglobal_r] / [process_named_pterm]: for each idxvar that is referenced in the body's [f_fv], substitute [Flocal id_ax] to a fresh form-evar registered in [pte_ev] and link it to the tindex univar via [pte_idx_link]. Skipping idxvars not in [f_fv] avoids leaving orphan evars that block [can_concretize]. 2. [can_concretize] now calls [propagate_idx_link] first to keep the two namespaces in sync regardless of which side the matcher pinned: - form-evar bound to a form projecting into a tindex => resolve the linked tindex univar via [unify_idx]; - tindex univar resolved to a [TIVar] / [TIConst] => set the linked form-evar to the matching int formula. --- src/ecProofTerm.ml | 129 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 98 insertions(+), 31 deletions(-) diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 965265a6bd..6ba16233ed 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -120,7 +120,53 @@ let rec get_head_symbol (pt : pt_env) (f : form) = | _ -> f (* -------------------------------------------------------------------- *) +(* Bridge bound form-evars and tindex univars in [pte_idx_link]: + + - If the form-evar [fresh] got bound to a form that projects into a + [tindex] (e.g. [Flocal m_lem]), resolve the tindex univar [u] + accordingly so [closed ue] succeeds. + - If the tindex univar [u] got resolved to a [TIVar tid] / [TIConst k] + by index unification (e.g. via [word<:?u> = word<:m_lem>] in a + bound-var type), set the form-evar [fresh] to the matching form + so [MEV.filled] succeeds. + + The matcher binds either side independently; this bridge keeps the + two namespaces in sync prior to the [can_concretize] check. *) +let propagate_idx_link (pt : pt_env) : unit = + let iu = EcUnify.UniEnv.iu_assubst pt.pte_ue in + List.iter (fun (fresh, u) -> + let fresh_set = + match EcMatching.MEV.get fresh `Form !(pt.pte_ev) with + | Some (`Set (`Form _)) -> true + | _ -> false + in + let u_resolved = + match EcUid.Muid.find_opt u iu with + | Some (EcAst.TIUnivar v) when EcUid.uid_equal v u -> None + | x -> x + in + match fresh_set, u_resolved with + | true, _ -> + (match EcMatching.MEV.get fresh `Form !(pt.pte_ev) with + | Some (`Set (`Form f)) -> + (match EcCoreFol.tindex_of_form f with + | Some ti -> + (try EcUnify.unify_idx (LDecl.toenv pt.pte_hy) + pt.pte_ue (EcAst.TIUnivar u) ti + with EcUnify.UnificationFailure _ -> ()) + | None -> ()) + | _ -> ()) + | false, Some ti -> + (match EcCoreFol.f_of_tindex_opt ti with + | Some f when EcMatching.MEV.mem fresh `Form !(pt.pte_ev) + && not (EcMatching.MEV.isset fresh `Form !(pt.pte_ev)) -> + pt.pte_ev := EcMatching.MEV.set fresh (`Form f) !(pt.pte_ev) + | _ -> ()) + | false, None -> ()) + !(pt.pte_idx_link) + let can_concretize (pt : pt_env) = + propagate_idx_link pt; EcMatching.can_concretize !(pt.pte_ev) pt.pte_ue (* -------------------------------------------------------------------- *) @@ -260,21 +306,38 @@ let pt_of_uglobal_r ptenv p = (* FIXME: TC HOOK *) let tv = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in let ix = EcUnify.UniEnv.openidx ptenv.pte_ue typ None in + (* Idxvars also appear as int-typed [Flocal] in the body + (Phase 2). For each idxvar that is REFERENCED as a [Flocal] + in the body, substitute it to a fresh int evar registered in + [pte_ev], so the matcher can bind it via term matching against + the goal's idxvar Flocal. The fresh evar is linked (via + [pte_idx_link]) to the corresponding tindex univar so + [concretize_env] keeps the two sides consistent. Idxvars NOT + referenced as Flocal don't need an evar — leaving one would + block [can_concretize] with an orphan binding. *) + let body_fv = EcAst.f_fv ax in + let loc_subst = ref EcIdent.Mid.empty in + List.iter (fun id -> + if EcIdent.Mid.mem id body_fv then + match EcIdent.Mid.find_opt id ix with + | Some (EcAst.TIUnivar u) -> + let fresh = EcIdent.fresh id in + ptenv.pte_ev := + EcMatching.MEV.add fresh `Form !(ptenv.pte_ev); + ptenv.pte_idx_link := (fresh, u) :: !(ptenv.pte_idx_link); + loc_subst := + EcIdent.Mid.add id (f_local fresh tint) !loc_subst + | _ -> ()) + typ.idxvars; let ax = let fs = EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx:ix () in + let fs = + EcIdent.Mid.fold + (fun id f s -> EcCoreSubst.Fsubst.f_bind_local s id f) + !loc_subst fs in EcCoreSubst.Fsubst.f_subst fs ax in - (* Record (idxvar ident, tindex univar uid) for each lemma idxvar - so [concretize_env] can synthesise the corresponding form-level - binding [Flocal n_lem -> Flocal concrete] once the tindex univar - resolves to a [TIVar concrete]. *) - List.iter (fun id -> - match EcIdent.Mid.find_opt id ix with - | Some (EcAst.TIUnivar u) -> - ptenv.pte_idx_link := (id, u) :: !(ptenv.pte_idx_link) - | _ -> ()) - typ.idxvars; let idxs = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in let typ = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in @@ -566,34 +629,38 @@ let process_named_pterm pe (tvi, fp) = (* FIXME: TC HOOK *) let tv = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in let ix = EcUnify.UniEnv.openidx pe.pte_ue typ tvi in + (* Idxvars are also int-typed formula locals (Phase 2). Three cases: + - [f_of_tindex_opt ti] succeeds (user-provided concrete index): + substitute [Flocal id -> f] directly. + - [TIUnivar u] AND [id] appears in [f_fv ax]: substitute + [Flocal id] to a fresh form-evar registered in [pte_ev], and + link the evar to [u] so [can_concretize] can bridge the two + namespaces on either binding direction. + - otherwise: no substitution needed. *) + let body_fv = EcAst.f_fv ax in + let loc_subst = ref EcIdent.Mid.empty in + EcIdent.Mid.iter (fun id ti -> + match EcCoreFol.f_of_tindex_opt ti with + | Some f -> + loc_subst := EcIdent.Mid.add id f !loc_subst + | None -> + match ti with + | EcAst.TIUnivar u when EcIdent.Mid.mem id body_fv -> + let fresh = EcIdent.fresh id in + pe.pte_ev := EcMatching.MEV.add fresh `Form !(pe.pte_ev); + pe.pte_idx_link := (fresh, u) :: !(pe.pte_idx_link); + loc_subst := EcIdent.Mid.add id (f_local fresh tint) !loc_subst + | _ -> ()) + ix; let ax = let fs = EcCoreSubst.Fsubst.f_subst_init ~freshen:false ~tv ~idx:ix () in - (* Idxvars are also int-typed formula locals (Phase 2): substitute - [Flocal n_lem] alongside [TIVar n_lem]. For univar instantiations, - defer to [pte_idx_link] (populated below) so [concretize_env] - can fill the form binding once unification resolves the - univar. *) let fs = EcIdent.Mid.fold - (fun id ti s -> - match EcCoreFol.f_of_tindex_opt ti with - | Some f -> EcCoreSubst.Fsubst.f_bind_local s id f - | None -> s) - ix fs - in + (fun id f s -> EcCoreSubst.Fsubst.f_bind_local s id f) + !loc_subst fs in EcCoreSubst.Fsubst.f_subst fs ax in - (* Same link mechanism as [pt_of_uglobal_r]: if [openidx] allocated - a fresh [TIUnivar] for any idxvar (because the user did not - supply an explicit index), record it so [concretize_env] can - bridge the tindex / formula-local namespaces. *) - List.iter (fun id -> - match EcIdent.Mid.find_opt id ix with - | Some (EcAst.TIUnivar u) -> - pe.pte_idx_link := (id, u) :: !(pe.pte_idx_link) - | _ -> ()) - typ.idxvars; let typ_out = List.map (fun a -> EcIdent.Mid.find a tv) typ.tyvars in let idxs_out = List.map (fun a -> EcIdent.Mid.find a ix) typ.idxvars in