diff --git a/src/ecAlgTactic.ml b/src/ecAlgTactic.ml index f926a7ff3..e68926a30 100644 --- a/src/ecAlgTactic.ml +++ b/src/ecAlgTactic.ml @@ -70,22 +70,22 @@ module Axioms = struct (div, (false, ty2 ty))] let subst_of_ring (cr : ring) = - let crcore = [(zero, cr.r_zero); - (one , cr.r_one ); - (add , cr.r_add ); - (mul , cr.r_mul ); ] in + let crcore = [(zero, cr.r_zero.ro_op); + (one , cr.r_one .ro_op); + (add , cr.r_add .ro_op); + (mul , cr.r_mul .ro_op); ] in let xpath = fun x -> EcPath.pqname tmod x in let add = fun subst x p -> EcSubst.add_path subst ~src:(xpath x) ~dst:p in 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 - let subst = odfl subst (cr.r_sub |> omap (fun p -> add subst sub p)) in - let subst = odfl subst (cr.r_exp |> omap (fun p -> add subst expr p)) in + let subst = odfl subst (cr.r_opp |> omap (fun o -> add subst opp o.ro_op)) in + let subst = odfl subst (cr.r_sub |> omap (fun o -> add subst sub o.ro_op)) in + let subst = odfl subst (cr.r_exp |> omap (fun o -> add subst expr o.ro_op)) in let subst = match cr.r_kind with @@ -99,7 +99,7 @@ module Axioms = struct let subst = match cr.r_embed with | `Direct | `Default -> subst - | `Embed p -> add subst embed p + | `Embed o -> add subst embed o.ro_op in subst @@ -109,10 +109,47 @@ module Axioms = struct let add = fun subst x p -> EcSubst.add_path subst ~src:(xpath x) ~dst:p in let subst = subst_of_ring cr.f_ring in - let subst = add subst inv cr.f_inv in - let subst = odfl subst (cr.f_div |> omap (fun p -> add subst div p)) in + let subst = add subst inv cr.f_inv.ro_op in + let subst = odfl subst (cr.f_div |> omap (fun o -> add subst div o.ro_op)) in subst + (* The op paths of an instance carry their instantiation implicitly + (each op records the indices/types at which it sits at the + carrier). The template axioms reference the ops without + instantiation, and [subst_of_ring] swaps paths but cannot + re-introduce it; so we patch the substituted axiom, tagging every + instance-op occurrence with its recorded targs. (If two slots + share one path they must also share their instantiation; the + first registered wins.) *) + let ring_op_targs (cr : ring) : EcDecl.ring_op EcPath.Mp.t = + let os = [cr.r_zero; cr.r_one; cr.r_add; cr.r_mul] in + let os = os @ List.filter_map (fun x -> x) [cr.r_opp; cr.r_sub; cr.r_exp] in + let os = match cr.r_embed with `Embed o -> o :: os | _ -> os in + List.fold_left + (fun m (o : EcDecl.ring_op) -> + if EcPath.Mp.mem o.ro_op m then m else EcPath.Mp.add o.ro_op o m) + EcPath.Mp.empty os + + let field_op_targs (cr : field) : EcDecl.ring_op EcPath.Mp.t = + let os = cr.f_inv :: List.filter_map (fun x -> x) [cr.f_div] in + List.fold_left + (fun m (o : EcDecl.ring_op) -> + if EcPath.Mp.mem o.ro_op m then m else EcPath.Mp.add o.ro_op o m) + (ring_op_targs cr.f_ring) os + + let inject_targs (opmap : EcDecl.ring_op EcPath.Mp.t) (f : form) = + let open EcAst in + let rec doit f = + match f.f_node with + | Fop (p, ta) when ta.indices = [] && ta.types = [] -> begin + match EcPath.Mp.find_opt p opmap with + | Some { ro_idxs = []; ro_tys = []; _ } | None -> f + | Some o -> + f_op_r p { indices = o.ro_idxs; types = o.ro_tys } (f_ty f) + end + | _ -> f_map (fun ty -> ty) doit f + in doit f + (* FIXME: should use operators inlining when available *) let get cr env axs = let subst = @@ -121,10 +158,16 @@ module Axioms = struct | `Field cr -> subst_of_field cr in + let opmap = + match cr with + | `Ring cr -> ring_op_targs cr + | `Field cr -> field_op_targs cr + in + let for1 axname = let ax = EcEnv.Ax.by_path (EcPath.pqname tmod axname) env in - assert (ax.ax_tparams = [] && is_axiom ax.ax_kind); - (axname, EcSubst.subst_form subst ax.ax_spec) + assert (ax.ax_tparams.tyvars = [] && ax.ax_tparams.idxvars = [] && is_axiom ax.ax_kind); + (axname, inject_targs opmap (EcSubst.subst_form subst ax.ax_spec)) in List.map for1 axs diff --git a/src/ecAlgebra.ml b/src/ecAlgebra.ml index 2cd7f1aa7..50cdf8dc0 100644 --- a/src/ecAlgebra.ml +++ b/src/ecAlgebra.ml @@ -73,9 +73,11 @@ end type eq = form * form (* -------------------------------------------------------------------- *) -let rapp r op args = +let rapp r (op : EcDecl.ring_op) args = let opty = toarrow (List.map f_ty args) r.r_type in - f_app (f_op op [] opty) args r.r_type + let indices = if op.ro_idxs = [] then None else Some op.ro_idxs in + let tyargs = if op.ro_tys = [] then None else Some op.ro_tys in + f_app (f_op op.ro_op ?indices ?tyargs opty) args r.r_type let rzero r = rapp r r.r_zero [] let rone r = rapp r r.r_one [] @@ -150,13 +152,16 @@ let emb_fone r = emb_rone r.f_ring (* -------------------------------------------------------------------- *) type cringop = [`Zero | `One | `Add | `Opp | `Sub | `Mul | `Exp | `OfInt] -type cring = ring * (cringop Mp.t) +type cring = ring * ((cringop * EcDecl.ring_op) Mp.t) (* -------------------------------------------------------------------- *) type cfieldop = [cringop | `Inv | `Div] -type cfield = field * (cfieldop Mp.t) +type cfield = field * ((cfieldop * EcDecl.ring_op) Mp.t) (* -------------------------------------------------------------------- *) +(* Recognition is keyed by op path, then checked against the slot's + recorded instantiation: an occurrence of the same path at OTHER + indices/types is not this ring's operator. *) let cring_of_ring (r : ring) : cring = let cr = [(r.r_zero, `Zero); (r.r_one , `One ); @@ -164,21 +169,24 @@ let cring_of_ring (r : ring) : cring = (r.r_mul , `Mul );] in - let cr = List.fold_left (fun m (p, op) -> Mp.add p op m) Mp.empty cr in - let cr = odfl cr (r.r_opp |> omap (fun p -> Mp.add p `Opp cr)) in - let cr = odfl cr (r.r_sub |> omap (fun p -> Mp.add p `Sub cr)) in - let cr = odfl cr (r.r_exp |> omap (fun p -> Mp.add p `Exp cr)) in + let radd (o : EcDecl.ring_op) tag m = Mp.add o.ro_op (tag, o) m in + let cr = List.fold_left (fun m (o, tag) -> radd o tag m) Mp.empty cr in + let cr = odfl cr (r.r_opp |> omap (fun o -> radd o `Opp cr)) in + let cr = odfl cr (r.r_sub |> omap (fun o -> radd o `Sub cr)) in + let cr = odfl cr (r.r_exp |> omap (fun o -> radd o `Exp cr)) in let cr = r.r_embed |> - (function (`Direct | `Default) -> cr | `Embed p -> Mp.add p `OfInt cr) in + (function (`Direct | `Default) -> cr | `Embed o -> radd o `OfInt cr) in (r, cr) let ring_of_cring (cr:cring) = fst cr (* -------------------------------------------------------------------- *) let cfield_of_field (r : field) : cfield = - let cr = (snd (cring_of_ring r.f_ring) :> cfieldop Mp.t) in - let cr = Mp.add r.f_inv `Inv cr in - let cr = odfl cr (r.f_div |> omap (fun p -> Mp.add p `Div cr)) in + let cr = + (snd (cring_of_ring r.f_ring) :> (cfieldop * EcDecl.ring_op) Mp.t) in + let cr = Mp.add r.f_inv.ro_op (`Inv, r.f_inv) cr in + let cr = + odfl cr (r.f_div |> omap (fun o -> Mp.add o.ro_op (`Div, o) cr)) in (r, cr) let field_of_cfield (cr:cfield) : field = fst cr @@ -192,10 +200,14 @@ let toring hyps ((r, cr) : cring) (rmap : RState.rstate) (form : form) = let rec doit form = let o, args = destr_app form in match o.f_node with - | Fop (op, _) -> begin + | Fop (op, ta) -> begin match Mp.find_opt op cr with | None -> abstract form - | Some op -> begin + | Some (_, ro) + when not (List.all2 EcAst.tindex_equal ta.indices ro.ro_idxs + && List.all2 ty_equal ta.types ro.ro_tys) -> + abstract form + | Some (op, _) -> begin match op,args with | `Zero, [] -> PEc c0 | `One , [] -> PEc c1 @@ -255,10 +267,14 @@ let tofield hyps ((r, cr) : cfield) (rmap : RState.rstate) (form : form) = let rec doit form = let o, args = destr_app form in match o.f_node with - | Fop(op, _) -> begin + | Fop(op, ta) -> begin match Mp.find_opt op cr with | None -> abstract form - | Some op -> begin + | Some (_, ro) + when not (List.all2 EcAst.tindex_equal ta.indices ro.ro_idxs + && List.all2 ty_equal ta.types ro.ro_tys) -> + abstract form + | Some (op, _) -> begin match op,args with | `Zero, [] -> FEc c0 | `One , [] -> FEc c1 diff --git a/src/ecAlgebra.mli b/src/ecAlgebra.mli index 5a4d823f7..a7994fd00 100644 --- a/src/ecAlgebra.mli +++ b/src/ecAlgebra.mli @@ -16,7 +16,7 @@ module RState : sig end (* -------------------------------------------------------------------- *) -val rapp : ring -> EcPath.path -> form list -> form +val rapp : ring -> EcDecl.ring_op -> form list -> form val rzero : ring -> form val rone : ring -> form val radd : ring -> form -> form -> form diff --git a/src/ecAlphaInvHashtbl.ml b/src/ecAlphaInvHashtbl.ml index 653da4a3e..afa558891 100644 --- a/src/ecAlphaInvHashtbl.ml +++ b/src/ecAlphaInvHashtbl.ml @@ -5,8 +5,9 @@ The hash is invariant under the renaming of bound variables: a bound occurrence is hashed by the de-Bruijn *level* of its binder (an integer, intrinsically stable) rather than by its name, so - alpha-equivalent formulas hash equal. Free variables, operators and - types are stable under alpha-renaming and are hashed as-is. + alpha-equivalent formulas hash equal. Free variables, operators + (with their type and index instantiations) and types are stable + under alpha-renaming and are hashed as-is. The hash traverses the whole formula, but is memoized on the hash-cons tag ([f_tag]) of every subformula reached with no binder in scope: each @@ -78,7 +79,7 @@ let hash_memo (memo : (int, int) Hashtbl.t) (f0 : form) : int = combine 3 (pv_hash pv) | Fglob (mp, _m) -> combine 4 (id_hash mp) | Fop (p, tys) -> - combine 5 (combine_list (EcPath.p_hash p) (List.map ty_hash tys)) + combine 5 (targ_hash (EcPath.p_hash p) tys) | Fif (c, t, f) -> combine 6 (combine_list 0 [hash e c; hash e t; hash e f]) | Fmatch (c, bs, ty) -> combine 7 (combine_list (ty_hash ty) (hash e c :: List.map (hash e) bs)) diff --git a/src/ecAst.ml b/src/ecAst.ml index dc04fe95e..5f79c05c8 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -54,9 +54,21 @@ 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 + | TIUnivar of EcUid.uid + | 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 +96,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 +197,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 @@ -1202,10 +1214,356 @@ let pr_hash pr = (f_hash pr.pr_args) (Why3.Hashcons.combine (f_hash pr.pr_event.inv) (mem_hash pr.pr_event.m)) +(* ----------------------------------------------------------------- *) +(* 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. *) +(* ----------------------------------------------------------------- *) + +(* 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_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: + - 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; +} + +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 = 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 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 = 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 + +(* 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 = [([(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; + 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 + | 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) + +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 + +(* 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 + +(* 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 + 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) + +(* Canonical (normal) form of an index: e.g. [4 + 1] becomes [5], + [n + n] becomes [2 * n]. Two indices are [tindex_equal] iff their + normal forms coincide. *) +let tindex_normalize (ti : tindex) : tindex = + tindex_of_canonical (tindex_canonicalize ti) + +(* 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 + (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 + Why3.Hashcons.combine_list pair_hash (EcBigInt.hash p.cn_konst) p.cn_mons (* ----------------------------------------------------------------- *) (* 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.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 + +(* 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 + | TIUnivar _ -> 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) = + 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) + +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 @@ -1224,8 +1582,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 @@ -1238,7 +1596,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 = @@ -1250,7 +1608,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; } @@ -1275,9 +1633,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) @@ -1320,9 +1677,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 @@ -1359,7 +1715,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) @@ -1410,8 +1766,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 @@ -1465,8 +1821,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 @@ -1505,7 +1861,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 a13023aec..1e42fac81 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -48,9 +48,21 @@ 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 + | TIUnivar of EcUid.uid + | 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; @@ -78,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 *) @@ -91,7 +103,6 @@ and ebinding = EcIdent.t * ty and ebindings = ebinding list (* -------------------------------------------------------------------- *) - and lvalue = | LvVar of (prog_var * ty) | LvTuple of (prog_var * ty) list @@ -179,7 +190,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 @@ -466,6 +477,31 @@ 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 tindex_hash : tindex hash +val targ_hash : int -> targs -> int +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 + +(* 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 + +(* 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 + +(* Canonical (normal) form of an index; [tindex_equal] on normal forms. *) +val tindex_normalize : tindex -> tindex + val ty_equal : ty equality val ty_hash : ty hash val ty_fv : ty fv diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 227ed19d1..919f3c557 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -68,6 +68,12 @@ let rec f_eq_simpl st f1 f2 = if f_equal f1 f2 then f_true else match fst_map f_node (destr_app f1), fst_map f_node (destr_app f2) with + (* Ignoring the ctor targs (types AND indices) is sound only because + datatypes are NON-REFINING: a ctor's result type is the datatype + at its own binders, so same-typed ctor applications have + canonically equal targs (f1/f2 share a type here). A refining- + datatype extension must revisit this and the parallel case in + EcReduction.reduce_logic. *) | (Fop (p1, _), args1), (Fop (p2, _), args2) when EcEnv.Op.is_dtype_ctor st.st_env p1 && EcEnv.Op.is_dtype_ctor st.st_env p2 -> @@ -217,7 +223,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 +251,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 +306,9 @@ 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 + EcFol.f_subst_tparams ~freshen:true + op.EcDecl.op_tparams.idxvars op.EcDecl.op_tparams.tyvars + tys body in Some (cbv st subst body (Args.create ty eargs)) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index d28eb1df4..84c23501b 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -200,7 +200,7 @@ let rec pp_circ_error ppe fmt (err : circuit_error) = let rec ctype_of_ty (env : env) (ty : ty) : ctype = match ty.ty_node with | Ttuple tys -> CTuple (List.map (ctype_of_ty env) tys) - | Tconstr (pth, []) when pth = EcCoreLib.CI_Bool.p_bool -> cbool + | Tconstr (pth, { indices = []; types = [] }) when pth = EcCoreLib.CI_Bool.p_bool -> cbool | _ -> begin match EcEnv.Circuit.lookup_array_and_bitstring env ty with | Some ({size = _, Some size_arr}, {size = _, Some size_bs}) -> @@ -581,7 +581,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = arg_of_init (fun i -> circuit_of_node isubst st (fapply_safe f [f_int (BI.of_int i)])) end - | {ty_node = Tconstr (p, [t])} + | {ty_node = Tconstr (p, { indices = []; types = [t] })} when EcPath.p_equal p EcCoreLib.CI_List.p_list && type_has_bindings env t -> let cs = diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 3e08fb640..21f734797 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -850,6 +850,7 @@ and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) match match g.pl_desc with | Gtype t -> `Fct (fun scope -> process_types ?src scope (List.map (mk_loc loc) t)) + | Gdeclidx ns -> `Fct (fun scope -> EcScope.Index.declare scope ns) | Gsubtype t -> `Fct (fun scope -> process_subtype scope (mk_loc loc t)) | Gtycinstance t -> `Fct (fun scope -> process_tycinst scope (mk_loc loc t)) | Gmodule m -> `Fct (fun scope -> process_module ?src scope m) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 04a8d03d8..04bc823a0 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 : ty) (m : memory) : ss_inv = + f_pvar pv_arg ty m -let f_pvarg ty m = f_pvar pv_arg ty m +let f_pvlocs (vs : variable list) (m : memory) = + List.map (fun v -> f_pvloc v m) vs -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_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 (* -------------------------------------------------------------------- *) @@ -221,13 +239,13 @@ let f_exists_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 @@ -260,7 +278,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 @@ -355,13 +375,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 @@ -378,20 +398,49 @@ 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]. 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 -> 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 + +(* CONTRACT: [ti] must be univar-free (callers on open-form paths use + [f_of_tindex_opt] and handle [None]); a univar here is an internal + invariant violation. *) +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 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 @@ -420,11 +469,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 = @@ -465,10 +517,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 @@ -959,8 +1013,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 @@ -1005,7 +1059,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 @@ -1047,7 +1101,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 @@ -1078,6 +1132,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 198c6ebc7..f586c2a91 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -95,7 +95,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 @@ -199,6 +200,14 @@ 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]. + 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 val f_some : form -> form @@ -251,13 +260,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 @@ -331,6 +340,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/ecCoreGoal.ml b/src/ecCoreGoal.ml index 728824b4d..6088818f3 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 2f1b51740..90c73e89e 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/ecCorePrinting.ml b/src/ecCorePrinting.ml index c576efca1..5f364c925 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -51,6 +51,7 @@ module type PrinterAPI = sig val pp_expr : PPEnv.t -> expr pp val pp_form : PPEnv.t -> form pp val pp_type : PPEnv.t -> ty pp + val pp_tindex : PPEnv.t -> tindex pp val pp_tyname : PPEnv.t -> path pp val pp_axname : PPEnv.t -> path pp val pp_tcname : PPEnv.t -> path pp diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 5df52665e..bbf6a6974 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; @@ -160,13 +175,55 @@ 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. 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 +235,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 @@ -185,6 +249,24 @@ 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 +(* -------------------------------------------------------------------- *) +(* 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 = + 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 @@ -259,10 +341,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 @@ -435,10 +517,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 @@ -725,6 +807,33 @@ module Tuni = struct end (* -------------------------------------------------------------------- *) +(* Freshen a body's declaration parameters of BOTH kinds. Idxvars are + renamed in both their namespaces: tindex positions AND their + int-typed formula-local occurrences (renaming only one leaves the + other dangling, making the declaration unusable). Returns the + substituted form and the fresh (idxvars, tyvars). *) +let f_freshen_tparams + (idxvars : ident list) (tyvars : ident list) (body : form) + : form * ident list * ident list += + let axipm = List.map EcIdent.fresh idxvars in + let axpm = List.map EcIdent.fresh tyvars in + let fs = + Fsubst.f_subst_init ~freshen:true + ~tv:(List.fold_left2 + (fun m id v -> Mid.add id (tvar v) m) + Mid.empty tyvars axpm) + ~idx:(List.fold_left2 + (fun m id v -> Mid.add id (TIVar v) m) + Mid.empty idxvars axipm) + () in + let fs = + List.fold_left2 + (fun fs oldi newi -> + Fsubst.f_bind_local fs oldi (EcCoreFol.f_local newi tint)) + fs idxvars axipm in + (Fsubst.f_subst fs body, axipm, axpm) + module Tvar = struct let subst (s : ty Mid.t) (ty : ty) : ty = ty_subst { f_subst_id with fs_v = s } ty diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 7743ee452..3dc9d7a19 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 @@ -43,6 +45,14 @@ module Tuni : sig end (* -------------------------------------------------------------------- *) +(* Freshen a body's declaration parameters of both kinds; idxvars are + renamed in BOTH namespaces (tindex positions and int-typed + formula-local occurrences). Returns (body, fresh idxvars, fresh + tyvars). *) +val f_freshen_tparams : + EcIdent.t list -> EcIdent.t list -> form + -> form * EcIdent.t list * EcIdent.t list + module Tvar : sig val init : EcIdent.t list -> ty list -> ty Mid.t val subst1 : (EcIdent.t * ty) -> ty -> ty @@ -56,8 +66,10 @@ 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 tindex_subst : tindex substitute + val ty_subst : ty substitute val e_subst : expr substitute val s_subst : stmt substitute @@ -71,6 +83,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/ecDecl.ml b/src/ecDecl.ml index 29449d29a..a72312c60 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 @@ -55,16 +58,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; @@ -75,7 +81,7 @@ let abs_tydecl ?(params = `Int 0) lc = (* -------------------------------------------------------------------- *) 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 (* -------------------------------------------------------------------- *) @@ -282,7 +288,7 @@ let operator_as_exception (op : operator) = let operator_of_exception (ex: exception_) = let ty = EcTypes.toarrow ex.exn_dom EcTypes.texn in - mk_op ~opaque: optransparent [] ty (Some (OP_Exn ex.exn_dom)) ex.exn_loca + mk_op ~opaque: optransparent { idxvars = []; tyvars = [] } ty (Some (OP_Exn ex.exn_dom)) ex.exn_loca (* -------------------------------------------------------------------- *) let axiomatized_op @@ -293,11 +299,8 @@ let axiomatized_op (lc : locality) : axiom = - let axbd, axpm = - let bdpm = tparams in - let axpm = List.map EcIdent.fresh bdpm in - (CS.Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) axbd, - axpm) + let axbd, axipm, axpm = + CS.f_freshen_tparams tparams.idxvars tparams.tyvars axbd in let args, axbd = @@ -310,11 +313,14 @@ 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 indices = List.map (fun id -> EcAst.TIVar id) axipm in + let op = + f_op path ~indices ~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 - { ax_tparams = axpm; + { ax_tparams = { idxvars = axipm; tyvars = axpm }; ax_spec = axspec; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -335,20 +341,64 @@ type rkind = [ | `Modulus of (BI.zint option) pair ] +(* An instance operator with its own recorded instantiation, captured + at typed selection: the indices/types (over the instance's binders) + at which the operator sits at the carrier's type. E.g. a + predecessor-shaped [exp {n} : t<:n+1> -> ...] at carrier [t<:wsz+1>] + records [ro_idxs = [wsz]]. *) +type ring_op = { + ro_op : EcPath.path; + ro_idxs : tindex list; + ro_tys : EcTypes.ty list; +} + +let ring_op_equal (o1 : ring_op) (o2 : ring_op) = + EcPath.p_equal o1.ro_op o2.ro_op + && List.all2 tindex_equal o1.ro_idxs o2.ro_idxs + && List.all2 EcTypes.ty_equal o1.ro_tys o2.ro_tys + +(* Map over a ring_op's instantiation components (substitutions). *) +let ring_op_map (fp : EcPath.path -> EcPath.path) + (fty : EcTypes.ty -> EcTypes.ty) (fix : tindex -> tindex) + (o : ring_op) = + { ro_op = fp o.ro_op; + ro_idxs = List.map fix o.ro_idxs; + ro_tys = List.map fty o.ro_tys; } + type ring = { r_name : EcSymbols.symbol option; r_type : EcTypes.ty; - r_zero : EcPath.path; - r_one : EcPath.path; - r_add : EcPath.path; - r_opp : EcPath.path option; - r_mul : EcPath.path; - r_exp : EcPath.path option; - r_sub : EcPath.path option; - r_embed : [ `Direct | `Embed of EcPath.path | `Default]; + r_zero : ring_op; + r_one : ring_op; + r_add : ring_op; + r_opp : ring_op option; + r_mul : ring_op; + r_exp : ring_op option; + r_sub : ring_op option; + r_embed : [ `Direct | `Embed of ring_op | `Default]; r_kind : rkind; } +let ring_map (fp : EcPath.path -> EcPath.path) + (fty : EcTypes.ty -> EcTypes.ty) (fix : tindex -> tindex) + (r : ring) = + let fo = ring_op_map fp fty fix in + { r_name = r.r_name; + r_type = fty r.r_type; + r_zero = fo r.r_zero; + r_one = fo r.r_one; + r_add = fo r.r_add; + r_opp = omap fo r.r_opp; + r_mul = fo r.r_mul; + r_exp = omap fo r.r_exp; + r_sub = omap fo r.r_sub; + r_embed = + (match r.r_embed with + | `Direct -> `Direct + | `Default -> `Default + | `Embed o -> `Embed (fo o)); + r_kind = r.r_kind; } + let kind_equal k1 k2 = match k1, k2 with | `Boolean, `Boolean -> true @@ -362,31 +412,36 @@ let kind_equal k1 k2 = let ring_equal r1 r2 = EcTypes.ty_equal r1.r_type r2.r_type - && EcPath.p_equal r1.r_zero r2.r_zero - && EcPath.p_equal r1.r_one r2.r_one - && EcPath.p_equal r1.r_add r2.r_add - && EcUtils.oall2 EcPath.p_equal r1.r_opp r2.r_opp - && EcPath.p_equal r1.r_mul r2.r_mul - && EcUtils.oall2 EcPath.p_equal r1.r_exp r2.r_exp - && EcUtils.oall2 EcPath.p_equal r1.r_sub r2.r_sub + && ring_op_equal r1.r_zero r2.r_zero + && ring_op_equal r1.r_one r2.r_one + && ring_op_equal r1.r_add r2.r_add + && EcUtils.oall2 ring_op_equal r1.r_opp r2.r_opp + && ring_op_equal r1.r_mul r2.r_mul + && EcUtils.oall2 ring_op_equal r1.r_exp r2.r_exp + && EcUtils.oall2 ring_op_equal r1.r_sub r2.r_sub && kind_equal r1.r_kind r2.r_kind && match r1.r_embed, r2.r_embed with | `Direct , `Direct -> true - | `Embed p1, `Embed p2 -> EcPath.p_equal p1 p2 + | `Embed o1, `Embed o2 -> ring_op_equal o1 o2 | `Default , `Default -> true | _ , _ -> false type field = { f_ring : ring; - f_inv : EcPath.path; - f_div : EcPath.path option; + f_inv : ring_op; + f_div : ring_op option; } +let field_map fp fty fix (f : field) = + { f_ring = ring_map fp fty fix f.f_ring; + f_inv = ring_op_map fp fty fix f.f_inv; + f_div = omap (ring_op_map fp fty fix) f.f_div; } + let field_equal f1 f2 = ring_equal f1.f_ring f2.f_ring - && EcPath.p_equal f1.f_inv f2.f_inv - && EcUtils.oall2 EcPath.p_equal f1.f_div f2.f_div + && ring_op_equal f1.f_inv f2.f_inv + && EcUtils.oall2 ring_op_equal f1.f_div f2.f_div (* -------------------------------------------------------------------- *) type binding_size = form * (int option) diff --git a/src/ecDecl.mli b/src/ecDecl.mli index d555d8b9f..0faf9bfe3 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 = @@ -198,29 +201,55 @@ type rkind = [ | `Modulus of (zint option) pair ] +(* An instance operator with its own recorded instantiation (indices + and types over the instance's binders), captured at typed + selection against the carrier. *) +type ring_op = { + ro_op : EcPath.path; + ro_idxs : tindex list; + ro_tys : EcTypes.ty list; +} + +val ring_op_equal : ring_op -> ring_op -> bool +val ring_op_map : + (EcPath.path -> EcPath.path) + -> (EcTypes.ty -> EcTypes.ty) + -> (tindex -> tindex) + -> ring_op -> ring_op + type ring = { r_name : EcSymbols.symbol option; r_type : EcTypes.ty; - r_zero : EcPath.path; - r_one : EcPath.path; - r_add : EcPath.path; - r_opp : EcPath.path option; - r_mul : EcPath.path; - r_exp : EcPath.path option; - r_sub : EcPath.path option; - r_embed : [ `Direct | `Embed of EcPath.path | `Default]; + r_zero : ring_op; + r_one : ring_op; + r_add : ring_op; + r_opp : ring_op option; + r_mul : ring_op; + r_exp : ring_op option; + r_sub : ring_op option; + r_embed : [ `Direct | `Embed of ring_op | `Default]; r_kind : rkind; } val ring_equal : ring -> ring -> bool +val ring_map : + (EcPath.path -> EcPath.path) + -> (EcTypes.ty -> EcTypes.ty) + -> (tindex -> tindex) + -> ring -> ring (* -------------------------------------------------------------------- *) type field = { f_ring : ring; - f_inv : EcPath.path; - f_div : EcPath.path option; + f_inv : ring_op; + f_div : ring_op option; } val field_equal : field -> field -> bool +val field_map : + (EcPath.path -> EcPath.path) + -> (EcTypes.ty -> EcTypes.ty) + -> (tindex -> tindex) + -> field -> field (* -------------------------------------------------------------------- *) type binding_size = form * (int option) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 62b8bf4af..b0730de9c 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -219,6 +219,7 @@ type preenv = { env_ntbase : ntbase Mop.t; env_albase : path Mp.t; (* theory aliases *) env_modlcs : Sid.t; (* declared modules *) + env_idxdecl : EcIdent.t list; (* section-declared indices (ℕ) *) env_item : theory_item list; (* in reverse order *) env_norm : env_norm ref; env_crbds : crbindings; @@ -354,6 +355,7 @@ let empty gstate = env_ntbase = Mop.empty; env_albase = Mp.empty; env_modlcs = Sid.empty; + env_idxdecl = []; env_item = []; env_norm = ref empty_norm_cache; env_crbds = empty_crbindings; @@ -363,6 +365,20 @@ let empty gstate = let copy (env : env) = { env with env_gstate = EcGState.copy env.env_gstate } +(* -------------------------------------------------------------------- *) +(* Section-declared indices (natural-number parameters). They live in + the environment so that [word<:n>] resolves without an explicit [{n}] + binder; they are generalized back to [{n}] index binders on section + close. *) +let declared_indices (env : env) : EcIdent.t list = + env.env_idxdecl + +let lookup_declared_index (name : symbol) (env : env) : EcIdent.t option = + List.find_opt (fun id -> EcIdent.name id = name) env.env_idxdecl + +let push_declared_index (id : EcIdent.t) (env : env) : env = + { env with env_idxdecl = id :: env.env_idxdecl } + (* -------------------------------------------------------------------- *) type lookup_error = [ | `XPath of xpath @@ -831,9 +847,12 @@ 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 indices = List.map (fun id -> TIVar id) tyd.tyd_params.idxvars in let for1 i (c, aty) = - let aty = EcTypes.toarrow aty (tconstr mypath params) 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) @@ -872,11 +891,13 @@ 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 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 mypath params) 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 @@ -897,7 +918,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) 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 @@ -947,14 +968,14 @@ 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) = 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 @@ -964,7 +985,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 @@ -974,7 +995,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; @@ -1537,7 +1558,7 @@ module Reduction = struct let p : topsym = match rule.rl_ptn with - | Rule (`Op p, _) -> `Path (fst p) + | Rule (`Op (p, _, _), _) -> `Path p | Rule (`Tuple, _) -> `Tuple | Rule (`Proj i, _) -> `Proj i | Var _ | Int _ -> assert false in @@ -2606,11 +2627,20 @@ 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) + (* Substitute BOTH parameter kinds: an indexed alias's body + mentions its formal index variables. *) + (* Ill-arity applications are corrupt nodes: fail loudly. *) + assert (List.compare_lengths + tyd.tyd_params.idxvars args.indices = 0); + ty_subst + (f_subst_init + ~tv:(Tvar.init tyd.tyd_params.tyvars args.types) + ~idx:(EcIdent.Mid.of_list + (List.combine tyd.tyd_params.idxvars args.indices)) + ()) body | _ -> raise (LookupFailure (`Path name)) @@ -2661,7 +2691,7 @@ module Ty = struct 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 = @@ -2767,9 +2797,43 @@ 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 + let tparams = op.op_tparams in + (* Arity mismatches are corrupt applications: fail loudly + (silently skipping the substitution produced bodies with + dangling parameters). *) + assert (List.compare_lengths tys.types tparams.tyvars = 0); + assert (List.compare_lengths tys.indices tparams.idxvars = 0); + let tv = + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.tyvars tys.types + in + let idx = + 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 + (* 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 -> + 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 let is_projection env p = try EcDecl.is_proj (by_path p env) @@ -2887,10 +2951,48 @@ 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 tys f + let tparams = ax.ax_tparams in + (* Kernel discipline: the index instantiation must cover the + axiom's idxvars exactly -- an empty list is only valid for + an index-free axiom (a partial map would leave dangling + idxvars in the produced statement). *) + if List.compare_lengths idxs tparams.idxvars <> 0 then + raise (LookupFailure (`Path p)); + let idx_map = + 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 + (* 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 -> + 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 | _ -> raise (LookupFailure (`Path p)) let iter ?name f (env : env) = @@ -2905,15 +3007,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 (* -------------------------------------------------------------------- *) @@ -3144,9 +3246,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; @@ -3362,12 +3474,12 @@ module Circuit = struct let k, _ = Ty.lookup (EcPath.toqsymbol k) (env) in match Mp.find_opt k env.env_crbds.bitstrings with | Some _ as bs -> bs - | None -> try lookup_bitstring env (Ty.unfold k [] env) + | None -> try lookup_bitstring env (Ty.unfold k (EcTypes.mk_targs ()) env) with LookupFailure _ -> None and lookup_bitstring (env : env) (ty : ty) : crb_bitstring option = match ty.ty_node with - | Tconstr (p, []) -> lookup_bitstring_path env p + | Tconstr (p, { indices = []; types = [] }) -> lookup_bitstring_path env p | _ -> None let lookup_bitstring_size_path (env : env) (pth : path) : int option = @@ -3385,17 +3497,17 @@ module Circuit = struct match Mp.find_opt k env.env_crbds.arrays with | Some arr -> Some arr | None -> try - lookup_array env (Ty.unfold pth [] env) + lookup_array env (Ty.unfold pth (EcTypes.mk_targs ()) env) with LookupFailure _ -> None and lookup_array (env : env) (ty : ty) : crb_array option = match ty.ty_node with - | Tconstr (p, [_w]) -> lookup_array_path env p + | Tconstr (p, { indices = []; types = [_w] }) -> lookup_array_path env p | _ -> None let rec lookup_array_and_bitstring (env: env) (ty: ty) : (crb_array * crb_bitstring) option = match ty.ty_node with - | Tconstr (p, [w]) -> + | Tconstr (p, { indices = []; types = [w] }) -> notify env `Debug "Unfolding parametric type with path %s@." (EcPath.tostring p); let arr = lookup_array_path env p in let bs = lookup_bitstring env w in @@ -3403,10 +3515,10 @@ module Circuit = struct | Some arr, Some bs -> Some (arr, bs) | _ -> None end - | Tconstr (p, []) -> + | Tconstr (p, { indices = []; types = [] }) -> notify env `Debug "Unfolding non parametric type with path %s@." (EcPath.tostring p); (try - lookup_array_and_bitstring env (Ty.unfold p [] env) + lookup_array_and_bitstring env (Ty.unfold p (EcTypes.mk_targs ()) env) with LookupFailure _ -> None) | _ -> None diff --git a/src/ecEnv.mli b/src/ecEnv.mli index debf6ce40..ab72abe42 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -53,6 +53,12 @@ val scope : env -> scope val gstate : env -> EcGState.gstate val copy : env -> env +(* -------------------------------------------------------------------- *) +(* Section-declared indices (natural-number parameters). *) +val declared_indices : env -> EcIdent.t list +val lookup_declared_index : symbol -> env -> EcIdent.t option +val push_declared_index : EcIdent.t -> env -> env + (* -------------------------------------------------------------------- *) val notify : ?immediate:bool -> env -> EcGState.loglevel @@ -198,7 +204,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 (* -------------------------------------------------------------------- *) @@ -346,7 +353,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 @@ -380,7 +387,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 @@ -389,7 +396,7 @@ module Ty : sig val scheme_of_ty : - [`Ind | `Case] -> EcTypes.ty -> env -> (path * EcTypes.ty list) option + [`Ind | `Case] -> EcTypes.ty -> env -> (path * EcAst.targs) option val signature : env -> ty -> ty list * ty diff --git a/src/ecFol.ml b/src/ecFol.ml index 7a9fbf494..5a899c8fe 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) @@ -69,25 +69,58 @@ let destr_rint f = try destr_int f1 with DestrError _ -> destr_error "destr_rint" end - | Fop (p, _) when EcPath.p_equal p CI.CI_Real.p_real0 -> BI.zero - | Fop (p, _) when EcPath.p_equal p CI.CI_Real.p_real1 -> BI.one + | Fop (p, { indices = []; types = [] }) + when EcPath.p_equal p CI.CI_Real.p_real0 -> BI.zero + | Fop (p, { indices = []; types = [] }) + when EcPath.p_equal p CI.CI_Real.p_real1 -> BI.one | _ -> 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 +(* -------------------------------------------------------------------- *) +(* Instantiate an operator body at explicit [targs]: type variables via + the type substitution; index variables in BOTH their namespaces -- + tindex positions AND their int-typed formula-local occurrences (an + idxvar the body uses as an int term must resolve to the call-site + index). Mirrors [EcEnv.Op.reduce]. *) +let f_subst_tparams + ~(freshen : bool) + (idxvars : EcIdent.t list) + (tyvars : EcIdent.t list) + (tys : targs) + (body : form) : form += + let tv = + List.fold_left2 + (fun m id v -> Mid.add id v m) + Mid.empty tyvars tys.types in + let idx = + List.fold_left2 + (fun m id v -> Mid.add id v m) + Mid.empty idxvars tys.indices in + let fs = Fsubst.f_subst_init ~freshen ~tv ~idx () in + let fs = + List.fold_left2 + (fun s id v -> + match f_of_tindex_opt v with + | Some f -> Fsubst.f_bind_local s id f + | None -> s) + fs idxvars tys.indices in + Fsubst.f_subst fs body + (* -------------------------------------------------------------------- *) let f_real_le f1 f2 = f_app fop_real_le [f1; f2] tbool let f_real_lt f1 f2 = f_app fop_real_lt [f1; f2] tbool @@ -119,25 +152,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 +184,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 +212,71 @@ 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(_, { types = [dom]; _ }) -> 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 +768,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 +792,8 @@ 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, { indices = []; types = [] }), + Fop (op2, { indices = []; types = [] }) 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 +907,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 +975,11 @@ let int_of_form = | SFint x -> x - | SFop ((op, []), [a]) when op_kind op = Some `Int_opp -> + | SFop ((op, { indices = []; types = [] }), [a]) + when op_kind op = Some `Int_opp -> BI.neg (doit a) - | SFop ((op, []), [a1; a2]) -> begin + | SFop ((op, { indices = []; types = [] }), [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 +992,7 @@ let int_of_form = let real_of_form f = match sform_of_form f with - | SFop ((op, []), [a]) -> + | SFop ((op, { indices = []; types = [] }), [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 6be1d1aaf..868142634 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -48,6 +48,17 @@ val ts_inv_eqglob: val f_int_le : form -> form -> form val f_int_lt : form -> form -> form +(* Instantiate an operator body at explicit [targs]: tyvars via the + type substitution, idxvars in BOTH namespaces (tindex positions and + int-typed formula-local occurrences). Mirrors [EcEnv.Op.reduce]. *) +val f_subst_tparams : + freshen:bool + -> EcIdent.t list (* idxvars *) + -> EcIdent.t list (* tyvars *) + -> EcAst.targs + -> form + -> form + (* soft-constructors - reals *) val f_rint : zint -> form val f_real_of_int : form -> form @@ -226,7 +237,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/ecHiGoal.ml b/src/ecHiGoal.ml index e9e011c66..25d179222 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -112,7 +112,13 @@ let process_local_hint (hint : plocalhint) (tc : tcenv1) = let simpl = List.fold_left (fun simpl lemma -> let path = EcEnv.Ax.lookup_path (unloc lemma) env in - let rule = EcReduction.User.compile ~opts ~prio:0 env path in + let rule = + try EcReduction.User.compile ~opts ~prio:0 env path + with EcReduction.User.InvalidUserRule e -> + tc_error !!tc ~loc:lemma.pl_loc + "invalid rewrite rule `%s': %s" + (EcSymbols.string_of_qsymbol (unloc lemma)) + (EcReduction.User.string_of_error e) in EcEnv.SimplifyContext.add_rules [(path, rule)] simpl) simpl h.ph_lemmas in @@ -198,7 +204,13 @@ let process_simplify_info ri (tc : tcenv1) = let opts = EcTheory.{ ur_delta = false; ur_eqtrue = false; } in List.fold_left (fun simpl lemma -> let path = EcEnv.Ax.lookup_path (unloc lemma) env in - let rule = EcReduction.User.compile ~opts ~prio:0 env path in + let rule = + try EcReduction.User.compile ~opts ~prio:0 env path + with EcReduction.User.InvalidUserRule e -> + tc_error !!tc ~loc:lemma.pl_loc + "invalid rewrite rule `%s': %s" + (EcSymbols.string_of_qsymbol (unloc lemma)) + (EcReduction.User.string_of_error e) in EcEnv.SimplifyContext.add_rules [(path, rule)] simpl ) simpl hint.ph_lemmas in @@ -687,6 +699,25 @@ let process_apply_bwd ~implicits mode (ff : ppterm) (tc : tcenv1) = with (EcLowGoal.Apply.NoInstance _) as err -> tc_error_exn !!tc err +(* -------------------------------------------------------------------- *) +let process_exacttype qs (tc : tcenv1) = + let env, hyps, _ = FApi.tc1_eflat tc in + let p = + try EcEnv.Ax.lookup_path (EcLocation.unloc qs) env + with LookupFailure cause -> + tc_error !!tc "%a" EcEnv.pp_lookup_failure cause + in + let tys = + List.map (fun a -> EcTypes.tvar a) + (EcEnv.LDecl.tohyps hyps).h_tvar.tyvars in + let pt = ptglobal ~tys p in + + try + EcLowGoal.t_apply pt tc + with InvalidGoalShape -> + let ppe = EcPrinting.PPEnv.ofenv env in + tc_error !!tc "cannot apply %a@." (EcPrinting.pp_axname ppe) p + (* -------------------------------------------------------------------- *) let process_apply_fwd ~implicits (pe, hyp) tc = let module E = struct exception NoInstance end in @@ -849,11 +880,15 @@ let process_delta ?(rigid = false) ?target ((s :rwside), o, p) tc = end | SFlocal x when LDecl.can_unfold x hyps -> - ([], [], LDecl.unfold x hyps, [], None) + ({ indices = []; types = [] }, + { EcDecl.idxvars = []; EcDecl.tyvars = [] }, + LDecl.unfold x hyps, [], None) | SFother { f_node = Fapp ({ f_node = Flocal x }, args) } when LDecl.can_unfold x hyps -> - ([], [], LDecl.unfold x hyps, args, None) + ({ indices = []; types = [] }, + { EcDecl.idxvars = []; EcDecl.tyvars = [] }, + LDecl.unfold x hyps, args, None) | _ -> tc_error !!tc "not headed by an operator/predicate" @@ -898,14 +933,17 @@ let process_delta ?(rigid = false) ?target ((s :rwside), 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 = + EcFol.f_subst_tparams ~freshen:true + tparams.EcDecl.idxvars tparams.EcDecl.tyvars tvi 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 end | SFlocal _ -> begin - assert (tparams = []); + assert ( List.is_empty tparams.EcDecl.tyvars + && List.is_empty tparams.EcDecl.idxvars); let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body with EcEnv.NotReducible -> body @@ -921,7 +959,9 @@ let process_delta ?(rigid = false) ?target ((s :rwside), o, p) tc = | `RtoL -> let fp = (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true tparams tvi body in + let body = + EcFol.f_subst_tparams ~freshen:true + tparams.EcDecl.idxvars tparams.EcDecl.tyvars tvi body in let fp = f_app body args p.f_ty in try EcReduction.h_red EcReduction.beta_red hyps fp with EcEnv.NotReducible -> fp diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 4d59c0f29..1da6a9e5c 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 = { @@ -133,11 +137,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 ] @@ -343,7 +347,7 @@ let trans_matchfix | _ :: _ :: _ -> fxerror cname.pl_loc env TT.FXE_CtorAmbiguous - | [(cp, _tvi), _opty, _subue, _] -> + | [(cp, _ixs, _tvi), _opty, _subue, _] -> let ctor = EcEnv.Op.by_path cp env in let (indp, _ctoridx) = EcDecl.operator_as_ctor ctor in let indty = EcEnv.Ty.by_path indp env in @@ -370,7 +374,7 @@ let trans_matchfix let indp, _ = Msym.find x indtbl in let indty = oget (EcEnv.Ty.by_path_opt indp env) in let ind = (oget (EcDecl.tydecl_as_datatype indty)).tydt_ctors in - let codom = tconstr indp (List.map tvar indty.tyd_params) in + let codom = tconstr ~tyargs:(List.map tvar indty.tyd_params.tyvars) indp in let tys = List.map (fun (_, dom) -> toarrow dom codom) ind in let tys, _ = EcUnify.UniEnv.opentys ue indty.tyd_params None tys in let doargs cty = @@ -391,7 +395,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 @@ -412,10 +416,22 @@ let trans_matchfix EcUnify.UniEnv.restore ~src:subue ~dst:ue; - let ctorty = - 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 + (* 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 (EcUnify.IXunamed [], tvi)) 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); @@ -480,12 +496,12 @@ let trans_matchfix (* Build the final result *) let aout = if close then - let ts = Tuni.subst (EcUnify.UniEnv.assubst ue) in + let ts = EcUnify.UniEnv.as_subst ue in let tparams = EcUnify.UniEnv.tparams ue in 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/ecHiInductive.mli b/src/ecHiInductive.mli index 1db4bd011..59c170e4a 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/ecHiNotations.ml b/src/ecHiNotations.ml index 3d742857c..94e5dde19 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -30,7 +30,8 @@ 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 + let env = TT.bind_idx_locals env ue in (* Translate bound idents and their types *) let bd = List.mapi (fun i (x, pty) -> @@ -75,7 +76,8 @@ 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 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 @@ -83,7 +85,7 @@ let trans_abbrev_r (env : env) (at : pabbrev located) = if not (EcUnify.UniEnv.closed ue) then nterror gloc env NTE_TyNotClosed; - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in let es = e_subst ts in let body = es body in let codom = ty_subst ts codom in diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index dcf3440a8..f37d51582 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -2,7 +2,6 @@ open EcUtils open EcSymbols open EcLocation -open EcTypes open EcCoreSubst open EcParsetree open EcDecl @@ -20,8 +19,7 @@ exception TransPredError of EcLocation.t * EcEnv.env * tperror let tperror loc env e = raise (TransPredError (loc, env, e)) (* -------------------------------------------------------------------- *) -let close_pr_body (uni : ty EcUid.Muid.t) (body : prbody) = - let fsubst = EcFol.Fsubst.f_subst_init ~tu:uni () in +let close_pr_body (fsubst : EcFol.f_subst) (body : prbody) = let tsubst = ty_subst fsubst in match body with @@ -40,7 +38,9 @@ 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 env = TT.bind_idx_locals env ue in let tp = TT.tp_relax in let dom, body = @@ -77,11 +77,15 @@ let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = if not (EcUnify.UniEnv.closed ue) then tperror loc env TPE_TyNotClosed; - let uidmap = EcUnify.UniEnv.assubst ue in + (* Resolve BOTH type- and index-univars: a predicate body may carry + index univars (e.g. a nullary indexed op [onew<:?u>] whose index is + fixed by the parameter types), which must be concretised before the + body is stored — otherwise the univar leaks into the saved AST. *) + let fsubst = EcUnify.UniEnv.close_subst ue in let tparams = EcUnify.UniEnv.tparams ue in - let body = body |> omap (close_pr_body uidmap) in + let body = body |> omap (close_pr_body fsubst) in - let dom = Tuni.subst_dom uidmap dom in + let dom = List.map (ty_subst fsubst) dom in let tags = Ssym.of_list (List.map unloc pr.pp_tags) in let opaque = { diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 81f3be80d..95fd054a7 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -38,15 +38,19 @@ 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 tyargs = List.map tvar rc.rc_tparams.tyvars in + let indices = List.map (fun id -> EcAst.TIVar id) rc.rc_tparams.idxvars in + let recty = + tconstr_r rc.rc_path (mk_targs ~indices ~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 ~indices ~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 +142,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,12 +162,15 @@ 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 + (* 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) -> 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.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) @@ -177,11 +184,12 @@ 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) + 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.iter (check_positivity_path fct p) args.types; + 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) @@ -223,11 +231,13 @@ 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 indices = List.map (fun id -> EcAst.TIVar id) targs.idxvars in + let indty = tconstr ~indices ~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 ~indices ~tyargs (toarrow tys indty) in let form = FL.f_app pred [FL.f_app ctor cargs indty] tbool in let form = match mode with @@ -247,7 +257,10 @@ 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 p + ~indices:(List.map (fun id -> EcAst.TIVar id) targs.idxvars) + ~tyargs:(List.map tvar targs.tyvars) in let indx = fresh_id_of_ty indty in let indfm = FL.f_local indx indty in let predty = tfun indty tbool in @@ -264,7 +277,10 @@ 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 tpath + ~indices:(List.map (fun id -> EcAst.TIVar id) tparams.idxvars) + ~tyargs:(List.map tvar tparams.tyvars) in let do1 i (cname, cty) = let thv = EcIdent.create "the" in @@ -378,7 +394,10 @@ 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 + ~indices:(List.map (fun id -> EcAst.TIVar id) pr.ip_tparams.idxvars) + ~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 @@ -391,7 +410,10 @@ 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 + ~indices:(List.map (fun id -> EcAst.TIVar id) pr.ip_tparams.idxvars) + ~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/ecLexer.mll b/src/ecLexer.mll index 99e22d777..108d7d814 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -190,6 +190,7 @@ "local" , LOCAL ; (* KW: global *) "global" , GLOBAL ; (* KW: global *) "declare" , DECLARE ; (* KW: global *) + "index" , INDEX ; (* KW: global *) "hint" , HINT ; (* KW: global *) "module" , MODULE ; (* KW: global *) "of" , OF ; (* KW: global *) @@ -418,6 +419,7 @@ rule main = parse (* string symbols *) | ".." { [DOTDOT ] } | ".[" { [DLBRACKET] } + | "[:" { [LBRACKETCOLON] } | ".`" { [DOTTICK ] } | "{0,1}" { [RBOOL ] } diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index e649bc45a..4f2765a1d 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 @@ -691,7 +691,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; @@ -727,10 +726,10 @@ let tt_apply_hyp (x : EcIdent.t) ?(args = []) ?(sk = 0) tc = tt_apply pt tc (* -------------------------------------------------------------------- *) -let tt_apply_s (p : path) tys ?(args = []) ?(sk = 0) tc = +let tt_apply_s (p : path) ?(idxs = []) tys ?(args = []) ?(sk = 0) tc = let pt = let args = (List.map paformula args) @ (List.make sk (PASub None)) in - ptglobal ~args ~tys p in + ptglobal ~args ~idxs ~tys p in tt_apply pt tc @@ -755,8 +754,8 @@ let t_hyp (x : EcIdent.t) tc = t_apply_hyp x ~args:[] ~sk:0 tc (* -------------------------------------------------------------------- *) -let t_apply_s (p : path) (tys : ty list) ?args ?sk tc = - tt_apply_s p tys ?args ?sk (FApi.tcenv_of_tcenv1 tc) +let t_apply_s (p : path) ?(idxs = []) (tys : ty list) ?args ?sk tc = + tt_apply_s p ~idxs tys ?args ?sk (FApi.tcenv_of_tcenv1 tc) (* -------------------------------------------------------------------- *) let t_apply_hd (hd : handle) ?args ?sk tc = @@ -1439,7 +1438,9 @@ let t_elimT_ind ?reduce mode (tc : tcenv1) = match EcEnv.Ty.scheme_of_ty mode ty env with | Some (p, typ) -> - let pt = ptglobal ~tys:typ p in (tc, pt, 0) + let pt = + ptglobal ~idxs:typ.indices ~tys:typ.types p in + (tc, pt, 0) | None -> match (EcEnv.ty_hnorm ty env).ty_node with @@ -1525,7 +1526,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 ~idxs:tv.indices tv.types ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1706,7 +1707,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 @@ -1726,10 +1727,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 @@ -1928,12 +1929,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/src/ecLowGoal.mli b/src/ecLowGoal.mli index e69da529d..7d2966101 100644 --- a/src/ecLowGoal.mli +++ b/src/ecLowGoal.mli @@ -111,7 +111,7 @@ val t_apply : ?cutsolver:cutsolver -> proofterm -> FApi.backward * constructed from the path, type parameters, and formulas given to * the function. The [int] argument gives the number of premises to * skip before applying [p]. *) -val t_apply_s : path -> ty list -> ?args:(form list) -> ?sk:int -> FApi.backward +val t_apply_s : path -> ?idxs:(EcAst.tindex list) -> ty list -> ?args:(form list) -> ?sk:int -> FApi.backward (* Apply a proof term of the form [h f1...fp _ ... _] constructed from * the local hypothesis and formulas given to the function. The [int] diff --git a/src/ecMatching.ml b/src/ecMatching.ml index db71dbf4d..38167ba84 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -828,7 +828,7 @@ module MEV = struct v let assubst ue ev env = - let subst = f_subst_init ~tu:(EcUnify.UniEnv.assubst ue) () in + let subst = EcUnify.UniEnv.as_subst 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 @@ -1048,7 +1048,38 @@ let f_match_core ?(conv_ri = EcReduction.full_compat) 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 + if List.compare_lengths tys1.indices tys2.indices <> 0 then + failure (); + if List.compare_lengths tys1.types tys2.types <> 0 then + failure (); + (* Index unification on Fop heads: when BOTH sides are + univar-free the indices are ground data -- a mismatch is + a definitive match failure (tolerating it used to leak + ill-matched instances into InvalidGoalShape anomalies + downstream). With univars involved, unification is + best-effort: a polynomial-against-polynomial with + multiple univars (e.g. [bits[:?u_m + ?u_n]] vs + [bits[:m + n]]) is genuinely ambiguous in isolation, so + defer to arg matching, which typically constrains the + individual univars first. Type unification of + [tys1.types] is still mandatory. *) + let ground ti = + let rec go = function + | EcAst.TIUnivar _ -> false + | EcAst.TIVar _ | EcAst.TIConst _ -> true + | EcAst.TIAdd (a, b) | EcAst.TIMul (a, b) -> go a && go b + in go ti in + List.iter2 (fun i1 i2 -> + let i1 = EcUnify.UniEnv.repr_tindex ue i1 in + let i2 = EcUnify.UniEnv.repr_tindex ue i2 in + if ground i1 && ground i2 then begin + if not (EcAst.tindex_equal i1 i2) then failure () + end else + 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 () end @@ -1291,7 +1322,7 @@ let f_match ?conv_ri opts hyps (ue, ev) f1 f2 = if not (MEV.filled ev) then raise MatchFailure; let clue = - try EcUnify.UniEnv.close ue + try EcUnify.UniEnv.close_subst ue with EcUnify.UninstantiateUni -> raise MatchFailure in (ue, clue, ev) diff --git a/src/ecMatching.mli b/src/ecMatching.mli index e4ee9d882..1241c429f 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -1,6 +1,5 @@ (* -------------------------------------------------------------------- *) open EcMaps -open EcUid open EcIdent open EcTypes open EcModules @@ -386,7 +385,7 @@ val f_match : -> unienv * mevmap -> form -> form - -> unienv * (ty Muid.t) * mevmap + -> unienv * EcCoreSubst.f_subst * mevmap (* -------------------------------------------------------------------- *) type ptnpos = private [`Select of int | `Sub of ptnpos] Mint.t diff --git a/src/ecPV.ml b/src/ecPV.ml index 19c763f24..bad0756a8 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -1023,7 +1023,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 -> @@ -1122,7 +1122,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/ecParser.mly b/src/ecParser.mly index 9552a74a1..0281ca750 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -14,13 +14,39 @@ 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; } + (* No mixed-bucket helper: idxvars and tyvars now use distinct + bracket families ({...} vs [...]), so the parser can keep them + separate. *) + + (* Homogeneous named-or-positional argument lists: parsed as ONE + item list so that a mixed list gets an intentional, located + error instead of an LR accident. *) + let homogeneous_annot ~(what : string) ~pos ~named items = + let bad (it : 'a EcLocation.located) = + parse_error (EcLocation.loc it) (Some (Printf.sprintf + "cannot mix positional and named %s arguments" what)) + in + match items with + | [] -> assert false + | { EcLocation.pl_desc = `Pos _; _ } :: _ -> + pos (List.map (fun it -> + match EcLocation.unloc it with + | `Pos x -> x + | `Named _ -> bad it) items) + | { EcLocation.pl_desc = `Named _; _ } :: _ -> + named (List.map (fun it -> + match EcLocation.unloc it with + | `Named x -> x + | `Pos _ -> bad it) items) + let map_gppterm f a = let fp_head = match a.fp_head with | FPNamed _ as x -> x @@ -88,14 +114,15 @@ 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 = - { pa_name = x; - pa_tyvars = ty; - pa_pvars = pv; - pa_vars = vd; - pa_formula = f; - pa_kind = k; - pa_locality = locality; } + 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_simplify ?(hint = empty_simplify_hint) l = if l = [] then @@ -426,8 +453,10 @@ %token FIX %token DEBUG %token DECLARE +%token INDEX %token DELTA %token DLBRACKET +%token LBRACKETCOLON %token DO %token DONE %token DOT @@ -666,6 +695,7 @@ _lident: | x=LIDENT { x } | ABORT { "abort" } +| INDEX { "index" } | ADMITTED { "admitted" } | ARRAY { "array" } | ASYNC { "async" } @@ -926,15 +956,62 @@ lp_field: (* -------------------------------------------------------------------- *) (* Expressions: program expression, real expression *) -tyvar_byname1: -| x=tident EQ ty=loc(type_exp) { (x, ty) } +tyvar_annot_item: +| ty=loc(type_exp) { `Pos ty } +| x=tident EQ ty=loc(type_exp) { `Named (x, ty) } tyvar_annot: -| lt = plist1(loc(type_exp), COMMA) { TVIunamed lt } -| lt = plist1(tyvar_byname1, COMMA) { TVInamed lt } - +| items=plist1(loc(tyvar_annot_item), COMMA) + { homogeneous_annot ~what:"type" + ~pos: (fun lt -> TVIunamed (IXunamed [], lt)) + ~named:(fun lt -> TVInamed (IXunamed [], lt)) + items } + +(* Explicit op-index instantiation, e.g. `f[:n+1]`, `f[:n,m]<:int>` + or `f[:n = 3, m = 4]`. The `[:` form is parsed as a single + LBRACKETCOLON token by the lexer to avoid clashes with list + literals. *) +idx_byname1: +| x=lident EQ ix=pindex { (x, ix) } + +idx_annot_item: +| ix=pindex { `Pos ix } +| nx=idx_byname1 { `Named nx } + +idx_annot: +| items=plist1(loc(idx_annot_item), COMMA) + { homogeneous_annot ~what:"index" + ~pos: (fun ix -> IXunamed ix) + ~named:(fun ix -> IXnamed ix) + items } + +%inline idx_app: +| LBRACKETCOLON ix=idx_annot RBRACKET { ix } + +(* Both annotation orders are accepted (`f[:3]<:int>` and + `f<:int>[:3]`); the printer stays canonical (indices first). *) %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 (IXunamed [], tys) -> + mk_loc k.pl_loc (TVIunamed (ix, tys)) + | TVInamed (IXunamed [], lts) -> + mk_loc k.pl_loc (TVInamed (ix, lts)) + | TVIunamed (_, _) | TVInamed (_, _) -> + assert false (* tyvar_annot never produces indices *) } +| LTCOLON k=loc(tyvar_annot) GT ix=loc(idx_app) + { let loc = EcLocation.merge k.pl_loc ix.pl_loc in + match k.pl_desc with + | TVIunamed (IXunamed [], tys) -> + mk_loc loc (TVIunamed (ix.pl_desc, tys)) + | TVInamed (IXunamed [], lts) -> + mk_loc loc (TVInamed (ix.pl_desc, lts)) + | TVIunamed (_, _) | TVInamed (_, _) -> + assert false (* tyvar_annot never produces indices *) } (* -------------------------------------------------------------------- *) %inline sexpr: f=sform { mk_loc f.pl_loc (Expr f) } @@ -1302,17 +1379,74 @@ 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=ioption(idx_args) + { PTapp (x, tya, odfl (IXunamed []) 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 { IXunamed xs } +| LTCOLON xs=plist1(idx_byname1, COMMA) GT { IXnamed xs } + +(* `f<:int vec<:3>>` lexes the trailing `>>` as one operator token; + catch it where the inner application expects its closing `>`. *) +| LTCOLON plist1(pindex, COMMA) op=loc(LOP1) + { ignore op; + parse_error op.pl_loc + (if String.for_all (fun c -> c = '>') (unloc op) then + Some "`>>' is a single operator token: \ + separate the closing brackets with a space (`> >')" + else None) } + +(* 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) } +| u=loc(UNDERSCORE) { mk_loc u.pl_loc PIhole } +| 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)) } +| a=pindex MINUS pindex_mul + { ignore a; + parse_error + (EcLocation.make $startpos $endpos) + (Some "index expressions range over the naturals: \ + subtraction is not available") } + +(* 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`. + + Non-negativity of indices is not marked here: it is an enforced + invariant, available as the [Int.ge0_index] axiom. *) +idxvars_decl: +| LBRACE xs=lident+ RBRACE { xs } + type_exp: | ty=simpl_type_exp { ty } | ty=plist2(loc(simpl_type_exp), STAR) { PTtuple ty } @@ -1685,7 +1819,8 @@ 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, []) } @@ -1733,10 +1868,12 @@ subtype_rename: (* Type classes (instances) *) tycinstance: | loca=is_local INSTANCE x=qident nm=bracket(ident)? - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* + WITH idx=loption(idxvars_decl) typ=tyvars_decl? ty=loc(type_exp) + ops=tyci_op* axs=tyci_ax* { { pti_name = x; pti_as = nm; + pti_idx = idx; pti_type = (odfl [] typ, ty); pti_ops = ops; pti_axs = axs; @@ -1746,10 +1883,12 @@ tycinstance: } | loca=is_local INSTANCE x=qident nm=bracket(ident)? c=uoption(UINT) p=uoption(UINT) - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* + WITH idx=loption(idxvars_decl) typ=tyvars_decl? ty=loc(type_exp) + ops=tyci_op* axs=tyci_ax* { { pti_name = x; pti_as = nm; + pti_idx = idx; pti_type = (odfl [] typ, ty); pti_ops = ops; pti_axs = axs; @@ -1787,38 +1926,53 @@ tyvars_decl: | LBRACKET tyvars=rlist2(tident, empty) RBRACKET { tyvars } +(* Combined `{idx}` then `['a]` binder. Indices come first; both are + independently optional. Returns [(idxvars, tyvars_opt)] where: + - [idxvars] is the idxvar names in order. + - [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 } | 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=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 (idxvars, po_tyvars) = 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 = po_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=ix_ty_binder args=ptybindings_opdecl? COLON LBRACE sty=loc(type_exp) PIPE reft=form RBRACE AS rname=ident - { { po_kind = k; + { let (idxvars, po_tyvars) = 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 = po_tyvars; po_args = odfl ([], None) args; po_def = opdef_of_opbody sty (Some (`Reft (rname, reft))); po_ax = None; @@ -1889,30 +2043,37 @@ exception_: predicate: | locality=locality PRED tags=bracket(ident*)? x=oident { { pp_name = x; + pp_idxvars = []; pp_tyvars = None; pp_def = PPabstr []; pp_tags = odfl [] tags; pp_locality = locality; } } -| locality=locality PRED tags=bracket(ident*)? x=oident tyvars=tyvars_decl? COLON sty=pred_tydom - { { pp_name = x; - pp_tyvars = tyvars; +| locality=locality PRED tags=bracket(ident*)? x=oident tvs=ix_ty_binder COLON sty=pred_tydom + { let (idxvars, pp_tyvars) = tvs in + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = pp_tyvars; pp_def = PPabstr sty; pp_tags = odfl [] tags; pp_locality = locality; } } -| locality=locality PRED tags=bracket(ident*)? x=oident tyvars=tyvars_decl? p=ptybindings? EQ f=form - { { pp_name = x; - pp_tyvars = tyvars; +| locality=locality PRED tags=bracket(ident*)? 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 = pp_tyvars; pp_def = PPconcr (odfl [] p, f); pp_tags = odfl [] tags; pp_locality = locality; } } -| locality=locality INDUCTIVE x=oident tyvars=tyvars_decl? p=ptybindings? +| locality=locality INDUCTIVE x=oident tvs=ix_ty_binder p=ptybindings? EQ b=indpred_def - { { pp_name = x; - pp_tyvars = tyvars; + { let (idxvars, pp_tyvars) = tvs in + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = pp_tyvars; pp_def = PPind (odfl [] p, b); pp_tags = []; pp_locality = locality; } } @@ -1953,10 +2114,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=ix_ty_binder bd=nt_bindings? args=nt_arg1* codom=prefix(COLON, loc(type_exp))? EQ body=expr - { { nt_name = x; - nt_tv = tv; + { let (idxvars, nt_tv) = tvs in + { nt_name = x; + nt_idx = idxvars; + nt_tv = nt_tv; nt_bd = odfl [] bd; nt_args = args; nt_codom = ofdfl (fun () -> mk_loc (loc body) PTunivar) codom; @@ -1976,13 +2139,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=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, ab_tv) = tvs in { ab_name = x; - ab_tv = tyvars; + ab_idx = idxvars; + ab_tv = ab_tv; ab_args = odfl [] args; ab_def = (sty, b); ab_opts = odfl [] opts; @@ -1997,11 +2162,12 @@ mempred_binding: lemma_decl: | x=ident - tyvars=tyvars_decl? + tvs=ix_ty_binder predvars=mempred_binding? pd=pgtybindings? COLON f=form - { (x, tyvars, predvars, pd, f) } + { let (idxvars, tyvars) = tvs in + (x, idxvars, tyvars, predvars, pd, f) } axiom_tc: | /* empty */ { PLemma None } @@ -2019,7 +2185,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 } @@ -3880,27 +4046,30 @@ 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*)? +| OP x=qoident idx=loption(idxvars_decl) tyvars=bracket(tident*)? p=ptybinding1* sty=ioption(prefix(COLON, loc(type_exp))) mode=loc(opclmode) f=form { let ov = { - opov_tyvars = tyvars; - opov_args = List.flatten p; - opov_retty = odfl (mk_loc mode.pl_loc PTunivar) sty; - opov_body = f; + opov_idxvars = idx; + opov_tyvars = tyvars; + opov_args = List.flatten p; + opov_retty = odfl (mk_loc mode.pl_loc PTunivar) sty; + opov_body = f; } in (x, PTHO_Op (`BySyntax ov, unloc mode)) } -| PRED x=qoident tyvars=bracket(tident*)? p=ptybinding1* mode=loc(opclmode) f=form +| PRED x=qoident idx=loption(idxvars_decl) tyvars=bracket(tident*)? + p=ptybinding1* mode=loc(opclmode) f=form { let ov = { - prov_tyvars = tyvars; - prov_args = List.flatten p; - prov_body = f; + prov_idxvars = idx; + prov_tyvars = tyvars; + prov_args = List.flatten p; + prov_body = f; } in (x, PTHO_Pred (`BySyntax ov, unloc mode)) } @@ -4113,6 +4282,8 @@ global_action: | mod_def_or_decl { Gmodule $1 } | sig_def { Ginterface $1 } | typedecl { Gtype $1 } +| DECLARE INDEX idx=idxvars_decl + { Gdeclidx idx } | subtype { Gsubtype $1 } | tycinstance { Gtycinstance $1 } | operator { Goperator $1 } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 2a70a2e92..756cd1422 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -109,14 +109,40 @@ type pty_r = | PTtuple of pty list | PTnamed of pqsymbol | PTvar of psymbol - | PTapp of pqsymbol * pty list + | PTapp of pqsymbol * pty list * pidxannot | 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 + (* `_` placeholder — let the system infer this index by + allocating a fresh [TIUnivar] at typecheck time. *) + | PIhole +and pindex = pindex_r located + +(* Explicit index instantiation: positional (`f[:3, 4]` / `t<:3, 4>`) + or named (`f[:n = 3, m = 4]` / `t<:n = 3, m = 4>`). [IXunamed []] + means "no indices provided". Named instantiation may be partial: + unnamed indices are inferred. *) +and pidxannot = + | IXunamed of pindex list + | IXnamed of (psymbol * pindex) list + type ptyannot_r = - | TVIunamed of pty list - | TVInamed of (psymbol * pty) list + (* Explicit indices first, then explicit types. Either side may be + empty; when both are empty, no instantiation was provided. The + index and type sides are independent: each may be positional or + named. *) + | TVIunamed of pidxannot * pty list + | TVInamed of pidxannot * (psymbol * pty) list and ptyannot = ptyannot_r located @@ -148,9 +174,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; } @@ -472,6 +499,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; @@ -506,6 +534,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_tags : psymbol list; @@ -515,6 +544,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; @@ -529,6 +559,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; @@ -1230,13 +1261,14 @@ type paxiom_kind = type mempred_binding = PT_MemPred of psymbol list type paxiom = { - pa_name : psymbol; - pa_pvars : mempred_binding option; - 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; + pa_tyvars : ptyparams option; + pa_vars : pgtybindings option; + pa_formula : pformula; + pa_kind : paxiom_kind; + pa_locality : locality; } (* -------------------------------------------------------------------- *) @@ -1249,6 +1281,9 @@ type prealize = { type ptycinstance = { pti_name : pqsymbol; pti_as : psymbol option; + (* Index binders of an index-parametric instance ([{n}] in + [instance ring [w] with {n} word<:n+1> ...]). *) + pti_idx : psymbol list; pti_type : ptyparams * pty; pti_ops : (psymbol * (pty list * pqsymbol)) list; pti_axs : (psymbol * ptactic_core) list; @@ -1378,19 +1413,22 @@ 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; - opov_args : ptybinding list; - opov_retty : pty; - opov_body : pformula; + opov_idxvars : psymbol list; + opov_tyvars : psymbol list option; + opov_args : ptybinding list; + opov_retty : pty; + opov_body : pformula; } and pr_override_def = { - prov_tyvars : psymbol list option; - prov_args : ptybinding list; - prov_body : pformula; + prov_idxvars : psymbol list; + prov_tyvars : psymbol list option; + prov_args : ptybinding list; + prov_body : pformula; } (* -------------------------------------------------------------------- *) @@ -1485,6 +1523,7 @@ type global_action = | Gabbrev of pabbrev | Gaxiom of paxiom | Gtype of ptydecl list + | Gdeclidx of psymbol list | Gsubtype of psubtype | Gtycinstance of ptycinstance | Gaddrw of (is_local * pqsymbol * pqsymbol list) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 3fd831673..30217c5ee 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -247,12 +247,11 @@ 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 (EcUnify.IXunamed [], typ)) in fun sm -> check_for_local sm; - - let by_current ((p, _), _, _, _) = + let by_current ((p, _, _), _, _, _) = let env = ppe.ppe_env in EcPath.isprefix ~prefix:(oget (EcPath.prefix p)) ~path:(EcEnv.root env) in @@ -261,7 +260,7 @@ module PPEnv = struct let ops = match List.mbfilter by_current ops with [] -> ops | ops -> ops in match ops with - | [(p1, _), _, _, _] -> p1 + | [(p1, _, _), _, _, _] -> p1 | _ -> raise (EcEnv.LookupFailure (`QSymbol sm)) in let exists sm = @@ -804,6 +803,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) @@ -824,23 +854,30 @@ 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 - maybe_paren outer t_prio_name pp fmt (name, tyargs) + maybe_paren outer t_prio_name pp fmt (name, tyargs.types) end | Tfun (t1, t2) -> @@ -931,17 +968,24 @@ let pp_opname (fmt : Format.formatter) ((nm, op) : symbol list * symbol) = (* -------------------------------------------------------------------- *) let pp_opname_with_tvi - (ppe : PPEnv.t) - (fmt : Format.formatter) - ((nm, op, tvi) : symbol list * symbol * ty list option) + (ppe : PPEnv.t) + (fmt : Format.formatter) + ((nm, op, ixi, tvi) : symbol list * symbol * tindex list option * ty list option) = + let pp_ix fmt = + match ixi with + | None -> () + | Some ixs -> + Format.fprintf fmt "[:%a]" + (pp_list ",@ " (pp_tindex ppe)) ixs + in match tvi with | None -> - pp_opname fmt (nm, op) + Format.fprintf fmt "%a%t" pp_opname (nm, op) pp_ix | Some tvi -> - Format.fprintf fmt "%a<:%a>" - pp_opname (nm, op) + Format.fprintf fmt "%a%t<:%a>" + pp_opname (nm, op) pp_ix (pp_list ",@ " (pp_type ppe)) tvi (* -------------------------------------------------------------------- *) @@ -1104,7 +1148,47 @@ let tvi_dominated (env : EcEnv.env) (op : EcPath.path) (nargs : int) : bool = List.fold_left (fun acc ty -> Sid.union acc (EcTypes.Tvar.fv ty)) Sid.empty arg_tys in - List.for_all (fun id -> Sid.mem id covered) tparams + List.for_all (fun id -> Sid.mem id covered) tparams.tyvars + +(* Index variables RECOVERABLE from a type: an idxvar counts as + displayed information only when some index determines it -- i.e. + the (normalized) index is affine in exactly that one variable with + unit coefficient ([vec<:n>], [vec<:n + 1>]), matching the + unifier's invertible fragment. [vec<:n + m>] or [vec<:2 * n>] + determine nothing. *) +let recoverable_idxvar (ti : EcAst.tindex) : EcIdent.t option = + match EcAst.tindex_normalize ti with + | EcAst.TIVar v -> Some v + | EcAst.TIAdd (EcAst.TIConst _, EcAst.TIVar v) -> Some v + | _ -> None + +let rec ty_idxfv_rec (acc : Sid.t) (ty : ty) : Sid.t = + let acc = + match ty.ty_node with + | Tconstr (_, ta) -> + List.fold_left + (fun acc ti -> + match recoverable_idxvar ti with + | Some id -> Sid.add id acc + | None -> acc) + acc ta.indices + | _ -> acc + in + ty_fold ty_idxfv_rec acc ty + +(* Index counterpart of [tvi_dominated]: all index parameters of [op] + can be inferred from the types of the first [nargs] arguments. *) +let ixs_dominated (env : EcEnv.env) (op : EcPath.path) (nargs : int) : bool = + match EcEnv.Op.by_path_opt op env with + | None -> false + | Some opdecl -> + let dom, _ = tyfun_flat opdecl.op_ty in + let arg_tys = List.take nargs dom in + let covered = + List.fold_left ty_idxfv_rec Sid.empty arg_tys in + List.for_all + (fun id -> Sid.mem id covered) + opdecl.op_tparams.idxvars (* -------------------------------------------------------------------- *) let pp_opapp @@ -1120,6 +1204,7 @@ let pp_opapp (fmt : Format.formatter) ((pred : [`Expr | `Form]), (op : EcPath.path), + (ixs : EcAst.tindex list), (tvi : EcTypes.ty list), (es : 'a list), (tyopt : ty option)) @@ -1189,14 +1274,23 @@ let pp_opapp then None else Some tvi in + let ixs_opt = + if List.is_empty ixs then None + else + let dominated = + ixs_dominated ppe.PPEnv.ppe_env op (List.length es) in + if dominated && not ppe.PPEnv.ppe_showtvi + then None else Some ixs + in + fun () -> match es with | [] -> - pp_opname_with_tvi ppe fmt (nm, opname, tvi_opt) + pp_opname_with_tvi ppe fmt (nm, opname, ixs_opt, tvi_opt) | _ -> let pp_first = fun _ _ fmt op -> - pp_opname_with_tvi ppe fmt (fst op, snd op, tvi_opt) in + pp_opname_with_tvi ppe fmt (fst op, snd op, ixs_opt, tvi_opt) in let pp fmt () = pp_app ppe ~pp_first ~pp_sub outer fmt ((nm, opname), es) in maybe_paren outer max_op_prec pp fmt () @@ -1555,7 +1649,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' -> @@ -1723,7 +1817,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 @@ -1734,7 +1828,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 @@ -1814,7 +1908,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 @@ -1861,12 +1955,12 @@ 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 args = let subst = EcMatching.MEV.assubst ue ev ppe.ppe_env in List.map (Fsubst.f_subst subst) args in - let f = f_app (f_op p tv rty) (args @ eargs) f.f_ty in + let f = f_app (f_op p ~tyargs:tv rty) (args @ eargs) f.f_ty in pp_form_core_r ppe outer fmt f; true and pp_poe (ppe : PPEnv.t) (fmt : Format.formatter) (poe : form Mop.t) = @@ -1879,7 +1973,7 @@ and pp_poe (ppe : PPEnv.t) (fmt : Format.formatter) (poe : form Mop.t) = let args = List.map doarg bd in let tys = List.map (fun (_, ty) -> EcFol.as_gtty ty) bd in let ty = EcTypes.toarrow tys EcTypes.texn in - let eargs = EcFol.f_app (EcFol.f_op e [] ty) args EcTypes.texn in + let eargs = EcFol.f_app (EcFol.f_op e ty) args EcTypes.texn in let ppe = PPEnv.add_locals ppe (List.map fst bd) in Format.fprintf fmt "@[| %a =>@ %a]" (pp_form ppe) eargs (pp_form ppe) br in @@ -1930,7 +2024,7 @@ and pp_form_core_r in pp_opapp ppe f_ty (dt_sub, pp_form_r, is_trm, is_tuple, is_proj) - lower_left outer fmt (`Form, op, tys, es, tyopt) + lower_left outer fmt (`Form, op, tys.indices, tys.types, es, tyopt) in match f.f_node with @@ -2351,19 +2445,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 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 with + 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 = @@ -2395,11 +2499,34 @@ 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 +(* 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 + | [], [] -> () + | _ , [] -> 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 | [] -> () @@ -2508,7 +2635,11 @@ let pp_codegap_range (ppe: PPEnv.t) (fmt: Format.formatter) ((cpath, cp1r) : CP. Format.fprintf fmt "%a:[%a]" (pp_codepos_path ppe) cpath (pp_codegap1_range ppe) cp1r (* -------------------------------------------------------------------- *) -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, 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 = @@ -2556,12 +2687,14 @@ let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * ty_param 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_exception_decl (ppe: PPEnv.t) fmt basename ty = @@ -2574,7 +2707,11 @@ let pp_exception_decl (ppe: PPEnv.t) fmt basename ty = pp_opname ([], basename) 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 = @@ -2656,17 +2793,22 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = Format.fprintf fmt "= < exception >" in - match ts with - | [] -> 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 + if List.is_empty tparams.idxvars && List.is_empty ts then + Format.fprintf fmt "@[op %a %t.@]" + pp_opname ([], basename) 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 * ty_param list * ty * notation) + ((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 = @@ -2678,12 +2820,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 @@ -2716,13 +2860,15 @@ let pp_opdecl 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 - | [] -> Format.fprintf fmt ": @[%a@]" - (pp_type ppe) op.op_ty - | ts -> + let ppe = PPEnv.add_locals ppe op.op_tparams.idxvars in + let ppe = PPEnv.add_locals ppe op.op_tparams.tyvars in + 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) = @@ -2738,16 +2884,20 @@ 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.idxvars 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 - | [] -> 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 @@ -3143,7 +3293,7 @@ let pp_poe (ppe : PPEnv.t) ?prpo (fmt: Format.formatter) poe = let args = List.map doarg bd in let tys = List.map (fun (_, ty) -> EcFol.as_gtty ty) bd in let ty = EcTypes.toarrow tys EcTypes.texn in - let eargs = EcFol.f_app (EcFol.f_op p [] ty) args EcTypes.texn in + let eargs = EcFol.f_app (EcFol.f_op p ty) args EcTypes.texn in let ppe = PPEnv.add_locals ppe (List.map fst bd) in pp_prpo ppe (pp_form ppe) eargs @@ -3409,14 +3559,22 @@ 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.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 with + 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 -> Format.fprintf fmt "Type variables: %a@\n\n%!" @@ -3455,12 +3613,19 @@ 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.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 with + 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 -> Format.fprintf fmt "Type variables: %a@\n\n%!" @@ -3615,7 +3780,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@]@ " @@ -3753,16 +3918,16 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = | CRBT_Type p -> Format.fprintf fmt "%s/ty:%a" item.name (pp_tyname ppe) p | CRBT_Op (tparams, { e_node = Eop (p, tys) }) - when List.for_all2 ty_equal (List.map tvar tparams) tys + when List.for_all2 ty_equal (List.map tvar tparams.tyvars) tys.types -> - let ppe = PPEnv.add_locals ppe tparams in + let ppe = PPEnv.add_locals ppe tparams.tyvars in Format.fprintf fmt "%s/op: %a" item.name (pp_opname ppe) p | CRBT_Op (tparams, e) -> - let ppe = PPEnv.add_locals ppe tparams in + let ppe = PPEnv.add_locals ppe tparams.tyvars in Format.fprintf fmt "%s/op:[%a] %a" item.name - (pp_list ",@ " (pp_tyvar ppe)) tparams + (pp_list ",@ " (pp_tyvar ppe)) tparams.tyvars (pp_expr ppe) e | CRBT_Lemma p -> Format.fprintf fmt "%s/ax:%a" item.name (pp_axname ppe) p @@ -3796,7 +3961,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 @@ -3836,12 +4001,12 @@ 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) -> + (fun fmt (name, (op : EcDecl.ring_op)) -> Format.fprintf fmt "op %s = %s" - name (EcPath.tostring op))) + name (EcPath.tostring op.ro_op))) ops end @@ -4004,6 +4169,10 @@ let pp_by_theory ) tr (* -------------------------------------------------------------------- *) +let pp_rp_indices (ppe : PPEnv.t) (fmt : Format.formatter) ixs = + if ixs <> [] then + Format.fprintf fmt "[:%a]" (pp_list ",@ " (pp_tindex ppe)) ixs + let rec pp_rule_pattern (ppe : PPEnv.t) (fmt : Format.formatter) @@ -4012,10 +4181,10 @@ let rec pp_rule_pattern match rule with | Rule (`Tuple, args) -> Format.fprintf fmt "(%a)" (pp_list ",@ " (pp_rule_pattern ppe)) args - | Rule (`Op (p, _), []) -> - Format.fprintf fmt "%a" (pp_opname ppe) p - | Rule (`Op (p, _), args) -> - Format.fprintf fmt "%a@ %a" (pp_opname ppe) p + | Rule (`Op (p, ixs, _), []) -> + Format.fprintf fmt "%a%a" (pp_opname ppe) p (pp_rp_indices ppe) ixs + | Rule (`Op (p, ixs, _), args) -> + Format.fprintf fmt "%a%a@ %a" (pp_opname ppe) p (pp_rp_indices ppe) ixs (pp_list "@ " (pp_paren (pp_rule_pattern ppe))) args | Rule (`Proj i, [arg]) -> Format.fprintf fmt "(%a)`.%d" (pp_rule_pattern ppe) arg i diff --git a/src/ecProcSem.ml b/src/ecProcSem.ml index 2fb1af20f..849cc3cda 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/ecProofTerm.ml b/src/ecProofTerm.ml index 5a5dce7a4..974c8500d 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; pte_lc : EcEnv.simplify_context; (* proof-local simplify context *) } @@ -84,11 +94,14 @@ let ptenv ?(simpl = EcEnv.SimplifyContext.empty) pe hyps (ue, ev) = pte_hy = hyps; pte_ue = EcUnify.UniEnv.copy ue; pte_ev = ref ev; + pte_idx_link = ref []; pte_lc = simpl; } (* -------------------------------------------------------------------- *) let copy pe = - ptenv ~simpl:pe.pte_lc pe.pte_pe pe.pte_hy (pe.pte_ue, !(pe.pte_ev)) + let cp = ptenv ~simpl:pe.pte_lc 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 ?(simpl = EcEnv.SimplifyContext.empty) (hyps : LDecl.hyps) (pe : proofenv) = @@ -96,6 +109,7 @@ let ptenv_of_penv ?(simpl = EcEnv.SimplifyContext.empty) (hyps : LDecl.hyps) (pe pte_hy = hyps; pte_ue = PT.unienv_of_hyps hyps; pte_ev = ref EcMatching.MEV.empty; + pte_idx_link = ref []; pte_lc = simpl; } (* -------------------------------------------------------------------- *) @@ -109,12 +123,100 @@ 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. *) +(* Returns [false] when some link is INCONSISTENT: the matcher bound + the evar to one index while unification resolved the univar to a + conflicting one. Callers must treat that as non-concretizable + (silently preferring either side would instantiate the lemma at an + index the other namespace disagrees with). *) +let propagate_idx_link (pt : pt_env) : bool = + (* SOUNDNESS GATE. This is the trust boundary where the matcher's + binding of a lemma idxvar (as an int [Flocal] evar) enters the + index world. Indices range over the NATURALS, and the only + natural-by-construction terms are the goal's own index variables: + an idxvar evar may be resolved to a [tindex] ONLY when every free + variable of that index is a declared index variable of the goal. + Without this, matching [plus : 0 <= n] against [0 <= k] for an + arbitrary int local [k] would bind [n := k] and let one prove + [0 <= k] for every [k], hence [false]. *) + let idxok = + let ids = (LDecl.tohyps pt.pte_hy).EcBaseLogic.h_tvar.EcDecl.idxvars in + let ids = List.fold_right EcIdent.Sid.add ids EcIdent.Sid.empty in + fun (ti : EcAst.tindex) -> + EcIdent.Mid.for_all + (fun id _ -> EcIdent.Sid.mem id ids) + (EcAst.tindex_fv ti) + in + let ok = ref true 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 + (* Chase assignment chains: [?u := ?v] with [?v := 5] must read + as resolved-to-5, and compound assignments count as resolved + once univar-free. *) + let u_resolved = + match EcUnify.UniEnv.repr_tindex pt.pte_ue (EcAst.TIUnivar u) with + | EcAst.TIUnivar _ -> None + | ti -> Some ti + 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 when idxok ti -> + (try EcUnify.unify_idx (LDecl.toenv pt.pte_hy) + pt.pte_ue (EcAst.TIUnivar u) ti + with EcUnify.UnificationFailure _ -> ok := false) + | _ -> ()) + | _ -> ()) + | 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); + !ok + let can_concretize (pt : pt_env) = - EcMatching.can_concretize !(pt.pte_ev) pt.pte_ue + propagate_idx_link pt + && EcMatching.can_concretize !(pt.pte_ev) pt.pte_ue (* -------------------------------------------------------------------- *) 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 subst = + List.fold_left (fun s (id, u) -> + let ti = + EcUnify.UniEnv.repr_tindex pe.pte_ue (EcAst.TIUnivar u) in + match EcCoreFol.f_of_tindex_opt ti with + | Some f -> EcCoreSubst.Fsubst.f_bind_local s id f + | None -> s) + subst !(pe.pte_idx_link) + in + CPTEnv subst (* -------------------------------------------------------------------- *) let concretize_e_form_gen (CPTEnv subst) ids f = @@ -140,7 +242,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 = @@ -226,12 +331,45 @@ 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 in + 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 + 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; } (* -------------------------------------------------------------------- *) @@ -459,7 +597,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 @@ -524,11 +662,44 @@ 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 in + 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 + 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 + 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 = @@ -536,8 +707,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/ecProofTerm.mli b/src/ecProofTerm.mli index bb4aaf6a4..341b93e4c 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; pte_lc : EcEnv.simplify_context; (* proof-local simplify context *) } diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 6dffd0f6d..0f64e2f25 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -21,17 +21,25 @@ let unienv_of_hyps hyps = let tv = (LDecl.tohyps hyps).EcBaseLogic.h_tvar in EcUnify.UniEnv.create (Some tv) +(* ------------------------------------------------------------------ *) +(* [FreeIndexVariables] when the unification env is closed on the + type side but not on the index side. *) +let free_uni_error (ue : EcUnify.unienv) = + if EcUnify.UniEnv.closed_tv ue && not (EcUnify.UniEnv.closed_iu ue) + then EcTyping.FreeIndexVariables + else EcTyping.FreeTypeVariables + (* ------------------------------------------------------------------ *) let process_form_opt ?mv hyps pf oty = + let ue = unienv_of_hyps hyps in try - let ue = unienv_of_hyps hyps in let ff = EcTyping.trans_form_opt ?mv (LDecl.toenv hyps) ue pf oty in - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in EcFol.Fsubst.f_subst ts ff with EcUnify.UninstantiateUni -> EcTyping.tyerror pf.EcLocation.pl_loc - (LDecl.toenv hyps) EcTyping.FreeTypeVariables + (LDecl.toenv hyps) (free_uni_error ue) (* ------------------------------------------------------------------ *) let process_form ?mv hyps pf ty = @@ -61,9 +69,9 @@ let process_type hyps pty = let ty = EcTyping.transty EcTyping.tp_tydecl env ue pty in if not (EcUnify.UniEnv.closed ue) then - EcTyping.tyerror (EcLocation.loc pty) env EcTyping.FreeTypeVariables; + EcTyping.tyerror (EcLocation.loc pty) env (free_uni_error ue); - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in EcCoreSubst.ty_subst ts ty (* ------------------------------------------------------------------ *) @@ -73,17 +81,17 @@ let process_stmt hyps s = let s = EcTyping.transstmt env ue s in try - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in s_subst ts s with EcUnify.UninstantiateUni -> - EcTyping.tyerror EcLocation._dummy env EcTyping.FreeTypeVariables + EcTyping.tyerror EcLocation._dummy env (free_uni_error ue) (* ------------------------------------------------------------------ *) let process_exp hyps mode oty e = let env = LDecl.toenv hyps in let ue = unienv_of_hyps hyps in let e = EcTyping.transexpcast_opt env mode ue oty e in - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in e_subst ts e (* ------------------------------------------------------------------ *) @@ -120,7 +128,7 @@ let pf_process_poe hyps poe = let env = LDecl.toenv hyps in let ue = unienv_of_hyps hyps in let m = EcTyping.trans_poe env ue poe in - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = EcUnify.UniEnv.close_subst ue in Mop.map (EcFol.Fsubst.f_subst ts) m (* ------------------------------------------------------------------ *) @@ -165,8 +173,7 @@ let tc1_process_stmt ?map hyps tc c = let env = LDecl.toenv hyps in let ue = unienv_of_hyps hyps in let c = Exn.recast_pe !!tc hyps (fun () -> EcTyping.transstmt ?map env ue c) in - let uidmap = Exn.recast_pe !!tc hyps (fun () -> EcUnify.UniEnv.close ue) in - let es = Tuni.subst uidmap in + let es = Exn.recast_pe !!tc hyps (fun () -> EcUnify.UniEnv.close_subst ue) in s_subst es c @@ -233,16 +240,39 @@ 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 check_ix () = + match EcUnify.tvi_indices tvi with + | EcUnify.IXunamed [] -> () + + | EcUnify.IXunamed ixargs -> + if List.length ixargs <> List.length typ.EcDecl.idxvars then + tc_error pe + "wrong number of index parameters (%d, expecting %d)" + (List.length ixargs) (List.length typ.EcDecl.idxvars) + + | EcUnify.IXnamed ixargs -> + (* May be partial: only reject names that bind nothing. *) + let ixnames = List.map EcIdent.name typ.EcDecl.idxvars in + List.iter + (fun (x, _) -> + if not (List.mem x ixnames) then + tc_error pe "unknown index variable: %s" x) + ixargs + in + + let typ = typ.tyvars in match tvi with | None -> () - | Some (EcUnify.TVIunamed tyargs) -> - if List.length tyargs <> List.length typ then + | Some (EcUnify.TVIunamed (_ix, tyargs)) -> + check_ix (); + 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) - | Some (EcUnify.TVInamed tyargs) -> + | Some (EcUnify.TVInamed (_ix, tyargs)) -> + check_ix (); let typnames = List.map EcIdent.name typ in List.iter (fun (x, _) -> diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 16d28b43e..de56c711e 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -22,10 +22,27 @@ 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 + 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 + + 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 +57,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 +151,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 +421,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 +555,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 -> @@ -710,14 +728,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 = @@ -741,6 +765,43 @@ let eta_expand bd f ty = | _ -> assert false) bd in (f_app f args ty) +(* -------------------------------------------------------------------- *) +(* Index patterns are matched WITHOUT the unification engine: a + normalized pattern index is a constant (compared canonically), + a bare idxvar (bound by assignment on first occurrence, checked + by canonical equality on repeats), or [b + k] (solved as + [k := term - b] when the term's canonical constant part is at + least [b]). [tindex_of_canonical] puts the constant first, so + these three shapes are exactly the affine single-variable + fragment in normal form. *) +type idx_pattern = + | IPconst + | IPaffine of EcIdent.t * EcBigInt.zint + +let classify_idx_pattern (ti : EcAst.tindex) : idx_pattern option = + match ti with + | TIConst _ -> Some IPconst + | TIVar k -> Some (IPaffine (k, EcBigInt.zero)) + | TIAdd (TIConst b, TIVar k) -> Some (IPaffine (k, b)) + | _ -> None + +(* [term - b] over the naturals, on canonical forms: defined iff the + canonical constant part of [term] is at least [b]. *) +let subtract_const (ti : EcAst.tindex) (b : EcBigInt.zint) = + if EcBigInt.sign b = 0 then Some (EcAst.tindex_normalize ti) else + match EcAst.tindex_normalize ti with + | TIConst c -> + if EcBigInt.compare c b >= 0 + then Some (EcAst.TIConst (EcBigInt.sub c b)) + else None + | TIAdd (TIConst c, rest) -> + if EcBigInt.compare c b >= 0 then + let c = EcBigInt.sub c b in + Some (if EcBigInt.sign c = 0 then rest + else EcAst.TIAdd (TIConst c, rest)) + else None + | _ -> None + (* -------------------------------------------------------------------- *) let reduce_user_gen simplify ri env hyps f = if not ri.user then raise nohead; @@ -769,7 +830,7 @@ let reduce_user_gen simplify ri env hyps f = |> List.filter_map (fun ((_, rule) : EcEnv.Reduction.entry) -> let p' : EcEnv.Reduction.topsym = match rule.rl_ptn with - | Rule (`Op p, _) -> `Path (fst p) + | Rule (`Op (p, _, _), _) -> `Path p | Rule (`Tuple, _) -> `Tuple | Rule (`Proj i, _) -> `Proj i | Var _ | Int _ -> assert false @@ -812,17 +873,39 @@ let reduce_user_gen simplify ri env hyps f = | None -> pv := Mid.add x f !pv | Some f' -> check_alpha_eq f f' in + (* Index side: matcher-free (see [idx_pattern]). A binding + seeds [pv] through [f_of_tindex] so that term-level + occurrences of the same idxvar are checked consistent by + [check_pv], in either binding order. *) + let iv = ref (Mid.empty : EcAst.tindex Mid.t) in + let match_index (ti : EcAst.tindex) (ptn : EcAst.tindex) = + match classify_idx_pattern ptn with + | None -> assert false (* enforced at compilation *) + | Some IPconst -> + if not (EcAst.tindex_equal ptn ti) then raise NotReducible + | Some (IPaffine (k, b)) -> + match subtract_const ti b with + | None -> raise NotReducible + | Some v -> + match Mid.find_opt k !iv with + | Some v' -> + if not (EcAst.tindex_equal v v') then raise NotReducible + | None -> + iv := Mid.add k v !iv; + check_pv k (EcCoreFol.f_of_tindex v) in + + (* Pattern types may mention idxvars bound at DEEPER nodes, so + their unification is deferred until the walk has built the + full index binding. *) + let deferred = ref ([] : (ty list * ty list) list) in + 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', ixs', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> - let tys' = List.map (Tvar.subst tvi) tys' in - - begin - try List.iter2 (EcUnify.unify env ue) tys tys' - with EcUnify.UnificationFailure _ -> raise NotReducible end; - + List.iter2 match_index ta.indices ixs'; + deferred := (ta.types, tys') :: !deferred; List.iter2 doit args args' | ({ f_node = Ftuple args} , []), R.Rule (`Tuple, args') @@ -842,16 +925,27 @@ let reduce_user_gen simplify ri env hyps f = doit f rule.R.rl_ptn; + let ivsubst = Fsubst.f_subst_init ~freshen:false ~idx:!iv () in + + List.iter (fun (tys, tys') -> + let tys' = List.map (Tvar.subst tvi) tys' in + let tys' = + if Mid.is_empty !iv then tys' + else List.map (EcCoreSubst.ty_subst ivsubst) tys' in + try List.iter2 (EcUnify.unify env ue) tys tys' + with EcUnify.UnificationFailure _ -> raise NotReducible) + !deferred; + if not (EcUnify.UniEnv.closed ue) then raise NotReducible; let subst f = - let uidmap = EcUnify.UniEnv.assubst ue in - let ts = Tuni.subst uidmap in + let ts = EcUnify.UniEnv.as_subst ue in let subst = ts in let subst = Mid.fold (fun x f s -> Fsubst.f_bind_local s x f) !pv subst in + let f = if Mid.is_empty !iv then f else Fsubst.f_subst ivsubst f in Fsubst.f_subst subst (Fsubst.f_subst_tvar ~freshen:true tvi f) in @@ -915,6 +1009,9 @@ let reduce_logic ri env hyps f p args = | Some (`Eq ), [f1;f2] -> begin match fst_map f_node (destr_app f1), fst_map f_node (destr_app f2) with + (* Ignoring the ctor targs is sound only because datatypes are + NON-REFINING (same-typed ctor applications have canonically + equal targs); see the twin case in EcCallbyValue.f_eq_simpl. *) | (Fop (p1, _), args1), (Fop (p2, _), args2) when EcEnv.Op.is_dtype_ctor env p1 && EcEnv.Op.is_dtype_ctor env p2 -> @@ -927,11 +1024,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) @@ -954,11 +1051,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 @@ -1110,9 +1207,10 @@ let reduce_head simplify ri env hyps f = subst bds pargs in 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 + EcFol.f_subst_tparams ~freshen:true + op.EcDecl.op_tparams.idxvars op.EcDecl.op_tparams.tyvars + tys body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1510,16 +1608,19 @@ 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) when EqTest_i.for_type env f1'.f_ty f2'.f_ty && List.length args1 = List.length args2 -> begin - (* So that we do not unfold operators *) + (* So that we do not unfold operators. The heads count as equal + only at the SAME instantiation: comparing paths alone would + make [f[:3] x] and [f[:5] x] convertible. *) match f1'.f_node, f2'.f_node with - | Fop(p1, _), Fop(p2, _) when EcPath.p_equal p1 p2 -> + | Fop(p1, ta1), Fop(p2, ta2) + when EcPath.p_equal p1 p2 && EqTest_i.for_targs env ta1 ta2 -> conv_next ri env f1' (zapp args1 args2 f1.f_ty stk) | _, _ -> conv ri env f1' f2' (zapp args1 args2 f1.f_ty stk) @@ -1774,26 +1875,55 @@ module User = struct type error = | MissingVarInLhs of EcIdent.t | MissingTyVarInLhs of EcIdent.t + | MissingIdxVarInLhs of EcIdent.t | NotAnEq | NotFirstOrder + | IdxNotAffine | RuleDependsOnMemOrModule | HeadedByVar exception InvalidUserRule of error + let string_of_error = function + | MissingVarInLhs x -> + Printf.sprintf + "variable `%s' does not occur in the left-hand side" + (EcIdent.name x) + | MissingTyVarInLhs a -> + Printf.sprintf + "type variable `%s' does not occur in the left-hand side" + (EcIdent.name a) + | MissingIdxVarInLhs k -> + Printf.sprintf + "index variable `%s' is not bound by an index position of \ + the left-hand side" + (EcIdent.name k) + | NotAnEq -> + "the lemma is not an (in)equation" + | NotFirstOrder -> + "the left-hand side is not a first-order pattern" + | IdxNotAffine -> + "index arguments in the left-hand side must be a constant, an \ + index variable `k', or `k + b' with `b' a constant" + | RuleDependsOnMemOrModule -> + "the lemma depends on a memory or a module" + | HeadedByVar -> + "the left-hand side is headed by a variable" + module R = EcTheory type rule = EcEnv.Reduction.rule - type compile_st = { cst_ty_vs : Sid.t; cst_f_vs : Sid.t; } + type compile_st = + { cst_ty_vs : Sid.t; cst_f_vs : Sid.t; cst_ix_vs : Sid.t; } let empty_cst : compile_st = - { cst_ty_vs = Sid.empty; cst_f_vs = Sid.empty; } + { cst_ty_vs = Sid.empty; cst_f_vs = Sid.empty; cst_ix_vs = Sid.empty; } 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 @@ -1827,8 +1957,13 @@ 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 -> + let ixs = List.map EcAst.tindex_normalize ta.indices in + List.iter (fun ti -> + if classify_idx_pattern ti = None then + raise (InvalidUserRule IdxNotAffine)) + ixs; + R.Rule (`Op (p, ixs, ta.types), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fproj (target, i) }, [] -> @@ -1849,23 +1984,31 @@ module User = struct | R.Int _ -> cst | R.Rule (op, args) -> - let ltyvars = + let ltyvars, lixvars = match op with - | `Op (_, tys) -> - List.fold_left ( - let rec doit ltyvars = function - | { ty_node = Tvar a } -> Sid.add a ltyvars - | _ as ty -> ty_fold doit ltyvars ty in doit) - cst.cst_ty_vs tys - | `Tuple -> cst.cst_ty_vs - | `Proj _ -> cst.cst_ty_vs in - let cst = {cst with cst_ty_vs = ltyvars } in + | `Op (_, ixs, tys) -> + let ltyvars = + List.fold_left ( + let rec doit ltyvars = function + | { ty_node = Tvar a } -> Sid.add a ltyvars + | _ as ty -> ty_fold doit ltyvars ty in doit) + cst.cst_ty_vs tys in + let lixvars = + List.fold_left (fun acc ti -> + match classify_idx_pattern ti with + | Some (IPaffine (k, _)) -> Sid.add k acc + | _ -> acc) + cst.cst_ix_vs ixs in + ltyvars, lixvars + | `Tuple -> cst.cst_ty_vs, cst.cst_ix_vs + | `Proj _ -> cst.cst_ty_vs, cst.cst_ix_vs in + let cst = {cst with cst_ty_vs = ltyvars; cst_ix_vs = lixvars } in List.fold_left doit cst args 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. @@ -1887,6 +2030,14 @@ module User = struct if not (Sid.is_empty mtyvars) then raise (InvalidUserRule (MissingTyVarInLhs (Sid.choose mtyvars))); + (* Idxvars must be inferable from LHS index positions: an idxvar + occurring only as an int term (or only in types) cannot be + recovered by the matcher-free index matching. *) + let mixvars = Sid.diff (Sid.of_list ax.ax_tparams.idxvars) cst.cst_ix_vs in + + if not (Sid.is_empty mixvars) then + raise (InvalidUserRule (MissingIdxVarInLhs (Sid.choose mixvars))); + begin match rule with | R.Var _ -> raise (InvalidUserRule (HeadedByVar)); | _ -> () end; @@ -1937,7 +2088,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/ecReduction.mli b/src/ecReduction.mli index f69c1d48f..e440d455b 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 @@ -44,13 +45,17 @@ module User : sig type error = | MissingVarInLhs of EcIdent.t | MissingTyVarInLhs of EcIdent.t + | MissingIdxVarInLhs of EcIdent.t | NotAnEq | NotFirstOrder + | IdxNotAffine | RuleDependsOnMemOrModule | HeadedByVar exception InvalidUserRule of error + val string_of_error : error -> string + type rule = EcEnv.Reduction.rule val compile : opts:options -> prio:int -> EcEnv.env -> EcPath.path -> rule diff --git a/src/ecScope.ml b/src/ecScope.ml index 8f0e27f87..620467746 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -949,12 +949,28 @@ module Ax = struct sc_locdoc = DocState.add_item scope.sc_locdoc; } (* ------------------------------------------------------------------ *) - let start_lemma ?(strict = false) scope (cont, axflags) check ?name (axd, ctxt) = + let start_lemma ?(strict = false) + 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 + (* Section-declared indices are natural numbers. Those actually + used by this lemma are registered as int-typed idxvars in the + proof hypotheses (so tactics/SMT resolve them); generalization + re-adds a [{n}] binder on close. Indices the lemma does not + mention are left out entirely. Their non-negativity is NOT + injected automatically: proofs that need [0 <= n] obtain it + explicitly (e.g. from [Int.ge0_index]). *) + let used_idxs = + let fv = EcSection.form_idx_fv axd.ax_spec in + List.filter (fun id -> Mid.mem id fv) + (EcEnv.declared_indices (env scope)) in + let proof_tparams : ty_params = + { axd.ax_tparams with + idxvars = axd.ax_tparams.idxvars @ used_idxs } in + let hyps = EcEnv.LDecl.init (env scope) proof_tparams in let proof = EcCoreGoal.start hyps axd.ax_spec in PSCheck proof in @@ -979,7 +995,9 @@ 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 env = TT.bind_idx_locals env ue in let (pconcl, tintro) = match ax.pa_vars with @@ -999,10 +1017,14 @@ module Ax = struct let concl = TT.trans_prop env ue pconcl in if not (EcUnify.UniEnv.closed ue) then - hierror "the formula contains free type variables"; + if EcUnify.UniEnv.closed_tv ue then + hierror + "cannot infer all index parameters in the formula; \ + supply them explicitly (e.g. `f[:n = 3]')" + else + 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 @@ -1114,7 +1136,10 @@ module Ax = struct (None, { scope with sc_env = puc.puc_init }) (* ------------------------------------------------------------------ *) - and start_lemma_with_proof ?(strict = false) scope tintro pucflags (mode, tc) check ?name axd = + and start_lemma_with_proof + ?(strict = false) + scope tintro pucflags (mode, tc) check ?name axd + = let { pl_loc = loc; pl_desc = tc } = tc in let scope = start_lemma ~strict scope pucflags check ?name (axd, None) in @@ -1283,7 +1308,9 @@ 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 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) = @@ -1311,7 +1338,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 @@ -1319,10 +1346,14 @@ module Op = struct in if not (EcUnify.UniEnv.closed ue) then - hierror ~loc "this operator type contains free type variables"; + if EcUnify.UniEnv.closed_tv ue then + hierror ~loc + "cannot infer all index parameters of this operator; \ + supply them explicitly (e.g. `f[:n = 3]')" + else + 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 @@ -1391,27 +1422,27 @@ 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 opidx = List.map (fun id -> EcAst.TIVar id) tparams.idxvars in + let opapp = List.map tvar tparams.tyvars in + let opapp = + e_app (e_op opname ~indices:opidx ~tyargs:opapp ty) + opargs codom in let subst = EcSubst.add_opdef EcSubst.empty opname ([], opapp) in let ax = EcSubst.subst_form subst ax in let ax = f_forall (List.map (snd_map gtty) xs) ax in - let uidmap = EcUnify.UniEnv.close ue in - let subst = Tuni.subst uidmap in + let subst = EcUnify.UniEnv.close_subst ue in let ax = Fsubst.f_subst subst ax in ax in - let ax, axpm = - let bdpm = tparams 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, axipm, axpm = + EcCoreSubst.f_freshen_tparams + tparams.idxvars tparams.tyvars ax in let ax = - { ax_tparams = axpm; + { ax_tparams = { idxvars = axipm; tyvars = axpm }; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -1426,11 +1457,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 @@ -1446,8 +1478,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 @@ -1458,13 +1490,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; @@ -1557,7 +1589,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; @@ -1581,7 +1613,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 @@ -1606,7 +1638,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; @@ -1628,7 +1660,7 @@ module Op = struct 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 @@ -1643,7 +1675,7 @@ module Op = struct in let prax = EcDecl.{ - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = hax; ax_kind = `Lemma; ax_loca = op.ppo_locality; @@ -1677,7 +1709,7 @@ module Exception = struct let ue = TT.transtyvars eenv (loc, Some []) in let e_dom = transtys tp_nothing eenv ue pe.pe_dom in let tparams = EcUnify.UniEnv.tparams ue in - if tparams <> [] then + if tparams.tyvars <> [] || tparams.idxvars <> [] then hierror ~loc "Polymorphic expression are not allowed"; let e = EcDecl.mk_exception lc e_dom in let scope = bind scope (unloc pe.pe_name, e) in @@ -1808,6 +1840,20 @@ module Mod = struct end +(* -------------------------------------------------------------------- *) +(* Section-declared indices: [declare {n m}] introduces natural-number + index parameters, in scope for the rest of the section and generalized + back to [{n}] binders on section close. *) +module Index = struct + let declare (scope : scope) (ns : psymbol list) : scope = + List.fold_left (fun scope n -> + if EcEnv.lookup_declared_index (unloc n) (env scope) <> None then + hierror ~loc:n.pl_loc "duplicate declared index: `%s'" (unloc n); + let id = EcIdent.create (unloc n) in + { scope with sc_env = EcSection.add_decl_index id scope.sc_env }) + scope ns +end + (* -------------------------------------------------------------------- *) module ModType = struct let bind @@ -2105,7 +2151,12 @@ module Reduction = struct } in let red_info = - EcReduction.User.compile ~opts ~prio:idx (env scope) ax_p in + try EcReduction.User.compile ~opts ~prio:idx (env scope) ax_p + with EcReduction.User.InvalidUserRule e -> + hierror ~loc:name.pl_loc + "invalid rewrite rule `%s': %s" + (EcSymbols.string_of_qsymbol (unloc name)) + (EcReduction.User.string_of_error e) in (ax_p, opts, Some red_info) in let rules = List.map (fun (xs, idx) -> List.map (for1 idx) xs) reds in @@ -2280,7 +2331,7 @@ 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; @@ -2288,16 +2339,19 @@ module Ty = struct 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 -> ( - 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; @@ -2308,7 +2362,10 @@ module Ty = struct EHI.dterror loc env (EHI.DTE_NonPositive (symbol, ctx))) | PTYD_Record rt -> - 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 @@ -2331,19 +2388,23 @@ module Ty = struct let ue = EcUnify.UniEnv.create None in let pred = EcTyping.trans_prop env ue (snd subtype.pst_pred) in if not (EcUnify.UniEnv.closed ue) then - hierror ~loc:(snd subtype.pst_pred).pl_loc - "the predicate contains free type variables"; - if EcUnify.UniEnv.tparams ue <> [] then + if EcUnify.UniEnv.closed_tv ue then + hierror ~loc:(snd subtype.pst_pred).pl_loc + "cannot infer all index parameters in the predicate; \ + supply them explicitly (e.g. `f[:n = 3]')" + else + hierror ~loc:(snd subtype.pst_pred).pl_loc + "the predicate contains free type variables"; + if (EcUnify.UniEnv.tparams ue).tyvars <> [] || (EcUnify.UniEnv.tparams ue).idxvars <> [] then hierror ~loc:(snd subtype.pst_pred).pl_loc "Polymorphic predicates are not allowed. \ Use clones if you want to make a polymorphic subtype."; - let uidmap = EcUnify.UniEnv.close ue in - let fs = Tuni.subst uidmap in + let fs = EcUnify.UniEnv.close_subst ue in f_lambda [(x, GTty carrier)] (Fsubst.f_subst fs pred) in let scope = let decl = EcDecl.{ - tyd_params = []; + tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Abstract; tyd_loca = `Global; tyd_clinline = false; @@ -2408,26 +2469,47 @@ module Ty = struct hierror ~loc:x.pl_loc "invalid operator name: `%s'" (unloc x); let tvi = List.map (TT.transty tp_tydecl env ue) tvi in + (* Select against the REQUIRED type at the carrier: unification + instantiates the candidate's parameters of both kinds (an + index-parametric operator resolves at the carrier's index) + and disambiguates overloaded symbols. The resolved + instantiation is RECORDED in the instance (each op is later + applied at its own recorded indices/types), so operators of + any index shape fit -- e.g. a predecessor-shaped + [exp {n} : t<:n+1> -> ...] at carrier [t<:wsz+1>] records + [ro_idxs = [wsz]]. *) + let expected = snd (Mstr.find (unloc x) rmap) in let selected = EcUnify.select_op ~filter:(fun _ -> EcDecl.is_oper) - (Some (EcUnify.TVIunamed tvi)) env (unloc op) ue ([], None) + (Some (EcUnify.TVIunamed (EcUnify.IXunamed [], tvi))) + env (unloc op) ue ([], Some expected) in let op = match selected with - | [] -> hierror ~loc:op.pl_loc "unknown operator" + | [] -> + hierror ~loc:op.pl_loc + "unknown operator, or operator with invalid type" | op1::op2::_ -> hierror ~loc:op.pl_loc "ambiguous operator (%s / %s)" - (EcPath.tostring (fst (proj4_1 op1))) - (EcPath.tostring (fst (proj4_1 op2))) - | [((p, _), _, _, _)] -> - let op = EcEnv.Op.by_path p env in - let opty = - Tvar.subst - (Tvar.init op.op_tparams tvi) - op.op_ty - in - (p, opty) + (EcPath.tostring (proj3_1 (proj4_1 op1))) + (EcPath.tostring (proj3_1 (proj4_1 op2))) + | [((p, ixs, tys), _, subue, _)] -> + EcUnify.UniEnv.restore ~src:subue ~dst:ue; + if not (EcUnify.UniEnv.closed ue) then + hierror ~loc:op.pl_loc + "cannot infer the instantiation of operator `%s' \ + from the carrier type" + (EcPath.tostring p); + let ts = EcUnify.UniEnv.as_subst ue in + let ixs = + List.map + (fun ti -> + EcAst.tindex_normalize + (EcCoreSubst.tindex_subst ts ti)) + ixs in + let tys = List.map (ty_subst ts) tys in + EcDecl.{ ro_op = p; ro_idxs = ixs; ro_tys = tys } in Mstr.change @@ -2445,17 +2527,14 @@ module Ty = struct hierror "no definition for operator `%s'" x) reqs; List.fold_left - (fun m (x, (_, ty)) -> + (fun m (x, _) -> match Mstr.find_opt x ops with | None -> m - | Some (loc, (p, opty)) -> - if not (EcReduction.EqTest.for_type env ty opty) then - hierror ~loc "invalid type for operator `%s'" x; - Mstr.add x p m) + | Some (_, p) -> Mstr.add x p m) Mstr.empty reqs (* ------------------------------------------------------------------ *) - let check_tci_axioms scope mode axs reqs lc = + let check_tci_axioms scope mode ?(typ = { idxvars = []; tyvars = [] }) axs reqs lc = let rmap = Mstr.of_list reqs in let symbs, axs = List.map_fold @@ -2472,7 +2551,7 @@ module Ty = struct (fun (x, req) -> if not (Mstr.mem x symbs) then let ax = { - ax_tparams = []; + ax_tparams = typ; ax_spec = req; ax_kind = `Lemma; ax_loca = lc; @@ -2487,7 +2566,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 = typ; ax_spec = f; ax_kind = `Lemma; ax_smt = false; @@ -2537,21 +2616,19 @@ module Ty = struct hierror "load AlgTactic/Ring first"; let ty = - let ue = TT.transtyvars env (loc, Some (fst tci.pti_type)) in + let ue = TT.transtyvars ~idxparams:tci.pti_idx env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl env ue (snd tci.pti_type) in assert (EcUnify.UniEnv.closed ue); - let uidmap = EcUnify.UniEnv.close ue in - (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) + let fs = EcUnify.UniEnv.close_subst ue in + (EcUnify.UniEnv.tparams ue, ty_subst fs ty) in - if not (List.is_empty (fst ty)) then - hierror "ring instances cannot be polymorphic"; let symbols = EcAlgTactic.ring_symbols env kind (snd ty) in let symbols = check_tci_operators env ty tci.pti_ops symbols in let cr = ring_of_symmap ?name:(omap unloc tci.pti_as) env (snd ty) kind symbols in let axioms = EcAlgTactic.ring_axioms env cr in let lc = (tci.pti_loca :> locality) in - let inter = check_tci_axioms scope mode tci.pti_axs axioms lc in + let inter = check_tci_axioms scope mode ~typ:(fst ty) tci.pti_axs axioms lc in let add env p = let item = EcTheory.Th_instance (ty,`General p, tci.pti_loca) in let item = EcTheory.mkitem ~import item in @@ -2561,7 +2638,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 (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] } @@ -2580,20 +2657,18 @@ module Ty = struct hierror "load AlgTactic/Ring first"; let ty = - let ue = TT.transtyvars env (loc, Some (fst tci.pti_type)) in + let ue = TT.transtyvars ~idxparams:tci.pti_idx env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl env ue (snd tci.pti_type) in assert (EcUnify.UniEnv.closed ue); - let uidmap = EcUnify.UniEnv.close ue in - (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) + let fs = EcUnify.UniEnv.close_subst ue in + (EcUnify.UniEnv.tparams ue, ty_subst fs ty) in - if not (List.is_empty (fst ty)) 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 let cr = field_of_symmap ?name:(omap unloc tci.pti_as) env (snd ty) symbols in let axioms = EcAlgTactic.field_axioms env cr in let lc = (tci.pti_loca :> locality) in - let inter = check_tci_axioms scope mode tci.pti_axs axioms lc; in + let inter = check_tci_axioms scope mode ~typ:(fst ty) tci.pti_axs axioms lc; in let add env p = let item = EcTheory.Th_instance(ty,`General p, tci.pti_loca) in let item = EcTheory.mkitem ~import item in @@ -2603,7 +2678,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 (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] } @@ -2612,7 +2687,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 @@ -2621,10 +2696,10 @@ module Ty = struct (* ------------------------------------------------------------------ *) let add_generic_tc (scope : scope) _mode { pl_desc = tci; pl_loc = loc; } = let ty = - let ue = TT.transtyvars scope.sc_env (loc, Some (fst tci.pti_type)) in + let ue = TT.transtyvars ~idxparams:tci.pti_idx scope.sc_env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl scope.sc_env ue (snd tci.pti_type) in assert (EcUnify.UniEnv.closed ue); - (EcUnify.UniEnv.tparams ue, Tuni.offun (EcUnify.UniEnv.close ue) ty) + (EcUnify.UniEnv.tparams ue, ty_subst (EcUnify.UniEnv.close_subst ue) ty) in let (tcp, tc) = @@ -2687,7 +2762,7 @@ end module Circuit = struct type preoperator = [ | `Path of path - | `Direct of ty_params * expr + | `Direct of EcIdent.t list * expr | `Form of pformula ] @@ -2736,10 +2811,11 @@ module Circuit = struct | `Direct (tparams, body) -> `Direct (tparams, form_of_expr body) | `Form f -> `BySyntax - { opov_tyvars = None - ; opov_args = [] - ; opov_retty = loced PTunivar - ; opov_body = f } in + { opov_idxvars = [] + ; opov_tyvars = None + ; opov_args = [] + ; opov_retty = loced PTunivar + ; opov_body = f } in let ovrd = (loced (ovrd, mode) :> EcThCloning.xop_override located) in { evc with evc_ops = Msym.add name ovrd evc.evc_ops } ) nm evc @@ -2793,8 +2869,8 @@ module Circuit = struct { name; kind = CRBT_Type (pqname root name) } | EcTheory.Th_operator (name, op) -> (* FIXME PY: refresh type parameters? *) - let tvars = List.map tvar op.op_tparams in - let body = e_op (pqname root name) tvars op.op_ty in + let tvars = List.map tvar op.op_tparams.tyvars in + let body = e_op (pqname root name) ~tyargs:tvars op.op_ty in { name; kind = CRBT_Op (op.op_tparams, body) } | EcTheory.Th_axiom (name, _) -> { name; kind = CRBT_Lemma (pqname root name) } @@ -2811,7 +2887,7 @@ module Circuit = struct hierror ~loc:(loc bs.type_) "cannot find named type: `%s'" (string_of_qsymbol (unloc bs.type_)) | Some (path, decl) -> - if not (List.is_empty decl.tyd_params) then + if not (List.is_empty decl.tyd_params.tyvars && List.is_empty decl.tyd_params.idxvars) then hierror ~loc:(loc bs.type_) "bit-string type must be a monomorphic named type: `%s'" (string_of_qsymbol (unloc bs.type_)); @@ -2842,7 +2918,7 @@ module Circuit = struct let size_f = EcTyping.trans_form env (EcUnify.UniEnv.create None) bs.size tint in let size_i = try - Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env []) size_f |> destr_int |> BI.to_int) + Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env { idxvars = []; tyvars = [] }) size_f |> destr_int |> BI.to_int) with | DestrError "destr_int" -> None | EcEnv.NotReducible -> None @@ -2879,7 +2955,7 @@ module Circuit = struct (string_of_qsymbol (unloc ba.type_)) | Some (path, decl) -> - if List.length decl.tyd_params <> 1 then + if List.length decl.tyd_params.tyvars <> 1 then hierror ~loc:(loc ba.type_) "type constructor should take exactly one parameter: `%s'" (string_of_qsymbol (unloc ba.type_)); @@ -2916,7 +2992,7 @@ module Circuit = struct let size_f = EcTyping.trans_form env (EcUnify.UniEnv.create None) ba.size tint in let size_i = try - Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env []) size_f |> destr_int |> BI.to_int) + Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env { idxvars = []; tyvars = [] }) size_f |> destr_int |> BI.to_int) with | DestrError "destr_int" -> None | EcEnv.NotReducible -> None @@ -3052,13 +3128,13 @@ module Circuit = struct (string_of_qsymbol (unloc ty)) | Some (path, decl), `BV _ -> - if List.length decl.tyd_params <> 0 then + if List.length decl.tyd_params.tyvars <> 0 then hierror ~loc:(loc ty) "a bit-string type must be a monomorphic named type"; path | Some (path, decl), `A -> - if List.length decl.tyd_params <> 1 then + if List.length decl.tyd_params.tyvars <> 1 then hierror ~loc:(ty.pl_loc) "an array type must be a 1-polymorphic named type"; path @@ -3154,7 +3230,7 @@ module Circuit = struct List.filter_map (fun (qname, (item : crb_theory1)) -> match item.kind with | CRBT_Op (tparams, e) -> - Some (qname, `Direct (tparams, e), `Inline `Clear) + Some (qname, `Direct (tparams.tyvars, e), `Inline `Clear) | _ -> None ) cltheories in @@ -3197,7 +3273,7 @@ module Circuit = struct let env = env scope in let operator, opdecl = EcEnv.Op.lookup op.pl_desc env in - if not (List.is_empty opdecl.op_tparams) then + if not (List.is_empty opdecl.op_tparams.tyvars && List.is_empty opdecl.op_tparams.idxvars) then hierror ~loc:(loc op) "operator must be monomorphic"; let ospec = EcEnv.Circuit.get_specification_by_name ~filename (unloc circ) in diff --git a/src/ecScope.mli b/src/ecScope.mli index d73ed66d7..5a70bc4aa 100644 --- a/src/ecScope.mli +++ b/src/ecScope.mli @@ -154,6 +154,11 @@ module Mod : sig val import : scope -> pmsymbol located -> scope end +(* -------------------------------------------------------------------- *) +module Index : sig + val declare : scope -> psymbol list -> scope +end + (* -------------------------------------------------------------------- *) module ModType : sig val add : ?src:string -> scope -> pinterface -> scope diff --git a/src/ecSearch.ml b/src/ecSearch.ml index 8a3621c27..3a8a97a8c 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 fd3db896b..ec81f6c64 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -175,7 +175,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] (* -------------------------------------------------------------------- *) @@ -215,7 +215,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 () @@ -292,7 +292,7 @@ and on_form (aenv : aenv) (f : EcFol.form) = | EcAst.Fpr pr -> on_pr aenv pr | 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 = @@ -525,18 +525,22 @@ and on_modsig (aenv : aenv) (ms:module_sig) = (* -------------------------------------------------------------------- *) and on_ring (aenv : aenv) (r : ring) = on_ty aenv r.r_type; - let on_p p = on_opname aenv p in - List.iter on_p [r.r_zero; r.r_one; r.r_add; r.r_mul]; - List.iter (oiter on_p) [r.r_opp; r.r_exp; r.r_sub]; + let on_o (o : EcDecl.ring_op) = + on_opname aenv o.ro_op; + List.iter (on_ty aenv) o.ro_tys in + List.iter on_o [r.r_zero; r.r_one; r.r_add; r.r_mul]; + List.iter (oiter on_o) [r.r_opp; r.r_exp; r.r_sub]; match r.r_embed with | `Direct | `Default -> () - | `Embed p -> on_p p + | `Embed o -> on_o o (* -------------------------------------------------------------------- *) and on_field (aenv : aenv) (f : field) = on_ring aenv f.f_ring; - let on_p p = on_opname aenv p in - on_p f.f_inv; oiter on_p f.f_div + let on_o (o : EcDecl.ring_op) = + on_opname aenv o.ro_op; + List.iter (on_ty aenv) o.ro_tys in + on_o f.f_inv; oiter on_o f.f_div (* -------------------------------------------------------------------- *) and on_instance (aenv : aenv) ty tci = @@ -546,8 +550,12 @@ and on_instance (aenv : aenv) ty tci = | `Ring r -> on_ring aenv r | `Field f -> on_field aenv f | `General p -> - (* FIXME section: ring/field use type class that do not exists *) - aenv.cb (`Typeclass p) + (* The [`General] cross-links a [`Ring]/[`Field] instance registers + (zmodule/ring/idomain markers) point at synthetic type-class paths + that do not exist as real declarations. They carry no section + dependency, so only check the ones that resolve. *) + if EcEnv.TypeClass.by_path_opt p aenv.env <> None then + aenv.cb (`Typeclass p) (* -------------------------------------------------------------------- *) type sc_name = @@ -569,6 +577,7 @@ and sc_item = | SC_th_item of EcTheory.theory_item | SC_th of EcEnv.Theory.compiled_theory | SC_decl_mod of EcIdent.t * mty_mr + | SC_decl_idx of EcIdent.t and sc_items = sc_item list @@ -663,18 +672,27 @@ let add_declared_mod to_gen id modty = tg_subst = EcSubst.add_module to_gen.tg_subst id (mpath_abs id []) } +(* A section-declared index [n] is a natural-number parameter. Typing + resolved [word<:n>] against the very ident [id], so generalization only + needs to make [id] available as an on-demand [{n}] binder — no subst. *) +let add_declared_idx to_gen id = + { to_gen with + tg_params = { to_gen.tg_params with + idxvars = to_gen.tg_params.idxvars @ [id] }; } + 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_subst = EcSubst.add_tydef to_gen.tg_subst path ([], tvar 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); @@ -695,7 +713,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 @@ -717,7 +735,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 @@ -748,7 +766,7 @@ let tydecl_fv tyd = EcIdent.fv_union (EcIdent.fv_union fv (ty_fv_and_tvar carrier)) (fv_and_tvar_f pred) 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 @@ -793,7 +811,42 @@ 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 generalize_extra_idx to_gen fv = + List.filter (fun id -> Mid.mem id fv) to_gen.tg_params.idxvars + +(* Free index variables: idents used as [TIVar] inside index arguments, + plus idxvars used as int-typed formula locals (already in [f_fv]). *) +let rec tindex_fv acc (ti : tindex) = + match ti with + | TIVar id -> Mid.add id 1 acc + | TIConst _ | TIUnivar _ -> acc + | TIAdd (a, b) | TIMul (a, b) -> tindex_fv (tindex_fv acc a) b + +let rec ty_idx_fv acc (ty : ty) = + match ty.ty_node with + | Tconstr (_, ta) -> + let acc = List.fold_left tindex_fv acc ta.indices in + List.fold_left ty_idx_fv acc ta.types + | Tfun (t1, t2) -> ty_idx_fv (ty_idx_fv acc t1) t2 + | Ttuple ts -> List.fold_left ty_idx_fv acc ts + | Tvar _ | Tunivar _ | Tglob _ -> acc + +let form_idx_fv (f : form) : int Mid.t = + let acc = ref f.f_fv in + let rec aux f = + acc := ty_idx_fv !acc f.f_ty; + (match f.f_node with + | Fop (_, ta) -> + acc := List.fold_left tindex_fv !acc ta.indices; + acc := List.fold_left ty_idx_fv !acc ta.types + | Fquant (_, d, _) -> + List.iter (fun (_, gty) -> + match gty with GTty ty -> acc := ty_idx_fv !acc ty | _ -> ()) d + | _ -> ()); + EcFol.f_iter aux f + in aux f; !acc let rec generalize_extra_args binds fv = match binds with @@ -828,10 +881,13 @@ 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 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 -> @@ -843,10 +899,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 @@ -862,12 +918,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 @@ -901,10 +957,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 @@ -912,10 +970,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 @@ -923,15 +983,23 @@ 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 idxfv = + ty_idx_fv + (match body with OP_Plain f -> form_idx_fv f | _ -> Mid.empty) + operator.op_ty in + let extra_i = generalize_extra_idx to_gen idxfv in + let tparams : ty_params = + { idxvars = extra_i @ 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 i_args = List.map (fun id -> TIVar id) tparams.idxvars in + let eop = e_op path ~indices:i_args ~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 = @@ -961,15 +1029,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 = @@ -992,7 +1062,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 @@ -1027,11 +1099,14 @@ 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 extra_i = generalize_extra_idx to_gen (form_idx_fv ax_spec) in + let ax_tparams : ty_params = + { idxvars = extra_i @ 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 @@ -1092,7 +1167,16 @@ let generalize_instance to_gen (ty,tci, lc) = if lc = `Local then to_gen, None (* FIXME: be sure that we have no dep to declare or local, or fix this code *) - else to_gen, Some (Th_instance (ty,tci,lc)) + else + (* Generalize the instance over the section's declared indices that its + carrier depends on, e.g. a ring registered in-section over + [word<:n+1>] becomes an [{n}]-parametric instance. (Type-variable + polymorphism of instances stays forbidden; only indices generalize.) *) + let idxfv = ty_idx_fv Mid.empty (snd ty) in + let extra_i = generalize_extra_idx to_gen idxfv in + let params = fst ty in + let ty = ({ params with idxvars = params.idxvars @ extra_i }, snd ty) in + to_gen, Some (Th_instance (ty,tci,lc)) let generalize_baserw to_gen prefix (s,lc) = if lc = `Local then @@ -1192,8 +1276,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" @@ -1549,6 +1633,8 @@ and generalize_lc_item (genenv : to_gen) (prefix : path) (item : sc_item) = match item with | SC_decl_mod (id, modty) -> add_declared_mod genenv id modty + | SC_decl_idx id -> + add_declared_idx genenv id | SC_th_item th_item -> generalize_th_item genenv prefix th_item | SC_th cth -> @@ -1562,7 +1648,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 } @@ -1654,6 +1740,17 @@ let add_decl_mod id mt scenv = sc_env = EcEnv.Mod.declare_local id mt scenv.sc_env; sc_items = SC_decl_mod (id, mt) :: scenv.sc_items } +let add_decl_index id scenv = + match scenv.sc_name with + | Th _ | Top -> + hierror "declare index is only allowed inside a section" + | Sc _ -> + let env = EcEnv.push_declared_index id scenv.sc_env in + let env = EcEnv.Var.bind_local id EcTypes.tint env in + { scenv with + sc_env = env; + sc_items = SC_decl_idx id :: scenv.sc_items } + (* -----------------------------------------------------------*) let enter_section (name : symbol option) (scenv : scenv) = { sc_env = scenv.sc_env; diff --git a/src/ecSection.mli b/src/ecSection.mli index 0ca9d26e3..9bcc4dec2 100644 --- a/src/ecSection.mli +++ b/src/ecSection.mli @@ -15,6 +15,11 @@ val initial : env -> scenv val add_item : ?override_locality:EcTypes.is_local option -> theory_item -> scenv -> scenv val add_decl_mod : EcIdent.t -> mty_mr -> scenv -> scenv +val add_decl_index : EcIdent.t -> scenv -> scenv + +(* Free index variables of a formula (idents used inside index arguments, + or as int-typed formula locals). *) +val form_idx_fv : form -> int EcIdent.Mid.t val enter_section : EcSymbols.symbol option -> scenv -> scenv val exit_section : EcSymbols.symbol option -> scenv -> scenv diff --git a/src/ecSmt.ml b/src/ecSmt.ml index f4a167b17..f8d11a9da 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -77,6 +77,13 @@ type tenv = { (*---*) te_known_w3 : w3_known_op Hp.t; (*---*) tk_known_w3 : (kpattern * w3_known_op) list; (*---*) te_ty : w3ty Hp.t; + (* Per-index-position "width observer" symbols of an indexed family: + [size_k : ('a, ...) t -> int]. They make the erased index + recoverable at the term level for VALUES (operations already + thread theirs as leading int arguments), so quantifiers over + [t<:i>] can be relativized -- without the guards, an axiom stated + at one width would constrain the whole erased sort. *) + (*---*) te_size : WTerm.lsymbol list Hp.t; (*---*) te_op : w3op Hp.t; (*---*) te_lc : w3op Hid.t; mutable te_lam : WTerm.term Mta.t; @@ -92,6 +99,7 @@ let empty_tenv env task (kwty, kw, kwk) = ty_known_w3 = kwty; tk_known_w3 = kwk; te_ty = Hp.create 0; + te_size = Hp.create 0; te_op = Hp.create 0; te_lc = Hid.create 0; te_lam = Mta.empty; @@ -190,6 +198,14 @@ end let load_wtheory (genv : tenv) (th : WTheory.theory) : unit = genv.te_task <- WTask.use_export genv.te_task th +(* [0 <= t] at the Why3 level. Guards must not depend on the EC int + theory being in scope (a file need not require CoreInt for its + indexed goals to translate). *) +let w3_ge0 (genv : tenv) (t : WTerm.term) : WTerm.term = + let ls, th = Hp.find genv.te_known_w3 CI_Int.p_int_le in + load_wtheory genv th; + WTerm.ps_app ls [WTerm.t_int_const (BI.to_why3 BI.zero); t] + (* -------------------------------------------------------------------- *) (* Create why3 tuple theory with projector *) @@ -265,20 +281,46 @@ 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 + 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; + (* goal idxvars range over the naturals *) + let wfact = w3_ge0 genv (WTerm.t_app_infer ls []) in + let pr = + WDecl.create_prsymbol + (WIdent.id_fresh (EcIdent.name id ^ "_ge0")) in + genv.te_task <- + WTask.add_decl genv.te_task + (WDecl.create_prop_decl WDecl.Paxiom pr wfact)) + ts.idxvars; + (env, tysyms) (* -------------------------------------------------------------------- *) let instantiate tparams ~textra targs tres tys = @@ -364,6 +406,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 +423,12 @@ let rec trans_ty ((genv, lenv) as env) ty = | Ttuple ts-> wty_tuple genv (trans_tys env ts) | Tconstr (p, tys) -> - let id = trans_pty genv p in - WTy.ty_app id (trans_tys env tys) + (* Indices are carried at the term level (as explicit int arguments + on the indexed operators), not at the sort level: [word<:n>] and + [word<:m>] share the single sort [word]. Sound because a + cross-width equation is ill-typed in EC and never reaches Why3, + while every width-dependent operator threads its index. *) + WTy.ty_app (trans_pty genv p) (trans_tys env tys.types) | Tfun (t1, t2) -> WTy.ty_func (trans_ty env t1) (trans_ty env t2) @@ -398,6 +450,18 @@ and trans_tydecl genv (p, tydecl) = let pid = preid_p p in let lenv, tparams = lenv_of_tparams tydecl.tyd_params in + (* Indexed datatypes/records have no sound erased encoding yet: a + width-erased constructor would conflate values across widths + (e.g. a nullary constructor at two widths), and the size axioms + would then be inconsistent. A sound encoding needs the indices + as constructor arguments; until then, degrade to the sound + CanNotTranslate paths instead of emitting ill-sorted Why3. *) + (match tydecl.tyd_type with + | Datatype _ | Record _ + when not (List.is_empty tydecl.tyd_params.idxvars) -> + raise CanNotTranslate + | _ -> ()); + let ts, opts, decl = match tydecl.tyd_type with | Abstract -> @@ -415,7 +479,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 +498,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) = @@ -462,7 +526,6 @@ and trans_tydecl genv (p, tydecl) = List.iter (fun (p, wop) -> Hp.add genv.te_op p wop) opts; ts -(* -------------------------------------------------------------------- *) let trans_memtype ((genv, _) as env) mt = match EcMemory.local_type mt with | None -> ty_mem @@ -471,7 +534,66 @@ let trans_memtype ((genv, _) as env) mt = wty_tuple genv [ty; ty_mem] (* -------------------------------------------------------------------- *) -exception CanNotTranslate +(* The width observers of an indexed family, one per index position, + declared on first use. Polymorphic in the family's type parameters, + like the erased sort itself. *) +let size_syms (genv : tenv) (p : EcPath.path) : WTerm.lsymbol list = + match Hp.find_opt genv.te_size p with + | Some ls -> ls + | None -> + let tyd = EcEnv.Ty.by_path p genv.te_env in + let syms = + match tyd.tyd_params.idxvars with + | [] -> [] + | idxvars -> + let ts = trans_pty genv p in + let self = WTy.ty_app ts (List.map WTy.ty_var ts.WTy.ts_args) in + List.mapi (fun k _ -> + let name = Format.sprintf "size%d_%s" k (EcPath.basename p) in + let ls = + WTerm.create_lsymbol + (WIdent.id_fresh name) [self] (Some WTy.ty_int) in + genv.te_task <- + WTask.add_decl genv.te_task (WDecl.create_param_decl ls); + ls) + idxvars + in + Hp.add genv.te_size p syms; syms + +(* -------------------------------------------------------------------- *) +(* Does [ty] mention an indexed constructor anywhere? *) +let rec ty_mentions_indexed (env : EcEnv.env) (ty : ty) : bool = + let ty = EcEnv.ty_hnorm ty env in + match ty.ty_node with + | Tconstr (_, ta) -> + not (List.is_empty ta.indices) + || List.exists (ty_mentions_indexed env) ta.types + | _ -> EcTypes.ty_sub_exists (ty_mentions_indexed env) ty + +(* [`Guard (p, ta)]: [ty] is an indexed constructor at its head with + index-free type arguments -- relativizable through the width + observers. [`None]: no indexed constructor anywhere. [`Punt]: an + indexed constructor occurs where the observers cannot see it (under + another constructor, a tuple, an arrow, or as a type argument of an + indexed head); the erased translation of a binder at such a type is + not meaning-preserving and the caller must fall back. *) +let binder_index_status (env : EcEnv.env) (ty : ty) = + let ty = EcEnv.ty_hnorm ty env in + match ty.ty_node with + | Tconstr (p, ta) when not (List.is_empty ta.indices) -> + if List.exists (ty_mentions_indexed env) ta.types + then `Punt + else `Guard (p, ta) + | _ -> if ty_mentions_indexed env ty then `Punt else `None + +let tindex_closed (ti : tindex) : bool = + let rec go = function + | TIUnivar _ -> false + | TIVar _ | TIConst _ -> true + | TIAdd (a, b) | TIMul (a, b) -> go a && go b + in go ti + +(* -------------------------------------------------------------------- *) let trans_binding genv lenv (x, xty) = let lenv, wty = match xty with @@ -542,14 +664,18 @@ let rec highorder_type targs tres = let apply_highorder f args = List.fold_left (fun f a -> WTerm.t_func_app f (Cast.force_bool a)) f args -let apply_wop genv wop tys args = +let apply_wop genv ?(idx = []) wop tys args = let (textra, targs, tres) = wop.w3op_ta tys in + (* Index arguments (concrete int terms) are prepended ahead of the + phantom type-dictionary witnesses and the value arguments, matching + the [widx @ textra @ wdom] order of the operator's Why3 symbol. *) + let idx_targs = List.map (fun t -> t.WTerm.t_ty) idx in let eargs = - List.map w_witness textra in + idx @ List.map w_witness textra in let arity = List.length targs in let nargs = List.length args in - let targs = List.map some textra @ targs in + let targs = idx_targs @ List.map some textra @ targs in if nargs = arity then Cast.app (w3op_fo wop) (eargs @ args) targs tres else if nargs < arity then let fty = highorder_type targs tres in @@ -689,10 +815,32 @@ and trans_form ((genv, lenv) as env : tenv * lenv) (fp : form) = begin try let lenv, wbds = trans_bindings genv lenv bds in + (* Relativize binders at indexed types: [forall (x : t<:i>), P] + means "for x of width i", which the erased sort cannot say by + itself. Guards are exact (an equivalence, not an + approximation); inexpressible cases raise CanNotTranslate and + take the [trans_gen] fallback below. Lambdas assert nothing, + so they need no guard. *) + let guards = + match qt with + | Llambda -> [] + | Lforall | Lexists -> + List.flatten + (List.map2 (binder_guards (genv, lenv)) bds wbds) + in let wbody = trans_form (genv,lenv) body in + let close mk join = + let wbody = Cast.force_prop wbody in + let wbody = + match guards with + | [] -> wbody + | g :: gs -> join (List.fold_left WTerm.t_and g gs) wbody + in + mk wbds [] wbody + in (match qt with - | Lforall -> WTerm.t_forall_close wbds [] (Cast.force_prop wbody) - | Lexists -> WTerm.t_exists_close wbds [] (Cast.force_prop wbody) + | Lforall -> close WTerm.t_forall_close WTerm.t_implies + | Lexists -> close WTerm.t_exists_close WTerm.t_and | Llambda -> trans_lambda genv wbds wbody) with CanNotTranslate -> trans_gen env fp end @@ -706,7 +854,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) @@ -731,6 +879,31 @@ and trans_form ((genv, lenv) as env : tenv * lenv) (fp : form) = and trans_form_b env f = Cast.force_bool (trans_form env f) +(* The relativization guards of one quantifier binder: for a binder at + a head-indexed type, the equations [size_k x = i_k]. Raises + [CanNotTranslate] when an indexed constructor occurs where the width + observers cannot reach it, or when an index is not closed. *) +and binder_guards ((genv, _) as env : tenv * lenv) + ((_, xty) : EcIdent.t * gty) (wv : WTerm.vsymbol) : WTerm.term list += + match xty with + | GTty ty -> begin + match binder_index_status genv.te_env ty with + | `None -> [] + | `Punt -> raise CanNotTranslate + | `Guard (p, ta) -> + if not (List.for_all tindex_closed ta.indices) then + raise CanNotTranslate; + List.map2 + (fun ls ti -> + let widx = trans_form env (EcCoreFol.f_of_tindex ti) in + WTerm.t_equ + (WTerm.t_app_infer ls [WTerm.t_var wv]) + widx) + (size_syms genv p) ta.indices + end + | _ -> [] + (* -------------------------------------------------------------------- *) and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = match f.f_node with @@ -739,8 +912,17 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = | Fop (p, ts) -> let wop = trans_op genv p in - let tys = List.map (trans_ty (genv,lenv)) ts in - apply_wop genv wop tys args + (* Each index becomes an explicit leading [int] argument. Reuse the + form translator on the index-as-int form so that idxvars resolve + through the same [te_lc]/[le_lv] machinery as any int local. *) + (* Forms reaching the translation are CLOSED (goal contexts and + environment axioms are univar-free by construction since the + closing-API consolidation); a residual index univar here is + an internal invariant violation and [f_of_tindex] asserts. *) + let widx = + List.map (fun ti -> trans_form env (EcCoreFol.f_of_tindex ti)) ts.indices in + let tys = List.map (trans_ty (genv,lenv)) ts.types in + apply_wop genv ~idx:widx wop tys args | Flocal x when Hid.mem genv.te_lc x -> apply_wop genv (Hid.find genv.te_lc x) [] args @@ -791,7 +973,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 @@ -849,7 +1031,6 @@ 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 -(* -------------------------------------------------------------------- *) and trans_pvar ((genv, lenv) as env) pv ty mem = let pv = NormMp.norm_pvar genv.te_env pv in let mt = get_memtype lenv mem in @@ -1058,10 +1239,17 @@ and trans_fix (genv, lenv) (wdom, o) = (* -------------------------------------------------------------------- *) and create_op ?(body = false) (genv : tenv) p = let op = EcEnv.Op.by_path p genv.te_env in + (* Indexed operators take their indices as explicit leading [int] + arguments (one per idxvar). Applications supply the concrete index + terms; the symbol itself is index-agnostic, so [zerow<:5>] and + [zerow<:n>] share the symbol [zerow : int -> word] applied at [5] + resp. [n]. Plain bodies are exported as standard definitions over + those index parameters (see below); matchfix bodies stay opaque. *) + let widx = List.map (fun _ -> WTy.ty_int) op.op_tparams.idxvars in 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 @@ -1081,7 +1269,7 @@ and create_op ?(body = false) (genv : tenv) p = load_wtheory genv th; (true, ls) | None -> - let ls = WTerm.create_lsymbol (preid_p p) (textra@wdom) wcodom in + let ls = WTerm.create_lsymbol (preid_p p) (widx@textra@wdom) wcodom in (false, ls) in @@ -1090,11 +1278,11 @@ and create_op ?(body = false) (genv : tenv) p = let w3op_ho = if EcDecl.is_fix op then let ls, decl, decl_s = - mk_highorder_func name (textra@wdom) wcodom (WTerm.t_app ls) + mk_highorder_func name (widx@textra@wdom) wcodom (WTerm.t_app ls) in `HO_FIX (ls, decl, decl_s, ref false) else - `HO_TODO (name, textra@wdom, wcodom) in + `HO_TODO (name, widx@textra@wdom, wcodom) in { w3op_fo = `LDecl ls; w3op_ta = instantiate wparams ~textra wdom wcodom; @@ -1106,6 +1294,26 @@ and create_op ?(body = false) (genv : tenv) p = if not known then begin let wextra = List.map (fun ty -> WTerm.create_vsymbol (WIdent.id_fresh "_") ty) textra in + + (* Definitions of indexed operators are STANDARD Why3 definitions: + one bound [int] variable per idxvar, prepended to the parameter + list (matching [ls]'s domain), and registered in [le_lv] so that + both the body's [Flocal n] occurrences and its index positions + (which translate through [f_of_tindex]) resolve to it. A + definition is a conservative extension, so no [0 <= i] guard is + needed (unlike the axioms about opaque symbols below): the + intended model interprets the op at out-of-range indices by its + body. Matchfix bodies stay opaque at indexed ops (indexed + datatypes are not exported); untranslatable bodies fall back to + an opaque declaration instead of punting the goal. *) + let widx_params, body_lenv = + let mk lenv (id : EcIdent.t) = + let vs = WTerm.create_vsymbol (preid id) WTy.ty_int in + ({ lenv with le_lv = Mid.add id vs lenv.le_lv }, vs) + in + let body_lenv, vs = List.map_fold mk lenv op.op_tparams.idxvars in + vs, body_lenv in + let decl = let default () = WDecl.create_param_decl ls in @@ -1113,19 +1321,31 @@ and create_op ?(body = false) (genv : tenv) p = default () else match body, op.op_kind with - | true, OB_oper (Some (OP_Plain body)) -> - let wparams, wbody = trans_body (genv, lenv) wdom wcodom body in - WDecl.create_logic_decl [WDecl.make_ls_defn ls (wextra@wparams) wbody] + | true, OB_oper (Some (OP_Plain body)) -> begin + try + let wparams, wbody = + trans_body (genv, body_lenv) wdom wcodom body in + WDecl.create_logic_decl + [WDecl.make_ls_defn ls (widx_params@wextra@wparams) wbody] + with CanNotTranslate when not (List.is_empty widx) -> + default () + end - | true, OB_oper (Some (OP_Fix body)) -> + | true, OB_oper (Some (OP_Fix body)) when List.is_empty widx -> OneShot.now register; let wparams, wbody = trans_fix (genv, lenv) (wdom, body) in let wbody = Cast.arg wbody ls.WTerm.ls_value in WDecl.create_logic_decl [WDecl.make_ls_defn ls (wextra@wparams) wbody] - | true, OB_pred (Some (PR_Plain body)) -> - let wparams, wbody = trans_body (genv, lenv) wdom None body in - WDecl.create_logic_decl [WDecl.make_ls_defn ls (wextra@wparams) wbody] + | true, OB_pred (Some (PR_Plain body)) -> begin + try + let wparams, wbody = + trans_body (genv, body_lenv) wdom None body in + WDecl.create_logic_decl + [WDecl.make_ls_defn ls (widx_params@wextra@wparams) wbody] + with CanNotTranslate when not (List.is_empty widx) -> + default () + end | _, _ -> default () @@ -1151,13 +1371,79 @@ and create_op ?(body = false) (genv : tenv) p = genv.te_task <- WTask.add_decl genv.te_task decl end; + (* [f i>> x>> : t<:e(i)>]: record the result width, + [forall i>> x>>, 0 <= i => size_k (f i>> x>>) = e_k(i>>)]. Justified by + typing alone, so it holds for opaque operators too; the [0 <= i] + premises keep the union-of-widths model satisfiable at + out-of-range index arguments (EC types are inhabited, so every + carrier at a natural width is non-empty). *) + if not known then begin + match binder_index_status genv.te_env codom with + | `Guard (rp, rta) when List.for_all tindex_closed rta.indices -> begin + try + let idxvs = + List.map + (fun id -> WTerm.create_vsymbol (preid id) WTy.ty_int) + op.op_tparams.idxvars in + let lenv = + { lenv with le_lv = + List.fold_left2 (fun m id vs -> Mid.add id vs m) + lenv.le_lv op.op_tparams.idxvars idxvs } in + let phvs = + List.map + (fun ty -> WTerm.create_vsymbol (WIdent.id_fresh "_") ty) + textra in + let argvs = + List.map + (fun ty -> WTerm.create_vsymbol (WIdent.id_fresh "x") ty) + wdom in + let allvs = idxvs @ phvs @ argvs in + let wapp = WTerm.t_app_infer ls (List.map WTerm.t_var allvs) in + let weqs = + List.map2 + (fun szls ti -> + WTerm.t_equ + (WTerm.t_app_infer szls [wapp]) + (trans_form (genv, lenv) (EcCoreFol.f_of_tindex ti))) + (size_syms genv rp) rta.indices in + let wpre = + List.map (fun v -> w3_ge0 genv (WTerm.t_var v)) idxvs in + let wconc = + match weqs with + | w :: ws -> List.fold_left WTerm.t_and w ws + | [] -> assert false in + let wbody = + match wpre with + | [] -> wconc + | w :: ws -> + WTerm.t_implies (List.fold_left WTerm.t_and w ws) wconc in + let wax = WTerm.t_forall_close allvs [] wbody in + let pr = + WDecl.create_prsymbol + (WIdent.id_fresh (ls.WTerm.ls_name.WIdent.id_string ^ "_size")) in + genv.te_task <- + WTask.add_decl genv.te_task + (WDecl.create_prop_decl WDecl.Paxiom pr wax) + with CanNotTranslate -> () + end + | _ -> () + end; + w3op (* -------------------------------------------------------------------- *) -let add_axiom ((genv, _) as env) preid form = +let add_axiom ?(qvars = []) ((genv, _) as env) preid form = let w = trans_form env form in + let w = Cast.force_prop w in + (* [qvars] are idxvar quantifications: they range over the NATURALS + (EC never proved anything at a negative index). *) + let w = + match List.map (fun v -> w3_ge0 genv (WTerm.t_var v)) qvars with + | [] -> w + | g :: gs -> WTerm.t_implies (List.fold_left WTerm.t_and g gs) w in + let w = WTerm.t_forall_close qvars [] w in let pr = WDecl.create_prsymbol preid in - let decl = WDecl.create_prop_decl WDecl.Paxiom pr (Cast.force_prop w) in + let decl = WDecl.create_prop_decl WDecl.Paxiom pr w in genv.te_task <- WTask.add_decl genv.te_task decl (* -------------------------------------------------------------------- *) @@ -1189,6 +1475,34 @@ let trans_hyp ((genv, lenv) as env) (x, ty) = in genv.te_task <- WTask.add_decl genv.te_task decl; Hid.add genv.te_lc x w3op; + (* A constant local at a head-indexed type carries its width as a + fact: [size_k x = i_k]. (Function-typed locals into indexed + types get no fact -- a completeness gap, not a soundness one.) *) + (match dom with + | [] -> begin + match binder_index_status genv.te_env codom with + | `Guard (p, ta) when List.for_all tindex_closed ta.indices -> + List.iter2 + (fun szls ti -> + try + let widx = + trans_form env (EcCoreFol.f_of_tindex ti) in + let wfact = + WTerm.t_equ + (WTerm.t_app_infer szls + [WTerm.t_app_infer ls []]) + widx in + let pr = + WDecl.create_prsymbol + (WIdent.id_fresh (EcIdent.name x ^ "_size")) in + genv.te_task <- + WTask.add_decl genv.te_task + (WDecl.create_prop_decl WDecl.Paxiom pr wfact) + with CanNotTranslate -> ()) + (size_syms genv p) ta.indices + | _ -> () + end + | _ -> ()); env | LD_hyp f -> @@ -1224,7 +1538,18 @@ let lenv_of_hyps genv (hyps : hyps) : lenv = let trans_axiom genv (p, ax) = (* if not ax.ax_nosmt then *) let lenv = fst (lenv_of_tparams ax.ax_tparams) in - add_axiom (genv, lenv) (preid_p p) ax.ax_spec + (* A polymorphic lemma's idxvars are int-valued: bind each to a fresh + Why3 int variable and universally quantify the emitted axiom over + them (type variables are handled by Why3's own type polymorphism; + int indices need explicit quantification). *) + let idx_vs = + List.map (fun id -> WTerm.create_vsymbol (preid id) WTy.ty_int) + ax.ax_tparams.idxvars in + let lenv = + { lenv with le_lv = + List.fold_left2 (fun m id vs -> Mid.add id vs m) + lenv.le_lv ax.ax_tparams.idxvars idx_vs } in + add_axiom ~qvars:idx_vs (genv, lenv) (preid_p p) ax.ax_spec (* -------------------------------------------------------------------- *) let mk_predb1 f l _ = f (Cast.force_prop (as_seq1 l)) @@ -1690,7 +2015,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 @@ -1704,7 +2041,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 = diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 6dbf75ad4..9c15d0c41 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -28,10 +28,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 *) } @@ -41,6 +47,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; @@ -53,6 +60,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 @@ -150,6 +158,38 @@ 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 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 -> + 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 + | TIUnivar _ -> ti + | 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) = match ty.ty_node with @@ -163,17 +203,23 @@ 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 - - | Some (args, body) -> - let s = List.fold_left2 add_tyvar empty args tys in + tconstr_r (subst_path s p) ta + + | 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 @@ -181,8 +227,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) = @@ -272,9 +320,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); @@ -332,24 +380,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 @@ -365,8 +413,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 @@ -514,24 +567,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 @@ -618,8 +671,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 @@ -834,14 +892,27 @@ 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_idxparam (s : subst) (x : EcIdent.t) = + let newx = EcIdent.fresh x in + (* both namespaces: tindex positions AND int-typed formula-local + occurrences (renaming only one dangles the other) *) + let s = { s with + sb_idxvar = Mid.add x (TIVar newx) s.sb_idxvar; + sb_flocal = + Mid.add x (EcCoreFol.f_local newx EcTypes.tint) s.sb_flocal; } in + (s, newx) + (* -------------------------------------------------------------------- *) let fresh_tparams (s : subst) (tparams : ty_params) = - List.fold_left_map fresh_tparam s tparams + 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) = @@ -994,29 +1065,11 @@ let fresh_scparams (s : subst) (xtys : (EcIdent.t * ty) list) = (* -------------------------------------------------------------------- *) let subst_ring (s : subst) cr = - { r_name = cr.r_name; - r_type = subst_ty s cr.r_type; - r_zero = subst_path s cr.r_zero; - r_one = subst_path s cr.r_one; - r_add = subst_path s cr.r_add; - r_opp = omap (subst_path s) cr.r_opp; - r_mul = subst_path s cr.r_mul; - r_exp = omap (subst_path s) cr.r_exp; - r_sub = omap (subst_path s) cr.r_sub; - r_embed = - begin match cr.r_embed with - | `Direct -> `Direct - | `Default -> `Default - | `Embed p -> `Embed (subst_path s p) - end; - r_kind = cr.r_kind - } + EcDecl.ring_map (subst_path s) (subst_ty s) (subst_tindex s) cr (* -------------------------------------------------------------------- *) let subst_field (s : subst) cr = - { f_ring = subst_ring s cr.f_ring; - f_inv = subst_path s cr.f_inv; - f_div = omap (subst_path s) cr.f_div; } + EcDecl.field_map (subst_path s) (subst_ty s) (subst_tindex s) cr (* -------------------------------------------------------------------- *) let subst_instance (s : subst) tci = @@ -1152,7 +1205,7 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin (* -------------------------------------------------------------------- *) let subst_exception (s : subst) (ex : exception_) = { exn_loca = ex.exn_loca; - exn_dom = subst_tys s ex.exn_dom } + exn_dom = List.map (subst_ty s) ex.exn_dom } (* -------------------------------------------------------------------- *) (* SUBSTITUTION OVER THEORIES *) @@ -1243,13 +1296,21 @@ let init_tparams (params : (EcIdent.t * ty) list) : subst = List.fold_left (fun s (x, ty) -> add_tyvar s x ty) empty params (* -------------------------------------------------------------------- *) -let open_oper op tys = - let s = List.combine op.op_tparams tys in +let open_oper ?(indices : tindex list = []) op tys = + let s = List.combine op.op_tparams.tyvars tys in let s = init_tparams s in + (* Empty [indices] leaves the operator's idxvars in place (the + index-free callers' historical behaviour). *) + let s = + if List.is_empty indices then s else + List.fold_left2 + (fun s x ti -> { s with sb_idxvar = Mid.add x ti s.sb_idxvar }) + s op.op_tparams.idxvars indices + 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/ecSubst.mli b/src/ecSubst.mli index 64ae60cf0..aa6977e76 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 *) @@ -68,8 +68,9 @@ val subst_oracle_infos : subst -> oracle_infos -> oracle_infos (* -------------------------------------------------------------------- *) val subst_gty : subst -> gty -> gty val subst_genty : subst -> (ty_params * ty) -> (ty_params * ty) -val subst_ty : subst -> ty -> ty -val subst_form : subst -> form -> form +val subst_ty : subst -> ty -> ty +val subst_tindex : subst -> tindex -> tindex +val subst_form : subst -> form -> form val subst_expr : subst -> expr -> expr val subst_stmt : subst -> stmt -> stmt @@ -86,7 +87,7 @@ val subst_bv_opkind : ?red:(form -> int option) -> subst -> bv_opkind -> bv_opki val subst_binding_size : ?red:(form -> int option) -> subst -> binding_size -> binding_size (* -------------------------------------------------------------------- *) -val open_oper : operator -> ty list -> ty * operator_kind +val open_oper : ?indices:EcAst.tindex list -> operator -> ty list -> ty * operator_kind val open_tydecl : tydecl -> ty list -> ty_body (* -------------------------------------------------------------------- *) diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 813556710..f92b725df 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -12,6 +12,7 @@ module Mp = EcPath.Mp (* ------------------------------------------------------------------ *) type incompatible = | NotSameNumberOfTyParam of int * int +| NotSameNumberOfIdxParam of int * int | DifferentType of EcTypes.ty * EcTypes.ty | OpBody (* of (EcPath.path * EcDecl.operator) * (EcPath.path * EcDecl.operator) *) | TyBody (* of (EcPath.path * EcDecl.tydecl) * (EcPath.path * EcDecl.tydecl) *) @@ -42,6 +43,9 @@ 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_NoExceptions exception CloneError of EcEnv.env * clone_error @@ -63,7 +67,7 @@ type xty_override = (* ------------------------------------------------------------------ *) type xop_override = [ | op_override_def genoverride - | `Direct of EcDecl.ty_params * EcAst.form + | `Direct of EcIdent.t list * EcAst.form ] * clmode (* ------------------------------------------------------------------ *) @@ -317,10 +321,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 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 @@ -329,7 +336,9 @@ 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.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 let evc = diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli index 4e7a8414a..c043869da 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -6,6 +6,7 @@ open EcParsetree (* -------------------------------------------------------------------- *) type incompatible = | NotSameNumberOfTyParam of int * int +| NotSameNumberOfIdxParam of int * int | DifferentType of EcTypes.ty * EcTypes.ty | OpBody (* of (EcPath.path * EcDecl.operator) * (EcPath.path * EcDecl.operator) *) | TyBody (* of (EcPath.path * EcDecl.tydecl) * (EcPath.path * EcDecl.tydecl) *) @@ -36,6 +37,7 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IdxArgMism of ovkind * qsymbol | CE_NoExceptions exception CloneError of EcEnv.env * clone_error @@ -49,7 +51,7 @@ type xty_override = (* ------------------------------------------------------------------ *) type xop_override = [ | op_override_def genoverride - | `Direct of EcDecl.ty_params * EcAst.form + | `Direct of EcIdent.t list * EcAst.form ] * clmode (* ------------------------------------------------------------------ *) diff --git a/src/ecTheory.ml b/src/ecTheory.ml index e4e5125da..e475ef3fe 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -54,7 +54,10 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * EcTypes.ty list) | `Tuple | `Proj of int] + (* Op patterns carry the head's index arguments (normalized). + Compilation restricts each to the affine fragment: a constant, + a rule idxvar [k], or [b + k]; see EcReduction.User. *) + [`Op of (EcPath.path * EcAst.tindex list * EcTypes.ty list) | `Tuple | `Proj of int] and rule = { rl_tyd : EcDecl.ty_params; diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 4305ad157..913dc92eb 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -51,7 +51,7 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * EcTypes.ty list) | `Tuple | `Proj of int] + [`Op of (EcPath.path * EcAst.tindex list * EcTypes.ty list) | `Tuple | `Proj of int] and rule = { rl_tyd : EcDecl.ty_params; diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 380bc501d..cedb74179 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -65,17 +65,17 @@ exception CoreIncompatible exception NoException (* -------------------------------------------------------------------- *) -let get_open_oper (env : EcEnv.env) (p : EcPath.path) (tys : ty list) = +let get_open_oper (env : EcEnv.env) (p : EcPath.path) (tys : targs) = let oper = EcEnv.Op.by_path p env in - let _, okind = EcSubst.open_oper oper tys in + let _, okind = EcSubst.open_oper ~indices:tys.indices oper tys.types in match okind with | OB_oper (Some ob) -> ob | _ -> raise CoreIncompatible (* -------------------------------------------------------------------- *) -let get_open_pred (env : EcEnv.env) (p : EcPath.path) (tys : ty list) = +let get_open_pred (env : EcEnv.env) (p : EcPath.path) (tys : targs) = let oper = EcEnv.Op.by_path p env in - let _, okind = EcSubst.open_oper oper tys in + let _, okind = EcSubst.open_oper ~indices:tys.indices oper tys.types in match okind with | OB_pred (Some pb) -> pb | _ -> raise CoreIncompatible @@ -87,8 +87,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 @@ -104,12 +104,18 @@ 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))) + raise (Incompatible (NotSameNumberOfTyParam (rlen, nlen))); + + let rilen = List.length rtp.idxvars + and nilen = List.length ntp.idxvars in + + if rilen <> nilen then + raise (Incompatible (NotSameNumberOfIdxParam (rilen, nilen))) let for_params (hyps : hyps) @@ -127,8 +133,16 @@ 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 rty = CS.Tvar.subst subst rty in + (* Rename the reference declaration's parameters -- type variables + AND index variables -- to the override's, then unify. *) + let fs = + CS.f_subst_init + ~tv:(CS.Tvar.init rtyvars.tyvars (List.map tvar ntyvars.tyvars)) + ~idx:(EcIdent.Mid.of_list + (List.combine rtyvars.idxvars + (List.map (fun id -> TIVar id) ntyvars.idxvars))) + () in + let rty = CS.ty_subst fs rty in try EcUnify.unify env ue rty nty with EcUnify.UnificationFailure _ -> @@ -169,11 +183,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 @@ -184,11 +198,11 @@ 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 - let subtype1 = CS.Tvar.sty_subst ~freshen:false tyd1.tyd_params tparams tyd1.tyd_subtype in - let subtype2 = CS.Tvar.sty_subst ~freshen:false tyd2.tyd_params tparams tyd2.tyd_subtype in + let subtype1 = CS.Tvar.sty_subst ~freshen:false tyd1.tyd_params.tyvars tparams tyd1.tyd_subtype in + let subtype2 = CS.Tvar.sty_subst ~freshen:false tyd2.tyd_params.tyvars tparams tyd2.tyd_subtype in let hyps = EcEnv.LDecl.init env params in @@ -242,7 +256,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 @@ -314,8 +328,9 @@ 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 oty2, okind2 = EcSubst.open_oper oper2 tparams in + let tparams = List.map tvar params.tyvars in + let tindices = List.map (fun id -> TIVar id) params.idxvars in + let oty2, okind2 = EcSubst.open_oper ~indices:tindices oper2 tparams in if not (EcReduction.EqTest.for_type env oty1 oty2) then raise (Incompatible (DifferentType(oty1, oty2))); @@ -459,19 +474,70 @@ let for_op_path (* -------------------------------------------------------------------- *) let for_op_path subst ~opath ~ops p = odfl p (for_op_path subst ~opath ~ops p) + +(* -------------------------------------------------------------------- *) +(* Map a ring/field slot through the clone overrides. An inlined + override ([op zeror <- zerow[:n+1]]) carries the body's own + instantiation: record it, composed with the slot's recorded one + (expressed over the overridden op's formals). *) +let for_ring_op + (subst : EcSubst.subst) + ~(opath : EcPath.path) + ~(ops : _ Mp.t) + (o : EcDecl.ring_op) += + let dflt () = + { EcDecl.ro_op = EcSubst.subst_path subst o.EcDecl.ro_op; + ro_idxs = List.map (EcSubst.subst_tindex subst) o.EcDecl.ro_idxs; + ro_tys = List.map (EcSubst.subst_ty subst) o.EcDecl.ro_tys; } in + match + EcPath.remprefix ~prefix:opath ~path:o.EcDecl.ro_op |> omap List.rev + with + | None | Some [] -> dflt () + | Some (x :: px) -> + let q = EcPath.fromqsymbol (List.rev px, x) in + + match Mp.find_opt q ops with + | None -> dflt () + | Some (op, alias) -> + if alias then dflt () else + + match op.EcDecl.op_kind with + | OB_oper (Some (OP_Plain f)) -> begin + match f.f_node with + | Fop (r, ta) -> + let ro_idxs = + List.map (EcSubst.subst_tindex subst) o.EcDecl.ro_idxs in + let ro_tys = + List.map (EcSubst.subst_ty subst) o.EcDecl.ro_tys in + let fs = + EcCoreSubst.Fsubst.f_subst_init ~freshen:false + ~tv:(EcIdent.Mid.of_list + (List.combine op.EcDecl.op_tparams.tyvars ro_tys)) + ~idx:(EcIdent.Mid.of_list + (List.combine op.EcDecl.op_tparams.idxvars ro_idxs)) + () in + { EcDecl.ro_op = r; + ro_idxs = + List.map (EcCoreSubst.tindex_subst fs) ta.EcAst.indices; + ro_tys = + List.map (EcCoreSubst.ty_subst fs) ta.EcAst.types; } + | _ -> raise InvInstPath + end + | _ -> dflt () (* -------------------------------------------------------------------- *) let for_ty_path (subst : EcSubst.subst) ?(nargs = 0) (p : EcPath.path) = let tyargs = List.init nargs (fun _ -> tvar (EcIdent.create "_")) in - match (EcSubst.subst_ty subst (tconstr p tyargs)).ty_node with - | Tconstr (p, tyargs') when List.equal ty_equal tyargs tyargs' -> p + match (EcSubst.subst_ty subst (tconstr ~tyargs p)).ty_node with + | Tconstr (p, tyargs') when List.equal ty_equal tyargs tyargs'.types -> p | _ -> raise InvInstPath (* -------------------------------------------------------------------- *) let for_ty_path (env : EcEnv.env) (subst : EcSubst.subst) (p : EcPath.path) = let env = EcEnv.Theory.env_of_theory (oget (EcPath.prefix p)) env in - let nargs = List.length ((EcEnv.Ty.by_path p env).tyd_params) in + let nargs = List.length ((EcEnv.Ty.by_path p env).tyd_params.tyvars) in for_ty_path subst ~nargs p (* -------------------------------------------------------------------- *) @@ -488,20 +554,21 @@ 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 ue = EcUnify.UniEnv.create (Some 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 subtype = match ntyd.ty_node with | Tconstr (p, tys) -> let reftyd = EcEnv.Ty.by_path p env in - CS.Tvar.sty_subst ~freshen:false reftyd.tyd_params tys reftyd.tyd_subtype + CS.Tvar.sty_subst ~freshen:false reftyd.tyd_params.tyvars tys.types reftyd.tyd_subtype | _ -> None in let decl = - { tyd_params = nargs; + { tyd_params = nargs_p; tyd_type = Concrete ntyd; tyd_loca = otyd.tyd_loca; tyd_clinline = (mode <> `Alias); @@ -518,8 +585,8 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | Concrete body -> body | _ -> assert false) else - let tyargs = List.map tvar reftyd.tyd_params in - tconstr p tyargs in + let tyargs = List.map tvar reftyd.tyd_params.tyvars in + tconstr ~tyargs p in let decl = { reftyd with tyd_type = Concrete body; @@ -530,10 +597,11 @@ 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); assert (otyd.tyd_subtype = None); let decl = - { tyd_params = []; + { tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Concrete ty; tyd_loca = otyd.tyd_loca; tyd_clinline = (mode <> `Alias); @@ -550,7 +618,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, body) in + subst (xpath ove x) + (newtyd.tyd_params.idxvars, + newtyd.tyd_params.tyvars, body) in (subst, x) in let subst = @@ -563,10 +633,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 @@ -576,7 +646,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 @@ -626,13 +696,13 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = let bypath (p : EcPath.path) = 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)); @@ -651,7 +721,10 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = match opov with | `BySyntax opov -> let tp = opov.opov_tyvars in - let ue = EcTyping.transtyvars env (loc, tp) in + let ue = + EcTyping.transtyvars + ~idxparams:opov.opov_idxvars env (loc, tp) in + let env = EcTyping.bind_idx_locals env ue in let tp = EcTyping.tp_relax in let (ty, body) = let codom = EcTyping.transty tp env ue opov.opov_retty in @@ -669,10 +742,16 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = end; if not (EcUnify.UniEnv.closed ue) then - ove.ovre_hooks.herr - ~loc "this operator body contains free type variables"; - - let sty = CS.Tuni.subst (EcUnify.UniEnv.close ue) in + if EcUnify.UniEnv.closed_tv ue then + ove.ovre_hooks.herr + ~loc "cannot infer all index parameters in this \ + operator body; supply them explicitly \ + (e.g. `f[:n = 3]')" + else + ove.ovre_hooks.herr + ~loc "this operator body contains free type variables"; + + let sty = EcUnify.UniEnv.close_subst ue in let body = EcFol.Fsubst.f_subst sty body in let ty = CS.ty_subst sty ty in let tparams = EcUnify.UniEnv.tparams ue in @@ -686,15 +765,16 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = bypath p | `Direct (tps, { f_node = Fop (p, tys) }) - when List.for_all2 ty_equal (List.map tvar tps) tys -> + when List.for_all2 ty_equal (List.map tvar tps) tys.types -> bypath p | `Direct (tparams, body) -> - assert (List.compare_lengths tparams refop.op_tparams = 0); + assert (List.compare_lengths tparams refop.op_tparams.tyvars = 0 + && 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 @@ -710,7 +790,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 @@ -764,7 +844,10 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = match prov with | `BySyntax prov -> let tp = prov.prov_tyvars in - let ue = EcTyping.transtyvars env (loc, tp) in + let ue = + EcTyping.transtyvars + ~idxparams:prov.prov_idxvars env (loc, tp) in + let env = EcTyping.bind_idx_locals env ue in let body = let env, xs = EcTyping.trans_binding env ue prov.prov_args in let body = EcTyping.trans_form_opt env ue prov.prov_body None in @@ -784,10 +867,16 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = end; if not (EcUnify.UniEnv.closed ue) then - ove.ovre_hooks.herr - ~loc "this predicate body contains free type variables"; + if EcUnify.UniEnv.closed_tv ue then + ove.ovre_hooks.herr + ~loc "cannot infer all index parameters in this \ + predicate body; supply them explicitly \ + (e.g. `f[:n = 3]')" + else + ove.ovre_hooks.herr + ~loc "this predicate body contains free type variables"; - let fs = CS.Tuni.subst (EcUnify.UniEnv.close ue) in + let fs = EcUnify.UniEnv.close_subst ue in let body = EcFol.Fsubst.f_subst fs body in let tparams = EcUnify.UniEnv.tparams ue in let newpr = @@ -803,13 +892,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)); @@ -820,9 +909,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; @@ -838,7 +928,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) @@ -1056,28 +1146,43 @@ and replay_instance try let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in let tc = - let rec doring cr = - { r_name = cr.r_name; - r_type = EcSubst.subst_ty subst cr.r_type; - r_zero = forpath cr.r_zero; - r_one = forpath cr.r_one; - r_add = forpath cr.r_add; - r_opp = cr.r_opp |> omap forpath; - r_mul = forpath cr.r_mul; - r_exp = cr.r_exp |> omap forpath; - r_sub = cr.r_sub |> omap forpath; + let foro = for_ring_op subst ~opath ~ops in + let doring cr = + { EcDecl.r_name = cr.EcDecl.r_name; + r_type = EcSubst.subst_ty subst cr.EcDecl.r_type; + r_zero = foro cr.EcDecl.r_zero; + r_one = foro cr.EcDecl.r_one; + r_add = foro cr.EcDecl.r_add; + r_opp = omap foro cr.EcDecl.r_opp; + r_mul = foro cr.EcDecl.r_mul; + r_exp = omap foro cr.EcDecl.r_exp; + r_sub = omap foro cr.EcDecl.r_sub; r_embed = - begin match cr.r_embed with - | `Direct -> `Direct - | `Default -> `Default - | `Embed p -> `Embed (forpath p) - end; - r_kind = cr.r_kind; } - + (match cr.EcDecl.r_embed with + | `Direct -> `Direct + | `Default -> `Default + | `Embed o -> `Embed (foro o)); + r_kind = cr.EcDecl.r_kind; } and dofield cr = - { f_ring = doring cr.f_ring; - f_inv = forpath cr.f_inv; - f_div = cr.f_div |> omap forpath; } + let doring cr = + { EcDecl.r_name = cr.EcDecl.r_name; + r_type = EcSubst.subst_ty subst cr.EcDecl.r_type; + r_zero = foro cr.EcDecl.r_zero; + r_one = foro cr.EcDecl.r_one; + r_add = foro cr.EcDecl.r_add; + r_opp = omap foro cr.EcDecl.r_opp; + r_mul = foro cr.EcDecl.r_mul; + r_exp = omap foro cr.EcDecl.r_exp; + r_sub = omap foro cr.EcDecl.r_sub; + r_embed = + (match cr.EcDecl.r_embed with + | `Direct -> `Direct + | `Default -> `Default + | `Embed o -> `Embed (foro o)); + r_kind = cr.EcDecl.r_kind; } in + { EcDecl.f_ring = doring cr.EcDecl.f_ring; + f_inv = foro cr.EcDecl.f_inv; + f_div = omap foro cr.EcDecl.f_div; } in match tc with | `Ring cr -> `Ring (doring cr) @@ -1094,7 +1199,7 @@ and replay_instance (* -------------------------------------------------------------------- *) and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, bs, lc) = let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in let opath = ove.ovre_opath in let oppath = for_op_path subst ~opath ~ops in @@ -1147,7 +1252,7 @@ and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, b (* -------------------------------------------------------------------- *) and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, lc) = let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in let opath = ove.ovre_opath in let oppath = for_op_path subst ~opath ~ops in @@ -1200,7 +1305,7 @@ and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, l (* -------------------------------------------------------------------- *) and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, op, lc) = let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in let opath = ove.ovre_opath in let oppath = for_op_path subst ~opath ~ops in diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 81ddae67c..72758b299 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,25 @@ 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 + + | TIUnivar u -> + Format.sprintf "?#%d" u + + | 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,34 +72,49 @@ 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 texn = tconstr EcCoreLib.CI_Exn .p_exn [] -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 texn = tconstr EcCoreLib.CI_Exn .p_exn +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 @@ -111,7 +148,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 @@ -125,11 +162,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) @@ -138,21 +177,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 @@ -351,13 +390,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 @@ -398,11 +458,12 @@ 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 let e_not e = - e_app (e_op EcCoreLib.CI_Bool.p_not [] tbool) [e] tbool + e_app (e_op EcCoreLib.CI_Bool.p_not tbool) [e] tbool (* -------------------------------------------------------------------- *) module Reals : sig @@ -444,14 +505,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 (* -------------------------------------------------------------------- *) @@ -459,25 +519,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 880b9bc47..d0421c6f6 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 -> ?types: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 @@ -23,17 +29,19 @@ 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 -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 : ?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 +val tpred : ty -> ty val ty_fv_and_tvar : ty -> int Mid.t @@ -178,7 +186,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_not : expr -> expr val e_let : lpattern -> expr -> expr -> expr diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index c6e638cd0..478dc8c52 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -33,12 +33,12 @@ let f_op_app if not (UE.closed ue) then assert false; - let subst = EcCoreSubst.Tuni.subst (UE.assubst ue) in + let subst = UE.as_subst ue in let rty = EcCoreSubst.ty_subst subst rty in let opty = EcCoreSubst.ty_subst subst opty in let tvars = List.map (EcCoreSubst.ty_subst subst) tvars in - f_app (f_op op tvars opty) args rty + f_app (f_op op ~tyargs:tvars opty) args rty (* -------------------------------------------------------------------- *) let f_app diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 1be5f098c..d599ccfbb 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 @@ -135,6 +135,7 @@ type appcand = [ type tyerror = | UniVarNotAllowed | FreeTypeVariables +| FreeIndexVariables | TypeVarNotAllowed | OnlyMonoTypeAllowed of symbol option | NoConcreteAnonParams @@ -152,7 +153,13 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol +| NegativeIndexLiteral of EcBigInt.zint +| IndexMismatch of tindex * tindex | DuplicatedTyVar +| DuplicatedIndexVar of symbol +| TypeHasNoIndexParam of qsymbol * symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | DuplicatedException of qsymbol @@ -223,10 +230,13 @@ let unify_or_fail (env : EcEnv.env) ue loc ~expct:ty1 ty2 = with EcUnify.UnificationFailure pb -> match pb with | `TyUni (t1, t2)-> - let uidmap = UE.assubst ue in - let tyinst = ty_subst (Tuni.subst uidmap) in + let tyinst = ty_subst (UE.as_subst ue) in tyerror loc env (TypeMismatch ((tyinst ty1, tyinst ty2), (tyinst t1, tyinst t2))) + | `IxUni (i1, i2) -> + let i1 = EcUnify.UniEnv.repr_tindex ue i1 in + let i2 = EcUnify.UniEnv.repr_tindex ue i2 in + tyerror loc env (IndexMismatch (i1, i2)) (* -------------------------------------------------------------------- *) let add_glob (m:Sx.t) (x:prog_var) : Sx.t = @@ -354,7 +364,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 ] @@ -398,13 +408,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 @@ -492,7 +502,7 @@ let select_proj env opsc name ue tvi recty = (* When the record type is known, resolve the projector from the type so it need not be in scope by name; fall back to a name-based search otherwise. *) - let ty = ty_subst (Tuni.subst (UE.assubst ue)) recty in + let ty = ty_subst (UE.as_subst ue) recty in let ops = match (EcEnv.ty_hnorm ty env).ty_node with | Tconstr (tp, _) -> begin @@ -501,11 +511,12 @@ let select_proj env opsc name ue tvi recty = | Some op when EcDecl.is_proj op && EcPath.p_equal tp (proj3_1 (EcDecl.operator_as_proj op)) -> let subue = EcUnify.UniEnv.copy ue in - let top, tvs = - EcUnify.UniEnv.openty subue op.op_tparams tvi op.op_ty in + let tip, ixs, tvs = + EcUnify.UniEnv.openty_r subue op.op_tparams tvi in + let top = ty_subst tip op.op_ty in (try EcUnify.unify env subue top (EcUnify.tfun_expected subue [recty]) with EcUnify.UnificationFailure _ -> assert false); - [((projp, tvs), top, subue)] + [((projp, ixs, tvs), top, subue)] | _ -> do_select name end | _ -> do_select name @@ -514,7 +525,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 @@ -554,15 +565,49 @@ 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; - 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 + +(* 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 @@ -1075,30 +1120,70 @@ 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 [] + 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 in + let nargs = List.length tyargs in + let expected = List.length tydecl.tyd_params.tyvars in + let expected_ix = List.length tydecl.tyd_params.idxvars 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 + let indices = + match idxargs with + | IXunamed ixs -> + let nidx = List.length ixs in + if nidx <> expected_ix then + tyerror ty.pl_loc env (InvalidIndexAppl (name, expected_ix, nidx)); + List.map (transtindex env ue) ixs + + | IXnamed ixs -> + (* Named instantiation, mirroring the op-site `f[:n = 3]` + form: any order, partial (missing indices get a fresh + univar, like the `_` hole). *) + let inames = + List.map EcIdent.name tydecl.tyd_params.idxvars in + List.iter (fun (x, _) -> + if not (List.mem (unloc x) inames) then + tyerror x.pl_loc env + (TypeHasNoIndexParam (name, unloc x))) + ixs; + let rec dup = function + | [] -> () + | (x, _) :: r -> + if List.exists (fun (y, _) -> unloc x = unloc y) r then + tyerror x.pl_loc env (DuplicatedIndexVar (unloc x)); + dup r + in + dup ixs; + let ixs = List.map (fun (x, pi) -> unloc x, pi) ixs in + List.map (fun v -> + match List.assoc_opt (EcIdent.name v) ixs with + | Some pi -> transtindex env ue pi + | None -> EcUnify.UniEnv.idx_fresh ue) + tydecl.tyd_params.idxvars + in + tconstr ~indices ~tyargs p end | PTglob gp -> let mo,_ = trans_msymbol env gp in @@ -1107,8 +1192,39 @@ 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 -> + (* Fall back to a section-declared index (rigid, never a univar). *) + begin match EcEnv.lookup_declared_index name env with + | Some id -> TIVar id + | None -> tyerror loc env (UnboundIndexVariable name) + end + end + | PIint n -> + (* Lexer only produces non-negative UINTs, but defensively. *) + if EcBigInt.sign n < 0 then + tyerror pi.pl_loc env (NegativeIndexLiteral n); + 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) + | 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 []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in transty tp_nothing env ue ty (* -------------------------------------------------------------------- *) @@ -1142,7 +1258,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; @@ -1160,8 +1276,15 @@ 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, rectvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty 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 + (* One opening for the whole pattern: field types must share the + record instance's index/type univars. *) + let tip, _, _ = EcUnify.UniEnv.openty_r ue recty.tyd_params None in + let reccty = ty_subst tip reccty in let fields = List.fold_left (fun map (((_, idx), _, _) as field) -> @@ -1179,14 +1302,10 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = match Mint.find_opt i fields with | None -> let pty = EcUnify.UniEnv.fresh ue in - let fty = snd (List.nth rec_ i) in - let fty, _ = - EcUnify.UniEnv.openty ue recty.tyd_params - (Some (EcUnify.TVIunamed rectvi)) fty - in - (try EcUnify.unify env ue pty fty - with EcUnify.UnificationFailure _ -> assert false); - (None, pty) + let fty = ty_subst tip (snd (List.nth rec_ i)) in + (try EcUnify.unify env ue pty fty + with EcUnify.UnificationFailure _ -> assert false); + (None, pty) | Some (_, opty, (_, v)) -> let pty = EcUnify.UniEnv.fresh ue in @@ -1213,11 +1332,27 @@ let transpattern env ue (p : EcParsetree.plpattern) = (* -------------------------------------------------------------------- *) let transtvi env ue tvi = + let transix = function + | IXunamed ix -> + EcUnify.IXunamed (List.map (transtindex env ue) ix) + + | IXnamed ix -> + let add locals (s, i) = + if List.exists (fun (s', _) -> unloc s = unloc s') locals then + tyerror tvi.pl_loc env (DuplicatedIndexVar (unloc s)); + (s, transtindex env ue i) :: locals + in + let ix = List.fold_left add [] ix in + EcUnify.IXnamed (List.rev_map (fun (s, i) -> unloc s, i) ix) + in + match tvi.pl_desc with - | TVIunamed lt -> - EcUnify.TVIunamed (List.map (transty tp_relax env ue) lt) + | TVIunamed (ix, lt) -> + EcUnify.TVIunamed + ( transix ix + , List.map (transty tp_relax env ue) lt ) - | TVInamed lst -> + | TVInamed (ix, lst) -> let add locals (s, t) = if List.exists (fun (s', _) -> unloc s = unloc s') locals then tyerror tvi.pl_loc env DuplicatedTyVar; @@ -1225,7 +1360,9 @@ let transtvi env ue tvi = in let lst = List.fold_left add [] lst in - EcUnify.TVInamed (List.rev_map (fun (s,t) -> unloc s, t) lst) + EcUnify.TVInamed + ( transix ix + , List.rev_map (fun (s,t) -> unloc s, t) lst ) let rec destr_tfun env ue tf = match tf.ty_node with @@ -1282,7 +1419,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; @@ -1300,9 +1437,12 @@ 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, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let tysopn = Tvar.init recty.tyd_params rtvi 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 tip, rixs, rtvi = EcUnify.UniEnv.openty_r ue recty.tyd_params None in + let reccty = ty_subst tip reccty in let fields = List.fold_left @@ -1331,7 +1471,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = | None -> match dflrec with | None -> tyerror loc env (MissingRecField name) - | Some _ -> `Dfl (Tvar.subst tysopn rty, name) + | Some _ -> `Dfl (ty_subst tip rty, name) in List.mapi (fun i (name, rty) -> get_field i name rty) rec_ in @@ -1347,7 +1487,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = | `Dfl (rty, name) -> let nm = oget (EcPath.prefix recp) in - (proj (nm, name, (rtvi, reccty), rty, oget dflrec), rty) + (proj (nm, name, ((rixs, rtvi), reccty), rty, oget dflrec), rty) in List.map for1 fields @@ -1358,7 +1498,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = (EcPath.prefix recp) (Printf.sprintf "mk_%s" (EcPath.basename recp)) in - (ctor, fields, (rtvi, reccty)) + (ctor, fields, ((rixs, rtvi), reccty)) (* -------------------------------------------------------------------- *) let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = @@ -1376,7 +1516,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 = EcEnv.Op.by_path cp env in let (indp, ctoridx) = EcDecl.operator_as_ctor ctor in @@ -1399,10 +1539,25 @@ 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 - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in - let pty = EcUnify.UniEnv.fresh ue in + (* 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 (EcUnify.IXunamed [], tvi)) 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); @@ -1475,7 +1630,7 @@ let trans_branch_exn env ue ((pb, body) : ppattern * _) = (* FIXME should we use a different error message ? *) tyerror cname.pl_loc env (InvalidMatch FXE_CtorAmbiguous) - | [(cp, _tvi), _opty, subue, _] -> + | [(cp, _ixs, _tvi), _opty, subue, _] -> let exn = EcEnv.Op.by_path cp env in let dom = (EcDecl.operator_as_exception exn).exn_dom in let args_exp = List.length dom in @@ -1712,7 +1867,7 @@ let form_of_opselect operators unconditionally), so diagnose a failing application here. *) begin match sel with | `Lc id -> - let resolve t = ty_subst (Tuni.subst (EcUnify.UniEnv.assubst ue)) t in + let resolve t = ty_subst (EcUnify.UniEnv.as_subst ue) t in let psig = List.map (fun t -> resolve (unloc t)) esig in let ue' = EcUnify.UniEnv.copy ue in begin match EcUnify.classify_application env ue' ty psig None with @@ -1753,8 +1908,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 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 @@ -1771,7 +1926,7 @@ let form_of_opselect * - e is the index to update * - ty is the type of the value [x] *) -type lvmap = (path * ty list) * prog_var * expr * ty +type lvmap = (path * targs) * prog_var * expr * ty type lVAl = | Lval of lvalue @@ -1781,7 +1936,9 @@ 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 ~indices:tys.indices ~tyargs:tys.types + (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 = @@ -2241,9 +2398,9 @@ 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 + let ts = UE.close_subst ue in if after then si @ (s_subst ts s).s_node else @@ -2262,9 +2419,9 @@ 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 ts = UE.close_subst ue in let ty = ty_subst ts ty in unify_or_fail env ue loc ~expct:tbool ty; if after then @@ -2275,9 +2432,9 @@ 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 ts = UE.close_subst ue in let ty = ty_subst ts ty in match i.i_node with | Sif (_, t, f) -> @@ -2304,7 +2461,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 @@ -2330,7 +2487,13 @@ 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 tyidx = + match (EcEnv.ty_hnorm e.e_ty env).ty_node with + | Tconstr (_, ta) -> ta.indices + | _ -> [] in + let proj = + e_op proj ~indices:tyidx ~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)) @@ -2377,10 +2540,10 @@ 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 + let ts = UE.close_subst ue in Some (e_subst ts e') | _ -> fd.f_ret in @@ -2550,7 +2713,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 *) @@ -2573,7 +2736,7 @@ and transstruct1 (env : EcEnv.env) (st : pstructure_item located) = transbody ue memenv env retty (mk_loc st.pl_loc body) in (* Close all types *) - let ts = Tuni.subst (UE.assubst ue) in + let ts = UE.as_subst ue in let retty = fundef_check_type (ty_subst ts) env None (retty, decl.pfd_tyresult.pl_loc) in let params = List.map (fundef_check_decl (ty_subst ts) env) params in let locals = List.map (fundef_check_decl (ty_subst ts) env) locals in @@ -2867,8 +3030,7 @@ and transinstr | PSmatch (pe, pbranches) -> begin let e, ety = transexp env `InProc ue pe in - let uidmap = EcUnify.UniEnv.assubst ue in - let ety = ty_subst (Tuni.subst uidmap) ety in + let ety = ty_subst (EcUnify.UniEnv.as_subst ue) ety in let inddecl = match (EcEnv.ty_hnorm ety env).ty_node with @@ -2945,26 +3107,22 @@ and translvalue ue (env : EcEnv.env) lvalue = match ops with | [] -> - let uidmap = UE.assubst ue in - let esig = Tuni.subst_dom uidmap esig in + let esig = List.map (ty_subst (UE.as_subst ue)) esig in tyerror_noop env x.pl_loc name esig None opfailures - | [`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 + let esig = List.map (ty_subst (UE.as_subst ue)) esig in let esig = toarrow esig xty in unify_or_fail env ue lvalue.pl_loc ~expct:esig opty; - LvMap ((p, tys), pv, e, xty), codom + LvMap ((p, { indices = idxs; types = tys }), pv, e, xty), codom | [_] -> - let uidmap = UE.assubst ue in - let esig = Tuni.subst_dom uidmap esig in + let esig = List.map (ty_subst (UE.as_subst ue)) esig in tyerror_noop env x.pl_loc name esig None opfailures | _ -> - let uidmap = UE.assubst ue in - let esig = Tuni.subst_dom uidmap esig in + let esig = List.map (ty_subst (UE.as_subst ue)) esig in let matches = List.map (fun (_, _, subue, m) -> (m, subue)) ops in tyerror x.pl_loc env (MultipleOpMatch (name, esig, matches)) @@ -3045,7 +3203,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 @@ -3112,7 +3270,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 @@ -3133,7 +3291,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 @@ -3156,7 +3314,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 @@ -3430,8 +3588,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = begin match ops with | [] -> - let uidmap = UE.assubst ue in - let esig = Tuni.subst_dom uidmap esig in + let esig = List.map (ty_subst (UE.as_subst ue)) esig in tyerror_noop env loc name esig tt opfailures | [sel] -> @@ -3439,8 +3596,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = form_of_opselect (env, ue) loc sel es | _ -> - let uidmap = UE.assubst ue in - let esig = Tuni.subst_dom uidmap esig in + let esig = List.map (ty_subst (UE.as_subst ue)) esig in let matches = List.map (fun (_, _, subue, m) -> (m, subue)) ops in tyerror loc env (MultipleOpMatch (name, esig, matches)) end @@ -3480,7 +3636,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = | PFmatch (pcf, pb) -> let cf = transf env pcf in - let ts = Tuni.subst (UE.assubst ue) in + let ts = UE.as_subst ue in let cfty = ty_subst ts cf.f_ty in let inddecl = @@ -3543,15 +3699,18 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = f_lambda (List.map (fun (x, ty) -> (x, GTty ty)) xs) f | PFrecord (b, fields) -> - let (ctor, fields, (rtvi, reccty)) = - let proj (recp, name, (rtvi, reccty), pty, arg) = + let (ctor, fields, ((rixs, rtvi), reccty)) = + let proj (recp, name, ((rixs, 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 ~indices:rixs ~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 ~indices:rixs ~tyargs:rtvi + (toarrow (List.map snd fields) reccty) in f_app ctor (List.map fst fields) reccty | PFproj (subf, x) -> begin @@ -3564,17 +3723,17 @@ 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 tvi pty) [subf] rty + f_app (f_op op ~indices:ixs ~tyargs:tvi pty) [subf] rty end | PFproji (psubf, i) -> begin let subf = transf env psubf in - let ts = Tuni.subst (UE.assubst ue) in + let ts = UE.as_subst ue in let ty = ty_subst ts subf.f_ty in match (EcEnv.ty_hnorm ty env).ty_node with | Ttuple l when i < List.length l -> @@ -3903,10 +4062,25 @@ let get_instances (tvi, bty) env = List.pmap (fun ((typ, gty), cr) -> let ue = EcUnify.UniEnv.create (Some tvi) in - let (gty, _typ) = EcUnify.UniEnv.openty ue typ None gty in + let (os, _, _) = EcUnify.UniEnv.openty_r ue typ None in + let gty = ty_subst os gty in try EcUnify.unify env ue bty gty; - let ts = Tuni.subst (UE.close ue) in + (* [close_subst] resolves both type- and index-univars, so the + whole matched instance comes back fully concrete: matching + the carrier [word<:?i + 1>] against [word<:5>] pins [?i] and + the composed substitution rebinds every recorded slot + instantiation (e.g. [exp] at [?i] comes back at [4]). *) + let ts = EcUnify.UniEnv.close_subst ue in + let fty t = ty_subst ts (ty_subst os t) in + let fidx ti = + EcAst.tindex_normalize + (EcCoreSubst.tindex_subst ts (EcCoreSubst.tindex_subst os ti)) in + let cr = + match cr with + | `Ring r -> `Ring (EcDecl.ring_map identity fty fidx r) + | `Field f -> `Field (EcDecl.field_map identity fty fidx f) + in Some (inst, ty_subst ts gty, cr) with EcUnify.UnificationFailure _ -> None) inst @@ -3917,28 +4091,49 @@ let get_instances (tvi, bty) env = let name_selects name iname = match name with None -> true | Some _ -> name = iname +(* Bare selection ([name] = None) prefers ANONYMOUS instances: a named + instance is deliberately addressable and must not capture bare + [ring]/[field] calls by registration recency. It is still reachable + as a fallback when no anonymous instance covers the carrier. *) let get_ring ?name (typ, ty) env = let module E = struct exception Found of ring end in + let scan accept = try List.iter - (fun (_, _, cr) -> + (fun (_, cty, cr) -> match cr with - | `Ring cr when name_selects name cr.EcDecl.r_name -> - raise (E.Found cr) + | `Ring cr when accept cr.EcDecl.r_name -> + raise (E.Found { cr with r_type = cty }) | _ -> ()) (get_instances (typ, ty) env); None with E.Found cr -> Some cr + in + match name with + | Some _ -> scan (name_selects name) + | None -> + match scan Option.is_none with + | Some _ as r -> r + | None -> scan (fun _ -> true) let get_field ?name (typ, ty) env = let module E = struct exception Found of field end in + let scan accept = try List.iter - (fun (_, _, cr) -> + (fun (_, cty, cr) -> match cr with - | `Field cr when name_selects name cr.EcDecl.f_ring.EcDecl.r_name -> - raise (E.Found cr) + | `Field cr when accept cr.EcDecl.f_ring.EcDecl.r_name -> + let f_ring = { cr.f_ring with r_type = cty } in + raise (E.Found { cr with f_ring }) | _ -> ()) (get_instances (typ, ty) env); None with E.Found cr -> Some cr + in + match name with + | Some _ -> scan (name_selects name) + | None -> + match scan Option.is_none with + | Some _ as r -> r + | None -> scan (fun _ -> true) diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 624432c2d..2d749107d 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 @@ -128,6 +128,7 @@ type goal_shape_error = type tyerror = | UniVarNotAllowed | FreeTypeVariables +| FreeIndexVariables | TypeVarNotAllowed | OnlyMonoTypeAllowed of symbol option | NoConcreteAnonParams @@ -145,7 +146,13 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol +| NegativeIndexLiteral of EcBigInt.zint +| IndexMismatch of tindex * tindex | DuplicatedTyVar +| DuplicatedIndexVar of symbol +| TypeHasNoIndexParam of qsymbol * symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | DuplicatedException of qsymbol @@ -212,8 +219,14 @@ val tp_nothing : typolicy (* -------------------------------------------------------------------- *) 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/src/ecUnify.ml b/src/ecUnify.ml index 55a9a0f67..a835a9fa6 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,79 @@ 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 + +(* -------------------------------------------------------------------- *) +(* Failure is TRANSACTIONAL by default: on [UnificationFailure] the + unienv is restored to its entry state (in-place mutation would + otherwise leak partial type/index assignments into non-restoring + failure paths, e.g. the matcher's MatchFailure handlers). + [~transactional:false] deliberately KEEPS the partial assignments: + the failure-classification path runs on a throwaway unienv and + reads them back for diagnostics ("inferred as 'a = int"). *) +let unify_core ?(transactional = true) (env : EcEnv.env) (ue : unienv) (pb : pb) = + let saved = !ue in 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 +157,78 @@ 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 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 + (* 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 + + (* 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) + ) todo; + if !progressed && !deferred <> [] then drain_deferred () 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) -> + try_unify_ix t1 t2 + | `TyUni (t1, t2) -> begin let (t1, t2) = (getvar t1, getvar t2) in @@ -127,8 +238,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,28 +250,45 @@ 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 - - | 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 + 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 (); + List.iter2 + (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 + 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 (); !uf + try doit () + with UnificationFailure _ as e -> + if transactional then ue := saved; + raise e (* -------------------------------------------------------------------- *) let close (uf : UF.t) = @@ -199,20 +330,32 @@ 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; -} - -type unienv = unienv_r ref +type idx_inst = +| IXunamed of tindex list +| IXnamed of (EcSymbols.symbol * tindex) list type tvar_inst = -| TVIunamed of ty list -| TVInamed of (EcSymbols.symbol * ty) list +(* Explicit indices first, then explicit types. Either may be empty; + when both are empty, the slot is "no instantiation provided". The + index side is independent of the named/positional choice made for + the type side. *) +| TVIunamed of idx_inst * ty list +| TVInamed of idx_inst * (EcSymbols.symbol * ty) list type tvi = tvar_inst option + +(* Raised by [opentvi] / [openidx] on an explicitly named parameter + that matches no formal of the instantiated declaration. User-facing + paths validate names beforehand (op selection filters candidates, + [pf_check_tvi] checks lemma instantiation), so reaching this from + the surface is a bug in the caller. *) +exception UnknownTypeVariable of EcSymbols.symbol +exception UnknownIndexVariable of EcSymbols.symbol + +let tvi_indices (tvi : tvar_inst option) : idx_inst = + match tvi with + | None -> IXunamed [] + | Some (TVIunamed (ix, _)) | Some (TVInamed (ix, _)) -> ix type uidmap = uid -> ty option module UniEnv = struct @@ -234,43 +377,76 @@ 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; - ue_decl = []; - ue_closed = false; + 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 = match vd with | None -> ue | Some vd -> - 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 + (* 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 + let opentvi (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = + let params = params.tyvars in match tvi with | None -> List.fold_left (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 (TVInamed 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 (_ix, lt)) -> + List.iter (fun (name, _) -> + if not (List.exists (fun v -> EcIdent.name v = name) params) then + raise (UnknownTypeVariable name)) + lt; let for1 s v = let t = try fresh ~ty:(List.assoc (EcIdent.name v) lt) ue @@ -280,19 +456,76 @@ module UniEnv = struct in List.fold_left for1 Mid.empty params + (* Build the ident-to-tindex substitution that binds each idxvar + of [params]. Explicit indices (positional or named) are used + where provided; every other idxvar gets a fresh TIUnivar so + type-directed unification can assign it later. Named + instantiation may be partial. *) + let openidx (ue : unienv) (params : ty_params) (tvi : tvar_inst option) : tindex Mid.t = + let infer_all () = + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + in + match tvi_indices tvi with + | IXunamed [] -> infer_all () + + | IXunamed ix -> + if List.compare_lengths ix params.idxvars <> 0 then + (* CONTRACT: the arity fallback exists ONLY for the select + loop (a candidate op may be tried among others; arity + incompatibility is reported there as OF_idx_arity). + Every other caller validates arity beforehand + (pf_check_tvi for lemmas, tvi_compat for selection), so + a mismatch reaching a non-select caller is a caller + bug -- it silently infers instead of failing. *) + infer_all () + else + List.fold_left2 + (fun s v ti -> Mid.add v ti s) + Mid.empty params.idxvars ix + + | IXnamed ix -> + List.iter (fun (name, _) -> + if not (List.exists (fun v -> EcIdent.name v = name) params.idxvars) then + raise (UnknownIndexVariable name)) + ix; + List.fold_left + (fun s v -> + let ti = + try List.assoc (EcIdent.name v) ix + with Not_found -> idx_fresh ue + in Mid.add v ti s) + Mid.empty params.idxvars + 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 + + (* 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 subst = f_subst_init ~tv:(opentvi ue params tvi) () in - (subst, subst_tv (ty_subst subst) params) + let idxmap = openidx ue params tvi in + let subst = + f_subst_init + ~tv:(opentvi ue params tvi) + ~idx:idxmap + () in + 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 = @@ -300,9 +533,20 @@ module UniEnv = struct | Tunivar id -> odfl t (UF.data id (!ue).ue_uf) | _ -> t - let closed (ue : unienv) = + let closed_tv (ue : unienv) = UF.closed (!ue).ue_uf + (* The index side: every allocated index univar got an assignment. + Exposed separately so uninferred *indices* can be reported as + such instead of as "free type variables". *) + let closed_iu (ue : unienv) = + Suid.subset (!ue).ue_iuf_alloc + (Muid.fold (fun u _ s -> Suid.add u s) + (!ue).ue_iuf Suid.empty) + + let closed (ue : unienv) = + closed_tv ue && closed_iu ue + let close (ue : unienv) = if not (closed ue) then raise UninstantiateUni; (subst_of_uf (!ue).ue_uf) @@ -310,14 +554,55 @@ 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 + + (* 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 + () + + (* Non-raising variant: substitute the resolved univars of both + kinds, leave the unresolved ones in place. *) + (* Chase [ue_iuf] chains: the assignment map may bind a univar to + another univar. *) + let repr_tindex (ue : unienv) (ti : tindex) : tindex = + resolve_tindex ue ti + + let as_subst (ue : unienv) : f_subst = + f_subst_init + ~tu:(subst_of_uf (!ue).ue_uf) + ~iu:(!ue).ue_iuf + () + let tparams (ue : unienv) : ty_params = - List.rev (!ue).ue_decl + { idxvars = List.rev (!ue).ue_idxdecl; + tyvars = List.rev (!ue).ue_decl; } 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)) + +(* 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 = @@ -328,23 +613,42 @@ 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 (* -------------------------------------------------------------------- *) type op_failure = | OF_argument of int * ty * ty (* 1-based index, expected (param), provided (arg) *) | OF_result of ty * ty (* operator result type, expected result type *) | OF_arity of int * int (* expected arity (at most), provided *) + | OF_idx_arity of int * int (* expected #index params, provided *) + | OF_idx_unknown of EcSymbols.symbol (* named index binding no index param *) + | OF_tv_arity of int * int (* expected #type params, provided *) + | OF_tv_unknown of EcSymbols.symbol (* named tyvar binding no type param *) (* -------------------------------------------------------------------- *) -(* Constrained type parameters of an operator (those bound while applying it). *) -type op_instance = (EcIdent.t * ty) list +(* Parameters of an operator constrained while applying it. *) +type op_instance = { + oi_tys : (EcIdent.t * ty) list; + oi_ixs : (EcIdent.t * tindex) list; +} type select_outcome = | OK of select_result | KO of (EcPath.path * op_instance * ty * op_failure) Lazy.t (* operator path, partial instantiation, declared operator type, reason *) +(* -------------------------------------------------------------------- *) +(* Resolve both type- and index-univars of [ty]: failure reports must + show inferred indices, not raw index univars. (No index + normalization: [ty] hashconsing compares indices canonically, so a + rebuilt [vec<:8>] IS the interned [vec<:3+5>] node — the display + spelling is whichever was interned first, deterministic per file.) *) +let resolve_ty_for_report (ue : unienv) (ty : ty) : ty = + ty_subst + (f_subst_init ~tu:(UniEnv.assubst ue) ~iu:(UniEnv.iu_assubst ue) ()) + ty + (* -------------------------------------------------------------------- *) (* [None] if [top] applies to [psig] (and [retty]), updating [ue]; otherwise [Some] of the first argument/result/arity failure. *) @@ -358,9 +662,14 @@ let classify_application = let exception Failure_with of op_failure in - let resolve ty = ty_subst (Tuni.subst (UniEnv.assubst ue)) ty in + (* Resolve both type- and index-univars: failure reports must show + inferred indices, not raw index univars. *) + let resolve ty = resolve_ty_for_report ue ty in let whnf ty = EcEnv.ty_hnorm (resolve ty) env in + let unify env ue t1 t2 = + unify_core ~transactional:false env ue (`TyUni (t1, t2)) in + let rec peel i cur args = match args with | [] -> begin @@ -413,28 +722,57 @@ let select_op_outcomes let (psig, retty) = sig_ in - let filter oppath op = - (* Filter operator based on given type variables instanciation *) - let filter_on_tvi = - match tvi with - | None -> fun _ -> true - - | Some (TVIunamed lt) -> - let len = List.length lt in - fun op -> - let tparams = op.D.op_tparams in - List.length tparams = len - - | Some (TVInamed ls) -> fun op -> - let tparams = List.map EcIdent.name op.D.op_tparams in - let tparams = Ssym.of_list tparams in - List.for_all (fun (x, _) -> Msym.mem x tparams) ls + (* An explicit instantiation incompatible with the candidate is not a + silent pre-filter: it classifies the candidate as a [KO] with a + precise reason, so a zero-[OK] selection can explain itself + instead of degenerating to "unknown variable or constant". *) + let tvi_compat (op : D.operator) : op_failure option = + match tvi with + | None -> None + | Some tvi_ -> + (* Index side: a positional non-empty list must match the + candidate's index arity; a named list must only use the + candidate's idxvar names (it may be partial). Empty means + "infer this side". *) + let idxvars = op.D.op_tparams.idxvars in + let idx_fail = + match tvi_indices (Some tvi_) with + | IXunamed [] -> None + | IXunamed ix -> + let n = List.length ix in + if n <> List.length idxvars then + Some (OF_idx_arity (List.length idxvars, n)) + else None + | IXnamed ix -> + let iparams = Ssym.of_list (List.map EcIdent.name idxvars) in + List.find_map_opt + (fun (x, _) -> + if Ssym.mem x iparams then None + else Some (OF_idx_unknown x)) + ix + in - in - filter oppath op && filter_on_tvi op + let tyvars = op.D.op_tparams.tyvars in + let ty_fail = + match tvi_ with + | TVIunamed (_, []) -> None + | TVIunamed (_, lt) -> + let n = List.length lt in + if n <> List.length tyvars then + Some (OF_tv_arity (List.length tyvars, n)) + else None + | TVInamed (_, ls) -> + let tparams = Ssym.of_list (List.map EcIdent.name tyvars) in + List.find_map_opt + (fun (x, _) -> + if Ssym.mem x tparams then None + else Some (OF_tv_unknown x)) + ls + in + (match idx_fail with Some _ -> idx_fail | None -> ty_fail) in - let mk_ok (path, op) tip tvs top subue = + let mk_ok (path, op) tip ixs tvs top subue = let bd = match op.D.op_kind with | OB_nott nt -> @@ -447,39 +785,55 @@ let select_op_outcomes | _ -> None - in OK ((path, tvs), top, subue, bd) + in OK ((path, ixs, tvs), top, subue, bd) in let classify (path, op) = let subue = UniEnv.copy ue in - 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 resolve ty = ty_subst (Tuni.subst (UniEnv.assubst subue)) ty in + let resolve ty = resolve_ty_for_report subue ty in (* [select] builds a [KO] only after unification rejected the candidate. *) let f = oget (classify_application env subue top psig retty) in - let instance = - List.combine op.D.op_tparams tvs - |> List.filter_map (fun (tp, tv) -> - match (resolve tv).ty_node with - | Tunivar _ -> None - | _ -> Some (tp, resolve tv)) - in + let instance = { + oi_tys = + List.combine op.D.op_tparams.tyvars tvs + |> List.filter_map (fun (tp, tv) -> + match (resolve tv).ty_node with + | Tunivar _ -> None + | _ -> Some (tp, resolve tv)); + oi_ixs = + List.combine op.D.op_tparams.idxvars ixs + |> List.filter_map (fun (ip, iv) -> + match resolve_tindex subue iv with + | TIUnivar _ -> None + | iv -> Some (ip, tindex_normalize iv)); + } in (path, instance, op.D.op_ty, f) in let select (path, op) = + match tvi_compat op with + | Some f -> + (* Do not open/unify: [openidx] falls back to inference on a + positional-arity mismatch, so a wrong-arity candidate could + otherwise unify successfully. *) + KO (lazy (path, { oi_tys = []; oi_ixs = [] }, op.D.op_ty, f)) + + | None -> + let subue = UniEnv.copy ue in - 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 match unify env subue top texpected with - | () -> mk_ok (path, op) tip tvs top subue + | () -> mk_ok (path, op) tip ixs tvs top subue | exception UnificationFailure _ -> KO (lazy (classify (path, op))) in diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 31d9a658a..0831903a8 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -6,16 +6,33 @@ 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 +(* Explicit index instantiation: positional or (possibly partial) + named. [IXunamed []] means "no indices provided". *) +type idx_inst = +| IXunamed of tindex list +| IXnamed of (EcSymbols.symbol * tindex) list + type tvar_inst = -| TVIunamed of ty list -| TVInamed of (EcSymbols.symbol * ty) list +(* (explicit indices, explicit types). Either may be empty; the + typing layer falls back to inference for empty sides. The index + side is independent of the named/positional choice made for the + type side. *) +| TVIunamed of idx_inst * ty list +| TVInamed of idx_inst * (EcSymbols.symbol * ty) list type tvi = tvar_inst option + +(* Raised by [opentvi] / [openidx] on an explicitly named parameter + that matches no formal of the instantiated declaration. *) +exception UnknownTypeVariable of EcSymbols.symbol +exception UnknownIndexVariable of EcSymbols.symbol + +val tvi_indices : tvi -> idx_inst type uidmap = uid -> ty option module UniEnv : sig @@ -23,32 +40,77 @@ 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 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 openty_r : unienv -> ty_params -> tvi + -> EcCoreSubst.f_subst * tindex list * ty list val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * ty list val closed : unienv -> bool - val close : unienv -> ty Muid.t - val assubst : unienv -> ty Muid.t + (* The two halves of [closed]: type-univar side / index-univar side, + so uninferred indices can be reported as such. *) + val closed_tv : unienv -> bool + val closed_iu : unienv -> bool + (* Index-univar resolved assignment map. Specialized: only for + consumers that need the raw index half (the proof-term idx-link + bridge); everything else goes through the combined substitutions + below. *) + val iu_assubst : unienv -> tindex Muid.t + (* Resolve a tindex through the current (possibly chained) index + univar assignments. *) + val repr_tindex : unienv -> tindex -> tindex + + (* THE closing API. Both build the complete [f_subst] resolving + type-univars AND index-univars — closing one kind without the + other is not expressible from outside this module. + [close_subst] raises [UninstantiateUni] when either side is + unresolved; [as_subst] substitutes what is resolved and leaves + the rest. *) + val close_subst : unienv -> EcCoreSubst.f_subst + val as_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 -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 type op_failure = | OF_argument of int * ty * ty (* 1-based index, expected (param), provided (arg) *) | OF_result of ty * ty (* operator result type, expected result type *) | OF_arity of int * int (* expected arity (at most), provided *) + | OF_idx_arity of int * int (* expected #index params, provided *) + | OF_idx_unknown of EcSymbols.symbol (* named index binding no index param *) + | OF_tv_arity of int * int (* expected #type params, provided *) + | OF_tv_unknown of EcSymbols.symbol (* named tyvar binding no type param *) -(* Constrained type parameters of an operator (those bound while applying it). *) -type op_instance = (EcIdent.t * ty) list +(* Parameters of an operator constrained while applying it. *) +type op_instance = { + oi_tys : (EcIdent.t * ty) list; + oi_ixs : (EcIdent.t * tindex) list; +} (* [None] if [top] applies to [psig] (and [retty]), updating [ue]; otherwise [Some] of the first argument/result/arity failure. *) diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 763bec43a..a6c3d70b4 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -278,6 +278,10 @@ end = struct | FreeTypeVariables -> msg "this expression contains free type variables" + | FreeIndexVariables -> + msg "cannot infer all index parameters in this expression; \ + supply them explicitly (e.g. `f[:n = 3]')" + | TypeVarNotAllowed -> msg "type variables not allowed" @@ -332,9 +336,45 @@ 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 + + | NegativeIndexLiteral n -> + msg "negative index literal `%s': indices range over the naturals" + (EcBigInt.to_string n) + + | IndexMismatch (i1, i2) -> + let ground ti = + let rec go = function + | EcAst.TIUnivar _ -> false + | EcAst.TIVar _ | EcAst.TIConst _ -> true + | EcAst.TIAdd (a, b) | EcAst.TIMul (a, b) -> go a && go b + in go ti in + if ground i1 && ground i2 then + msg "incompatible index arguments: `%a' vs `%a'" + (EcPrinting.pp_tindex env) i1 + (EcPrinting.pp_tindex env) i2 + else + msg "cannot infer the index arguments: unifying `%a' with \ + `%a' is outside the supported fragment (single-variable \ + affine equations)" + (EcPrinting.pp_tindex env) i1 + (EcPrinting.pp_tindex env) i2 + | DuplicatedTyVar -> msg "a type variable appear at least twice" + | DuplicatedIndexVar name -> + msg "an index variable appears at least twice: `%s'" name + + | TypeHasNoIndexParam (tyname, x) -> + msg "type `%s' has no index parameter named `%s'" + (string_of_qsymbol tyname) x + | DuplicatedLocal name -> msg "duplicated local/parameters name: `%s'" name @@ -403,15 +443,41 @@ end = struct Format.fprintf fmt "it is applied to %d argument(s) but takes at most %d" provided atmost + | EcUnify.OF_idx_arity (expected, provided) -> + Format.fprintf fmt + "it takes %d index parameter(s) but is given %d" + expected provided + | EcUnify.OF_idx_unknown x -> + Format.fprintf fmt + "it has no index parameter named `%s'" x + | EcUnify.OF_tv_arity (expected, provided) -> + Format.fprintf fmt + "it takes %d type parameter(s) but is given %d" + expected provided + | EcUnify.OF_tv_unknown x -> + Format.fprintf fmt + "it has no type parameter named `%s'" x + in + let instance_is_empty instance = + List.is_empty instance.EcUnify.oi_tys + && List.is_empty instance.EcUnify.oi_ixs in let pp_instance fmt instance = - if not (List.is_empty instance) then begin + if not (List.is_empty instance.EcUnify.oi_ixs) then begin + Format.fprintf fmt "where the index parameters were inferred as:@\n"; + List.iter + (fun (ip, ti) -> + Format.fprintf fmt " @[%s = %a@]@\n" + (EcIdent.name ip) (EcPrinting.pp_tindex env) ti) + instance.EcUnify.oi_ixs + end; + if not (List.is_empty instance.EcUnify.oi_tys) then begin Format.fprintf fmt "where the type parameters were inferred as:@\n"; List.iter (fun (tp, ty) -> Format.fprintf fmt " @[%a = %a@]@\n" pp_type (tvar tp) pp_type ty) - instance + instance.EcUnify.oi_tys end in let pp_kind fmt = function @@ -425,7 +491,7 @@ end = struct let pp_details fmt (cand, fail) = begin match cand with | `Op (_, instance, declty) -> - if not (List.is_empty instance) then + if not (instance_is_empty instance) then Format.fprintf fmt "its type is@\n @[%a@]@\n%a" pp_type declty pp_instance instance | `Pv (_, ty) | `Lc (_, ty) -> @@ -477,8 +543,8 @@ end = struct msg "@\n"; let pp_op fmt ((op, inst), subue) = - let uidmap = EcUnify.UniEnv.assubst subue in - let inst = Tuni.subst_dom uidmap inst in + let inst = + List.map (ty_subst (EcUnify.UniEnv.as_subst subue)) inst in begin match inst with | [] -> @@ -494,8 +560,7 @@ end = struct let myuvars = List.fold_left Suid.union uvars myuvars in let myuvars = Suid.elements myuvars in - let uidmap = EcUnify.UniEnv.assubst subue in - let tysubst = ty_subst (Tuni.subst uidmap) in + let tysubst = ty_subst (EcUnify.UniEnv.as_subst subue) in let myuvars = List.pmap (fun uid -> match tysubst (tuni uid) with @@ -523,8 +588,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 @@ -831,6 +896,9 @@ end = struct | NotSameNumberOfTyParam (exp, got) -> Format.fprintf fmt "contains %i type parameter instead of %i" got exp + | NotSameNumberOfIdxParam (exp, got) -> + Format.fprintf fmt "contains %i index parameter instead of %i" got exp + | DifferentType (exp, got) -> let ppe = EcPrinting.PPEnv.ofenv env in Format.fprintf fmt "has type %a instead of %a" @@ -878,6 +946,11 @@ 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_OpIncompatible (x, err) -> msg "operator `%s' body %a" (string_of_qsymbol x) (pp_incompatible env) err @@ -946,8 +1019,7 @@ end = struct | AE_InvalidArgForm (IAF_Mismatch (src, dst)) -> let ppe = EcPrinting.PPEnv.ofenv (LDecl.toenv hyps) in - let uidmap = EcUnify.UniEnv.assubst ue in - let dst = ty_subst (Tuni.subst uidmap) dst in + let dst = ty_subst (EcUnify.UniEnv.as_subst ue) dst in msg "This expression has type@\n"; msg " @[%a@]@\n@\n" (EcPrinting.pp_type ppe) src; diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 103e382f4..5612296e0 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -199,7 +199,7 @@ let t_bdep_solve (tc : tcenv1) = | _ -> begin try let ctxt = tohyps hyps in - assert (ctxt.h_tvar = []); + assert (ctxt.h_tvar.tyvars = [] && ctxt.h_tvar.idxvars = []); let st = circuit_state_of_hyps hyps in let cgoal = circuit_of_form st hyps goal |> state_close_circuit st in if circ_valid cgoal then FApi.close !@tc VBdep @@ -301,11 +301,11 @@ let t_extens (v : string option) (tt : backward) (tc : tcenv1) = let goals = match sform_of_form (tc1_goal tc), v with - | SFop ((p, [tp]), [fpred; flist]), None + | SFop ((p, { indices = []; types = [tp] }), [fpred; flist]), None when EcPath.p_equal p EcCoreLib.CI_List.p_all && tp = tint -> begin match sform_of_form flist with - | SFop ((p, []), [fstart; flen]) + | SFop ((p, { indices = []; types = [] }), [fstart; flen]) when EcPath.p_equal p EcCoreLib.CI_List.p_iota -> let start = match sform_of_form fstart with diff --git a/src/phl/ecPhlCond.ml b/src/phl/ecPhlCond.ml index baf9f449e..169a003a8 100644 --- a/src/phl/ecPhlCond.ml +++ b/src/phl/ecPhlCond.ml @@ -273,8 +273,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 @@ -290,8 +290,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; @@ -354,8 +354,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 8ea5e6e5b..e0ebc8fd7 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 a1727ff94..718c59e3c 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 8709cce9e..d2c536e80 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 && not (Mid.mem m f_l.f_fv) then Some(ty_elem, {m;inv=f_f}, f_l) else None @@ -138,7 +138,7 @@ let pr_has_le f_pr = let f_pr1 = f_pr_r {pr with pr_event} in let f_fsum = f_lambda [idx, GTty ty_elem] f_pr1 in let f_sum = - f_app (f_op p_BRA_big [ty_elem] EcTypes.treal) [f_predT ty_elem; f_fsum; f_l] EcTypes.treal in + f_app (f_op p_BRA_big ~tyargs:[ty_elem] EcTypes.treal) [f_predT ty_elem; f_fsum; f_l] EcTypes.treal in f_real_le f_pr f_sum (* -------------------------------------------------------------------- *) diff --git a/src/phl/ecPhlRCond.ml b/src/phl/ecPhlRCond.ml index 81a78744a..e1657108c 100644 --- a/src/phl/ecPhlRCond.ml +++ b/src/phl/ecPhlRCond.ml @@ -143,7 +143,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 @@ -172,7 +172,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 @@ -201,7 +201,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 @@ -210,7 +210,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 3e2ff5b6b..8097c5c6f 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -152,10 +152,10 @@ 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 + let es = e_subst (EcUnify.UniEnv.close_subst ue) in Some (List.map es args, omap (EcModules.lv_of_expr -| es) res) with EcUnify.UninstantiateUni -> EcTyping.tyerror (loc pargs) env EcTyping.FreeTypeVariables diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index c5de2be2c..2eb23cd53 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -29,7 +29,7 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let ty = EcTyping.transty EcTyping.tp_tydecl env ue ty in assert (EcUnify.UniEnv.closed ue); let ty = - let subst = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + let subst = EcUnify.UniEnv.close_subst ue in EcCoreSubst.ty_subst subst ty in let x = Option.map EcLocation.unloc (EcLocation.unloc x) in let vr = EcAst.{ ov_name = x; ov_type = ty; } in @@ -50,7 +50,7 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = if not (EcUnify.UniEnv.closed ue) then tc_error !!tc "Failed to infer all types for type variables"; - let sb = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + let sb = EcUnify.UniEnv.close_subst ue in EcCoreSubst.s_subst sb s in let zp = Zpr.zipper_of_cpos env cpos hs.hs_s in diff --git a/src/phl/ecPhlWhile.ml b/src/phl/ecPhlWhile.ml index e1714332c..4261dfd07 100644 --- a/src/phl/ecPhlWhile.ml +++ b/src/phl/ecPhlWhile.ml @@ -370,7 +370,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 @@ -611,7 +611,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 ; diff --git a/src/phl/ecPhlWp.ml b/src/phl/ecPhlWp.ml index 4c2e0babb..7c3306429 100644 --- a/src/phl/ecPhlWp.ml +++ b/src/phl/ecPhlWp.ml @@ -20,7 +20,7 @@ module LowInternal = struct let f = EcReduction.h_red_until EcReduction.full_red hyps f in let (ex, tyargs), args = destr_op_app f in - assert (List.is_empty tyargs); + assert (List.is_empty tyargs.types && List.is_empty tyargs.indices); let default_exn () = match Mop.find_opt None epost with diff --git a/tests/clone-indexed-override.ec b/tests/clone-indexed-override.ec new file mode 100644 index 000000000..8d0151ada --- /dev/null +++ b/tests/clone-indexed-override.ec @@ -0,0 +1,60 @@ +(* Overriding indexed types and operators in cloning (#1065, comment 5): + + clone U with type {n} 'a foo = 'a vec<:n>, + op f {n} ['a] (x : 'a) (xs : 'a vec<:n>) = cons[:n] x xs. +*) + +type {n} 'a vec. + +op cons {n} ['a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. + +theory U. + type {n} 'a foo. + + op f {n} ['a] : 'a -> 'a foo<:n> -> 'a foo<:n+1>. + + axiom fP {n} ['a] (x : 'a) (xs : 'a foo<:n>) : f x xs = f x xs. + + pred p {n} ['a] : 'a foo<:n>. +end U. + +(* type override only *) +clone U as U1 with + type {n} 'a foo = 'a vec<:n>. + +(* type + op + pred overrides, alias mode *) +pred nonempty {n} ['a] (xs : 'a vec<:n>) = ! (n = 0). + +clone U as U2 with + type {n} 'a foo = 'a vec<:n>, + op f {n} ['a] (x : 'a) (xs : 'a vec<:n>) = cons[:n] x xs, + pred p {n} ['a] (xs : 'a vec<:n>) = nonempty xs. + +(* the overridden operator unfolds to its definition *) +lemma f_is_cons {n} ['a] (x : 'a) (xs : 'a vec<:n>) : + U2.f x xs = cons x xs. +proof. trivial. qed. + +expect "* In [operators, predicates or exceptions]: + +pred p {n} ['a] (xs : 'a vec<:n>) = nonempty xs." by print U2.p. + +(* inline mode *) +clone U as U3 with + type {n} 'a foo <- 'a vec<:n>, + op f {n} ['a] (x : 'a) (xs : 'a vec<:n>) <- cons[:n] x xs. + +(* the inlined operator is substituted in the clone's axioms *) +expect "* In [lemmas or axioms]: + +(* U3.fP *) +axiom fP {n} ['a]: forall (x : 'a) (xs : 'a vec<:n>), cons x xs = cons x xs." by print U3.fP. + +(* index-arity mismatch in an override is rejected *) +theory V. + type {n m} 'a bar. + op g {n m} ['a] : 'a bar<:n, m> -> 'a bar<:n, m>. +end V. + +fail clone V as V1 with + type {n} 'a bar = 'a vec<:n>. diff --git a/tests/iarray.ec b/tests/iarray.ec new file mode 100644 index 000000000..84b30a693 --- /dev/null +++ b/tests/iarray.ec @@ -0,0 +1,20 @@ +require import AllCore. +require import IArray. + +(* Symbolic n: the equational surface is usable by rewriting. *) +lemma sym_get_set {n} ['a] (a : 'a array<:n>) (i : int) (x : 'a) : + 0 <= i < n => a.[i <- x].[i] = x. +proof. by move=> hi; rewrite get_set. qed. + +lemma sym_set_set {n} ['a] (a : 'a array<:n>) (i j : int) (x y : 'a) : + i <> j => a.[i <- x].[j <- y] = a.[j <- y].[i <- x]. +proof. by move=> ne; rewrite set_set_swap. qed. + +lemma sym_map_get {n} ['a 'b] (f : 'a -> 'b) (a : 'a array<:n>) (i : int) : + 0 <= i < n => (map f a).[i] = f a.[i]. +proof. by move=> hi; rewrite mapE. qed. + +(* Concrete index: same lemmas specialise. *) +lemma cn_get_set ['a] (a : 'a array<:8>) (x : 'a) : + a.[3 <- x].[3] = x. +proof. by rewrite get_set. qed. diff --git a/tests/indexed-elim.ec b/tests/indexed-elim.ec new file mode 100644 index 000000000..261304b48 --- /dev/null +++ b/tests/indexed-elim.ec @@ -0,0 +1,52 @@ +(* Elimination and matching over indexed inductives. + + - the case/induction scheme GENERATORS (datatype, record, prind, + projectors) built their type/op occurrences without indices, so + the schemes were ill-shaped and elim/case failed or anomalied; + - the matcher tolerated GROUND index mismatches on Fop heads, + leaking ill-matched instances into InvalidGoalShape downstream. *) + +require import AllCore. + +type {n} 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. + +lemma case_ivec {k} (v : int ivec<:k>) : + v = INil \/ exists x xs, v = ICons x xs. +proof. by case: v => [|x xs]; [left | right; exists x xs]. qed. + +lemma elim_ivec {k} (v : int ivec<:k>) : true. +proof. by elim: v. qed. + +lemma case_explicit {k} (v : int ivec<:k>) : + v = INil \/ exists x xs, v = ICons x xs. +proof. elim/ivec_case: v => [|x xs]; [by left | by right; exists x xs]. qed. + +(* indexed records: induction scheme *) +type {n} r = { rfld : int ivec<:n> }. + +lemma case_r {k} (x : r<:k>) : exists v, x = {| rfld = v |}. +proof. by elim/r_ind: x => v; exists v. qed. + +(* indexed inductive predicates *) +type {n} 'a vec. +op vnil {n} ['a] : 'a vec<:n>. + +inductive allz {n} (v : int vec<:n>) = +| AllNil of (v = vnil). + +lemma elim_allz {k} (v : int vec<:k>) : allz v => v = vnil. +proof. by case. qed. + +(* matcher: ground index mismatches fail the match cleanly *) +op f {n} (x : int) : int. +axiom fE3 (x : int) : f[:3] x = 0. + +lemma no_ground_confusion (x : int) : f[:5] x = f[:5] x. +proof. +fail rewrite fE3. +trivial. +qed. + +axiom fEk {k} (x : int) : f[:k] x = 0. +lemma infer_ok (x : int) : f[:5] x = 0. +proof. by rewrite fEk. qed. diff --git a/tests/indexed-idxvar-freshening.ec b/tests/indexed-idxvar-freshening.ec new file mode 100644 index 000000000..22eaff4b5 --- /dev/null +++ b/tests/indexed-idxvar-freshening.ec @@ -0,0 +1,38 @@ +(* Declaration builders that FRESHEN parameters must rename idxvars in + BOTH namespaces (tindex positions and int-typed formula-local + occurrences), and generated op applications must carry indices: + axiomatized-by axioms, refinement axioms, and clone-freshened + indexed lemmas were all born with dangling idents. *) + +require import AllCore. + +type {n} 'a vec. +op vsize {n} ['a] (v : 'a vec<:n>) : int = n. + +(* axiomatized_op: the generated axiom must keep both namespaces linked *) +op double {n} (x : int) : int = x + n axiomatized by doubleE. + +expect "* In [lemmas or axioms]: + +axiom doubleE {n}: forall (x : int), double[:n] x = x + n." by print doubleE. + +lemma use_doubleE {k} (x : int) : double[:k] x = x + k. +proof. by smt(doubleE). qed. + +lemma vszE {k} ['a] (v : 'a vec<:k>) : vsize v = k. +proof. by rewrite /vsize. qed. + +lemma rw_control (v : int vec<:3>) : vsize v = 3. +proof. by rewrite vszE. qed. + +(* clone-freshening: an indexed lemma using its index as a term *) +theory U. + type {n} t. + op sz {n} (x : t<:n>) : int. + axiom szE {n} (x : t<:n>) : sz x = n. +end U. + +clone U as U2. + +lemma use_szE {k} (x : U2.t<:k>) : U2.sz x = k. +proof. by rewrite U2.szE. qed. diff --git a/tests/indexed-iota.ec b/tests/indexed-iota.ec new file mode 100644 index 000000000..642cbd4f3 --- /dev/null +++ b/tests/indexed-iota.ec @@ -0,0 +1,45 @@ +(* Iota-reduction of match-fix operators and delta-unfolding must + instantiate the operator's index parameters in BOTH namespaces + (tindex positions and int-formula occurrences). A tyvars-only + substitution left the declaration-time idxvar dangling, reducing + applications at DIFFERENT indices to the same term (false was + derivable). *) + +type {n} 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. + +op f {n} (d : int) (xs : int ivec<:n>) : int = + with xs = INil => n + with xs = ICons y ys => d. + +(* iota lands on the call-site index (cbv path) *) +lemma f5 : f[:5] 0 (INil[:5]<:int>) = 5. +proof. by cbv. qed. + +lemma f7 : f[:7] 0 (INil[:7]<:int>) = 7. +proof. by cbv. qed. + +(* the old unsound collapse: both sides reduce to their OWN index *) +lemma nocollapse : f[:5] 0 (INil[:5]<:int>) <> f[:7] 0 (INil[:7]<:int>). +proof. by cbv. qed. + +(* simplify path (ecReduction iota) *) +lemma f5' : f[:5] 0 (INil[:5]<:int>) = 5. +proof. by simplify. qed. + +(* delta-unfold of an indexed plain operator (rewrite /op path) *) +op g {n} ['a] (v : 'a ivec<:n>) : int = n. + +lemma gdelta (v : int ivec<:3>) : g v = 3. +proof. by rewrite /g. qed. + +(* conversion must not identify distinct index instantiations (the + applied-operator fast path used to compare heads by path only) *) +op h {n} (x : int) : int. + +lemma conv_same : h[:3] 0 = h[:2+1] 0. +proof. trivial. qed. + +lemma conv_distinct : h[:3] 0 = h[:5] 0. +proof. +fail by trivial. +abort. diff --git a/tests/indexed-node-instantiation.ec b/tests/indexed-node-instantiation.ec new file mode 100644 index 000000000..89547b9a3 --- /dev/null +++ b/tests/indexed-node-instantiation.ec @@ -0,0 +1,56 @@ +(* Index-carrying AST nodes at desugaring sites, and chained index + univars in proof terms. + + - LvMap: the map-set assignment [a.[e] <- v] must persist the set + operator WITH its inferred indices; + - records: constructor / projection nodes carry the record's + instance indices (as does the datatype-match desugar); + - proof terms: an applied lemma argument may link the lemma's index + univar to the argument's own univar (a chain); concretization + must chase the chain, including into compound indices. *) + +require import AllCore IArray. + +(* LvMap (finding: index-erased set operator persisted) *) +module M = { + proc f (a : int array<:4>) : int array<:4> = { + a.[0] <- 7; + return a; + } +}. + +lemma lvmap_wp (a0 : int array<:4>) : + hoare [M.f : a = a0 ==> res = a0.[0 <- 7]]. +proof. proc. wp. skip. by move => &m ->. qed. + +(* indexed records: nodes carry indices; conversion works *) +type {n} 'a vec. +op mk {n} ['a] : 'a vec<:n>. +type {n} 'a r = { fld : 'a vec<:n> }. + +op build : int r<:5> = {| fld = mk |}. + +lemma build_fld : build.`fld = mk[:5]<:int>. +proof. by rewrite /build. qed. + +(* SMT on indexed records degrades cleanly (no sound erased encoding + yet: CanNotTranslate, not a Why3 arity anomaly) *) +lemma build_fld_smt : build.`fld = mk[:5]<:int>. +proof. +fail smt(). +by rewrite /build. +qed. + +(* chained index univars through proof-term application *) +op vinit {n} ['a] : 'a -> 'a vec<:n>. +op vsize {n} ['a] (v : 'a vec<:n>) : int = n. + +lemma vsz {n} ['a] (v : 'a vec<:n>) : vsize v = n. +proof. by rewrite /vsize. qed. + +lemma chained : vsize (vinit[:7]<:int> 0) = 7. +proof. apply (vsz (vinit 0)). qed. + +(* compound resolved index through the link (n+1 shape) *) +lemma chained2 {m} (w : int vec<:m>) : vsize (vinit[:m+1]<:int> 0) = m + 1. +proof. apply (vsz (vinit 0)). qed. diff --git a/tests/indexed-nonneg.ec b/tests/indexed-nonneg.ec new file mode 100644 index 000000000..09dc24cfc --- /dev/null +++ b/tests/indexed-nonneg.ec @@ -0,0 +1,43 @@ +(* The non-negativity discipline: index variables range over the + NATURALS, and the only terms allowed to instantiate an index are + built from the context's own index variables. The fact itself is + the [Int.ge0_index] axiom (sound in the enforced model); the + [fail] cases below were derivations of [false]: matching an + idxvar-premised lemma against a goal over an arbitrary int local + bound the index to that local. *) + +require import AllCore. + +type {n} vec. + +lemma plus {n} : 0 <= n. +proof. exact ge0_index. qed. + +(* an arbitrary int local is NOT an index variable *) +lemma bad (k : int) : 0 <= k. +proof. +fail apply plus. +abort. + +(* the axiom itself is gated the same way *) +lemma bad0 (k : int) : 0 <= k. +proof. +fail apply ge0_index. +abort. + +(* same through an idxvar-premised axiom *) +type {n} t. +axiom ge0_idx {n} (x : t<:n>) : 0 <= n. + +lemma bad2 (k : int) : 0 <= k. +proof. +fail apply (ge0_idx witness). +abort. + +(* positive control: a goal whose variable IS an index variable *) +lemma ok {k} : 0 <= k. +proof. apply plus. qed. + +(* positive control: index arithmetic over index variables *) +lemma ok2 {k} : 0 <= k + 1. +proof. apply plus. qed. diff --git a/tests/indexed-simplify-rules.ec b/tests/indexed-simplify-rules.ec new file mode 100644 index 000000000..66a18596d --- /dev/null +++ b/tests/indexed-simplify-rules.ec @@ -0,0 +1,93 @@ +(* User rewrite rules (hint simplify) over indexed operator heads. + Index patterns are matched WITHOUT the unification engine and are + restricted to the affine single-variable fragment: a constant, a + bare idxvar [k], or [k + b] (solved as [k := width - b] when the + width's constant part is at least [b]). *) + +require import AllCore. + +type {n} vec. + +(* ------------------------------------------------------------------ *) +(* Tier 0: bare idxvar patterns. RHS uses the idxvar as an int TERM + (dual namespace: the binding seeds both sides). *) +op sz {n} (v : vec<:n>) : int. +axiom szE {n} (v : vec<:n>) : sz v = n. +hint simplify szE. + +op v7 : vec<:7>. + +lemma t0_concrete : sz v7 = 7. +proof. by simplify. qed. + +lemma t0_symbolic {m} (v : vec<:m>) : sz v = m. +proof. by simplify. qed. + +(* ------------------------------------------------------------------ *) +(* Constant index patterns fire at that width only. *) +op c3 : vec<:3> -> int. +op cv {n} : vec<:n>. +axiom c3E : c3 cv = 42. +hint simplify c3E. + +lemma tc_fires : c3 cv = 42. +proof. by simplify. qed. + +(* ------------------------------------------------------------------ *) +(* Tier 1: affine pattern [n + 1]. [t] itself accepts any width; the + RULE is stated at [n + 1], so it fires only where the width has a + constant part of at least 1. *) +op t {k} (v : vec<:k>) : int. +axiom tE {n} (v : vec<:n+1>) : t v = 1. +hint simplify tE. + +op v8 : vec<:8>. + +lemma t1_concrete : t v8 = 1. +proof. by simplify. qed. + +lemma t1_symbolic {j} (v : vec<:j+1>) : t v = 1. +proof. by simplify. qed. + +(* bare symbolic width: nothing guarantees [m >= 1]; the rule must + NOT fire ([by simplify] then has nothing to close the goal with) *) +fail lemma t1_nofire {m} (v : vec<:m>) : t v = 1 by simplify. + +(* ------------------------------------------------------------------ *) +(* Repeated idxvar: bound at the first index position, checked by + canonical equality at the second. *) +op dd {n m} : int. +axiom ddE {n} : dd[:n, n] = 0. +hint simplify ddE. + +lemma tdup_fires : dd[:3, 3] = 0. +proof. by simplify. qed. + +fail lemma tdup_nofire : dd[:3, 4] = 0 by simplify. + +(* ------------------------------------------------------------------ *) +(* Declaration-time rejections. The messages (asserted manually -- + hierror embeds locations, so [expect fail] cannot exact-match): + - "index arguments in the left-hand side must be a constant, an + index variable `k', or `k + b' with `b' a constant" + - "index variable `n' is not bound by an index position of the + left-hand side" *) + +(* out of the affine fragment *) +op q {k} : int. +axiom qE {n} : q[:2 * n] = 0. +fail hint simplify qE. + +(* idxvar not recoverable from LHS index positions *) +op g0 : int. +axiom gE {n} : g0 = q[:n]. +fail hint simplify gE. + +(* ------------------------------------------------------------------ *) +(* Unindexed rules: unchanged behavior. *) +op u : int. +axiom uE : u = 5. +hint simplify uE. + +lemma tu : u = 5. +proof. by simplify. qed. diff --git a/tests/indexed-smt-defs.ec b/tests/indexed-smt-defs.ec new file mode 100644 index 000000000..e0f8427d2 --- /dev/null +++ b/tests/indexed-smt-defs.ec @@ -0,0 +1,46 @@ +(* Definitions of indexed operators reach the provers: an indexed op + with a plain body is exported as a standard Why3 definition, with + one bound [int] variable per idxvar (conservative, so no [0 <= i] + guard is needed). Before, every indexed op was opaque to smt and + definitional goals were silently unprovable. *) + +require import AllCore. + +type {n} vec. + +op sz {n} (v : vec<:n>) : int. + +(* the body uses the idxvar BOTH through an index position (sz's + index argument) and as an int term *) +op szp {n} (v : vec<:n>) : int = sz v + n. + +lemma t_symbolic {k} (v : vec<:k>) : szp v = sz v + k. +proof. smt(). qed. + +lemma t_concrete (v : vec<:5>) : szp v = sz v + 5. +proof. smt(). qed. + +(* predicates too *) +pred low {n} (v : vec<:n>) = sz v <= n. + +lemma t_pred {k} (v : vec<:k>) : sz v <= k => low v. +proof. smt(). qed. + +(* an indexed op used at a shifted width *) +lemma t_shift {k} (v : vec<:k+1>) : szp v = sz v + (k + 1). +proof. smt(). qed. + +(* matchfix over an indexed datatype: stays opaque, and the datatype + itself is not exported -- the goal punts and smt fails cleanly + (no anomaly) *) +type {n} 'a ivec = [ INil | ICons of 'a & 'a ivec<:n> ]. + +op hd {n} (d : int) (xs : int ivec<:n>) : int = + with xs = INil => d + with xs = ICons y _ => y. + +lemma t_fix_punts (xs : int ivec<:3>) : hd 0 xs = hd 0 xs. +proof. +fail smt(). +by []. +qed. diff --git a/tests/indexed-smt-guards.ec b/tests/indexed-smt-guards.ec new file mode 100644 index 000000000..fd8bcb157 --- /dev/null +++ b/tests/indexed-smt-guards.ec @@ -0,0 +1,51 @@ +(* SMT relativization guards for indexed types. + + The Why3 translation erases indices at the sort level (word<:3> and + word<:5> share one sort); soundness requires the index to be + recoverable at the term level: + - per-family width observers [size_k : t -> int]; + - quantifiers over head-indexed types are relativized + ([forall (x : t<:i>), P] ==> [forall x, size x = i => P]); + - lemma/goal idxvars are guarded by [0 <= n]; + - goal locals and operator results carry their width as facts. + + The two [fail smt] cases below were derivations of [false] before + the guards existed. *) + +require import AllCore List. +require import IArray. + +(* Honest width-0 instances of the IArray axioms. *) +lemma hsz0 (c : bool array<:0>) : size (ofarr c) = 0. +proof. by rewrite size_ofarr. qed. + +lemma hK0 (c : bool array<:0>) : mkarr (ofarr c) = c. +proof. by rewrite ofarrK. qed. + +lemma hnil (s : bool list) : size s = 0 => s = []. +proof. by rewrite size_eq0. qed. + +(* Sort erasure alone would let the width-0 lemmas constrain every + width, collapsing array<:1>. *) +lemma collapse (a b : bool array<:1>) : a = b. +proof. +fail smt(hsz0 hK0 hnil). +abort. + +(* An unguarded [forall n : int] quantification of ge0_index would + assert that every integer is non-negative. *) +lemma negboom (c : bool array<:1>) : false. +proof. +fail smt(ge0_index). +abort. + +(* The guards must not break legitimate reasoning: width-0 lemmas + still apply to width-0 goals (the goal local's size fact discharges + the relativization premise). *) +lemma ok0 (c : bool array<:0>) : ofarr c = []. +proof. smt(hsz0 hnil). qed. + +(* Symbolic-width goals keep working (idxvar 0 <= n facts + guarded + lemma instantiation at the symbolic width). *) +lemma oksym {n} (a : bool array<:n>) : 0 <= size (ofarr a). +proof. smt(size_ofarr ge0_index). qed. diff --git a/tests/indexed-type-alias.ec b/tests/indexed-type-alias.ec new file mode 100644 index 000000000..0940a2814 --- /dev/null +++ b/tests/indexed-type-alias.ec @@ -0,0 +1,20 @@ +(* Unfolding of indexed type aliases: [EcEnv.Ty.unfold] must + substitute the alias's index parameters, not only its type + parameters (a leaked formal index variable made [foo<:3>] fail to + unify with its own unfolding). *) + +type {n} 'a vec. + +type {n} 'a foo = 'a vec<:n>. + +(* alias <-> unfolding, concrete index *) +op test1 (x : int foo<:3>) : int vec<:3> = x. +op test2 (x : int vec<:3>) : int foo<:3> = x. + +(* symbolic index through an op's index parameter *) +op test3 {n} ['a] (x : 'a foo<:n>) : 'a vec<:n> = x. + +(* index arithmetic through the alias *) +op cons {n} ['a] (x : 'a) (xs : 'a vec<:n>) : 'a vec<:n+1>. +op test4 {n} ['a] (x : 'a) (xs : 'a foo<:n>) : 'a foo<:n+1> = + cons x xs. diff --git a/tests/indexed-types.ec b/tests/indexed-types.ec new file mode 100644 index 000000000..61e879cc1 --- /dev/null +++ b/tests/indexed-types.ec @@ -0,0 +1,358 @@ +(* -------------------------------------------------------------------- *) +(* Phase-3 Slice A — concrete syntax for indexed types. + Index binders use `{...}` and come first; type-variable binders + stay in `[...]`. Type-application indices 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. *) +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. + +(* 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. + +(* Phase 4 — cloning with index instantiation. *) +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>. + +(* 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>. + +(* 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. *) +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. + +(* Gap C — non-refining indexed datatypes and records. *) +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. *) +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. *) +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. + +(* 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 {n} ['a] (x : 'a) (xs : 'a vec<:n>) : + cons x xs = cons x xs. +proof. trivial. qed. + +lemma f_test5 {n} ['a] : + forall (x : 'a) (xs : 'a vec<:n>), cons x xs = cons x xs. +proof. move => x xs; trivial. qed. + +(* 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 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. + +(* 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. + +(* 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. + +(* 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. + +(* `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. + +(* 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. + +(* 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. + +(* Index non-negativity is not a binder marker: it is the enforced + naturals invariant, available as the [Int.ge0_index] axiom. *) +lemma idx_ge0_simple {n} : 0 <= n. +proof. exact ge0_index. qed. + +lemma idx_ge0_smt {m n} : 0 <= m + n. +proof. smt(ge0_index). qed. + +lemma idx_with_args {n} (xs : int vec<:n>) : 0 <= n. +proof. exact ge0_index. qed. + +(* 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. + +(* 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. + +(* `_` 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 + 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. by move=> ->. qed. + +(* ------------------------------------------------------------------ *) +(* section-declared indices: duplicates are rejected + (message: `duplicate declared index' -- hierror embeds locations, + so we do not exact-match it) *) +section. +declare index {k}. +fail declare index {k}. +end section. + +section. +fail declare index {k k}. +end section. + +(* ------------------------------------------------------------------ *) +(* nested `<: ... >` applications: the trailing `>>' lexes as one + operator token; the spaced form parses. (The unspaced form's + dedicated parse-error hint -- "`>>' is a single operator token: + separate the closing brackets" -- is asserted manually; parse + errors cannot be caught by [fail].) *) +type {n} 'a pvec. +op nw = witness<:int pvec<:3> >. + +(* ------------------------------------------------------------------ *) +(* section-declared indices carry NO automatic [0 <= n] premise; the + fact is obtained explicitly from Int.ge0_index. *) +section. +declare index {k}. +lemma sec_ge0k : 0 <= k + 1. +proof. by have := ge0_index[:k]; smt(). qed. +end section. diff --git a/tests/indexed-univar-close.ec b/tests/indexed-univar-close.ec new file mode 100644 index 000000000..07751455d --- /dev/null +++ b/tests/indexed-univar-close.ec @@ -0,0 +1,31 @@ +(* Close boundaries must resolve BOTH univar kinds (the closing API + returns a combined substitution; a type-only close is no longer + expressible). Regressions: dangling index univars used to persist + in abbrev bodies, checked proc bodies, and have-hypotheses. *) + +type {n} 'a vec. +op vinit {n} ['a] : 'a -> 'a vec<:n>. +op vsize {n} ['a] (v : 'a vec<:n>) : int = n. + +(* abbrev: the body's inferred index links to the binder *) +abbrev vz {n} : int vec<:n> = vinit 0. + +expect "* In [operators, predicates or exceptions]: + +abbrev vz {n} : int vec<:n> = vinit[:n] 0." by print vz. + +(* proc bodies persist with resolved indices *) +module M = { + proc f () : int vec<:3> = { + var a : int vec<:3>; + a <- vinit 0; + return a; + } +}. + +(* have-hypotheses store resolved indices and remain usable *) +lemma t (w : int vec<:5>) : vsize w = 5. +proof. +have h : vsize[:5]<:int> w = 5 by trivial. +apply h. +qed. diff --git a/tests/instance-family-shape.ec b/tests/instance-family-shape.ec new file mode 100644 index 000000000..8a86a532f --- /dev/null +++ b/tests/instance-family-shape.ec @@ -0,0 +1,52 @@ +(* Every instance operator records its own instantiation at the + carrier, so operators of ANY index shape fit: a predecessor-shaped + operator ([badz {n} : t<:n+1>] at carrier [t<:k+1>]) is recorded at + [k] and applied there. (This used to be rejected outright: the + old machinery applied every operator at the carrier's indices.) *) + +require import AllCore Ring. + +type {n} t. +op zer {n} : t<:n>. +op one {n} : t<:n>. +op add {n} (x y : t<:n>) : t<:n>. +op mul {n} (x y : t<:n>) : t<:n>. +op opp {n} (x : t<:n>) : t<:n>. + +(* predecessor-shaped zero *) +op zp {n} : t<:n+1>. + +axiom A_oner_neq0 {n} : one[:n+1] <> zp[:n]. +axiom A_addr0 {n} (x : t<:n+1>) : add x zp[:n] = x. +axiom A_addrA {n} (x y z : t<:n+1>) : add x (add y z) = add (add x y) z. +axiom A_addrC {n} (x y : t<:n+1>) : add x y = add y x. +axiom A_addrN {n} (x : t<:n+1>) : add x (opp x) = zp[:n]. +axiom A_mulr1 {n} (x : t<:n+1>) : mul x one = x. +axiom A_mulrA {n} (x y z : t<:n+1>) : mul x (mul y z) = mul (mul x y) z. +axiom A_mulrC {n} (x y : t<:n+1>) : mul x y = mul y x. +axiom A_mulrDl {n} (x y z : t<:n+1>) : mul (add x y) z = add (mul x z) (mul y z). + +instance ring [shp] with {k} t<:k+1> + op rzero = zp + op rone = one + op add = add + op mul = mul + op opp = opp + + proof oner_neq0 by exact (A_oner_neq0[:k]) + proof addr0 by exact (A_addr0[:k]) + proof addrA by exact (A_addrA[:k]) + proof addrC by exact (A_addrC[:k]) + proof addrN by exact (A_addrN[:k]) + proof mulr1 by exact (A_mulr1[:k]) + proof mulrA by exact (A_mulrA[:k]) + proof mulrC by exact (A_mulrC[:k]) + proof mulrDl by exact (A_mulrDl[:k]). + +(* the tactic fires with the predecessor-shaped zero *) +lemma shp_test {k} (x y : t<:k+1>) : + add x (add y (opp x)) = y. +proof. by ring [shp]. qed. + +lemma shp_concrete (x : t<:8>) : add x zp = x. +proof. by ring [shp]. qed. diff --git a/tests/iword.ec b/tests/iword.ec new file mode 100644 index 000000000..39fc16088 --- /dev/null +++ b/tests/iword.ec @@ -0,0 +1,17 @@ +require import AllCore. +require import IArray IWord. + +(* Symbolic width: XOR is an involutive abelian group. *) +lemma sym_xor_inv {n} (w : word<:n>) : w +^ w +^ w = w. +proof. by rewrite xorwK xorwC xorw0. qed. + +lemma sym_and_absorb {n} (w : word<:n>) : andw w w = w. +proof. by apply/andwK. qed. + +(* Out-of-range bits are false (the eclib convention). *) +lemma sym_get_out {n} (w : word<:n>) (i : int) : n <= i => w.[i] = false. +proof. by move=> hi; rewrite get_out // ltzNge hi. qed. + +(* Concrete width 64: same laws specialise. *) +lemma cn_xorC (w1 w2 : word<:64>) : w1 +^ w2 = w2 +^ w1. +proof. by apply/xorwC. qed. diff --git a/tests/iword_arith.ec b/tests/iword_arith.ec new file mode 100644 index 000000000..602d55b1f --- /dev/null +++ b/tests/iword_arith.ec @@ -0,0 +1,55 @@ +(* -------------------------------------------------------------------- *) +(* Tier-1 machine-word surface on top of [IWord]: bitwise [orw], the + arithmetic (ℤ/2ⁿ) ring via [to_uint] laws, unsigned/signed + comparisons, and shifts/rotates (as bit reindexings). *) +require import AllCore IntDiv IArray IWord. + +(* Bitwise OR. *) +lemma orwC_ {k} (a b : word<:k>) : orw a b = orw b a by apply orwC. + +(* Arithmetic: reason through [to_uint] (the machine-word idiom). *) +lemma addC_ {k} (a b : word<:k>) : to_uint (a + b) = to_uint (b + a). +proof. by rewrite !to_uintD addzC. qed. + +lemma mulC_ {k} (a b : word<:k>) : to_uint (a * b) = to_uint (b * a). +proof. by rewrite !to_uintM mulzC. qed. + +(* Comparisons. *) +lemma uleNgt_ {k} (a b : word<:k>) : (a \ule b) = !(b \ult a) by apply uleNgt. +lemma sltNge_ {k} (a b : word<:k>) : (a \slt b) = !(b \sle a) by apply sltNge. + +(* Shifts / rotates as bit reindexings. *) +lemma shr_ {k} (x : word<:k>) i j : 0 <= j < k => (x `>>>` i).[j] = x.[j + i] + by apply shrwE. +lemma rol_ {k} (x : word<:k>) i j : 0 <= j < k => (rol x i).[j] = x.[(j - i) %% k] + by apply rolwE. + +(* Shift <-> arithmetic (unsigned division / truncated multiplication). *) +lemma shr_uint {k} (x : word<:k>) i : + 0 <= i => to_uint (x `>>>` i) = to_uint x %/ 2 ^ i by apply to_uint_shr. +lemma shl_uint {k} (x : word<:k>) i : + 0 <= i => to_uint (x `<<<` i) = (to_uint x * 2 ^ i) %% 2 ^ k + by apply to_uint_shl. + +(* The underlying pure-integer bit-shift lemmas. *) +lemma bitM {k} (x j i : int) : 0 <= i => 0 <= j < k => + int_bit[:k] (x * 2 ^ i) j = (0 <= j - i < k /\ int_bit[:k] x (j - i)) + by apply int_bitMP. + +(* ------------------------------------------------------------------ *) +(* The predecessor-shaped [expr]/[ofint] slots (recorded per-op + instantiations): exponents and literals go through the instance's + own operators. *) +lemma warith_exp {k} (x : word<:k+1>) : + WRingA.exp x 2 = x * x. +proof. by ring [warith]. qed. + +(* literals in the theory's own vocabulary: the embed slot is + IWord.of_int, not the clone's WRingA.ofint *) +lemma warith_ofint {k} (x : word<:k+1>) : + x * of_int 2 = x + x. +proof. by ring [warith]. qed. + +lemma warith_exp8 (x y : word<:8>) : + WRingA.exp (x + y) 2 = WRingA.exp x 2 + x * y + x * y + WRingA.exp y 2. +proof. by ring [warith]. qed. diff --git a/tests/iword_num.ec b/tests/iword_num.ec new file mode 100644 index 000000000..8a0370abd --- /dev/null +++ b/tests/iword_num.ec @@ -0,0 +1,51 @@ +(* -------------------------------------------------------------------- *) +(* Unsigned/signed integer interpretation of indexed words, at symbolic + and concrete widths. Exercises the [get_to_uint] bit<->int bridge and + the round-trip lemmas from [IWord]. + + Also a regression for the SMT translation of symbolic indices: an + indexed type in scope (e.g. [w : word<:k>]) no longer poisons the goal + — the index is a first-class Why3 int, so [smt] reasons through it. *) +require import AllCore IntDiv IArray IWord. + +(* Symbolic width: round-trips and bounds. *) +lemma uintK {k} (w : word<:k>) : of_int (to_uint w) = w by apply to_uintK. +lemma uint_cmp {k} (w : word<:k>) : 0 <= to_uint w < 2 ^ k by apply to_uint_cmp. +lemma uintP {k} (w1 w2 : word<:k>) : + w1 = w2 <=> to_uint w1 = to_uint w2 by apply to_uint_eq. + +(* The bit <-> int bridge. *) +lemma bit_of_uint {k} (w : word<:k>) i : + w.[i] = (0 <= i < k /\ to_uint w %/ 2 ^ i %% 2 <> 0) by apply get_to_uint. + +(* Constants relate the bitwise and numeric views. *) +lemma z0 {k} : to_uint zerow[:k] = 0 by apply to_uint_zerow. +lemma o1 {k} : to_uint onew[:k] = 2 ^ k - 1 by apply to_uint_onew. + +(* ==================================================================== *) +(* SMT reaches through symbolic indices. *) + +(* A pure-int goal is provable even with an indexed-type local in scope + (this used to be skipped: "constructs not yet exported to Why3"). *) +lemma smt_thru {k} (w : word<:k+1>) : 0 <= k => 0 < k + 1. +proof. smt(). qed. + +(* [smt] uses an indexed-op fact at symbolic width. *) +lemma smt_uint {k} (w : word<:k>) : to_uint w < 2 ^ k. +proof. smt(to_uint_cmp). qed. + +lemma smt_uint2 {k} (w1 w2 : word<:k>) : + to_uint w1 = to_uint w2 => w1 = w2. +proof. smt(to_uint_eq). qed. + +(* Signed view (positive width). *) +lemma sint_cmp {k} (w : word<:k+1>) : 0 <= k => + - 2 ^ k <= to_sint w <= 2 ^ k - 1. +proof. +move=> ge0; have h := to_sint_cmp w _; first by smt(). +have e : 2 ^ (k + 1 - 1) = 2 ^ k by congr; ring. +by move: h; rewrite e. +qed. + +(* Concrete width. *) +lemma c8 (w : word<:8>) : 0 <= to_uint w < 2 ^ 8 by apply to_uint_cmp. diff --git a/tests/iword_ring.ec b/tests/iword_ring.ec new file mode 100644 index 000000000..830b57a16 --- /dev/null +++ b/tests/iword_ring.ec @@ -0,0 +1,37 @@ +(* -------------------------------------------------------------------- *) +(* The generic [Ring.BoolRing] instance over [word<:n+1>] (registered in + [IWord]) lets the [ring] tactic fire on any manifestly-nonzero word + width, without a per-width clone: symbolic ([word<:k+1>]) and concrete + ([word<:8>], [word<:64>]) alike. Instance resolution unifies the goal + width against [?i+1], which succeeds exactly when the width is provably + positive and refuses an arbitrary (possibly zero) [word<:m>]. *) +require import AllCore Bool Ring. +require import IArray IWord. + +(* Symbolic width. *) +lemma addwA {k} (a b c : word<:k+1>) : a +^ (b +^ c) = (a +^ b) +^ c by ring. +lemma andwC {k} (a b : word<:k+1>) : andw a b = andw b a by ring. +lemma andwDl {k} (a b c : word<:k+1>) : + andw a (b +^ c) = andw a b +^ andw a c by ring. + +(* Concrete widths. *) +lemma at8 (a b : word<:8>) : a +^ b = b +^ a by ring. +lemma at64 (a b : word<:64>) : andw a (andw b a) = andw (andw a b) a by ring. + +(* ------------------------------------------------------------------ *) +(* The NAMED arithmetic instance: [ring [warith]] selects ℤ/2ⁿ even + though the boolean instance is registered first on the same + carrier (review finding: the arithmetic structure was unreachable). *) + +lemma arith_comm8 (a b : word<:8>) : a + b = b + a. +proof. by ring [warith]. qed. + +lemma arith_distr8 (a b c : word<:8>) : a * (b + c) = a * b + a * c. +proof. by ring [warith]. qed. + +lemma arith_symb {k} (a b : word<:k+1>) : a + b = b + a. +proof. by ring [warith]. qed. + +(* bare [ring] still selects the boolean structure *) +lemma bool_still8 (a b : word<:8>) : a +^ b = b +^ a. +proof. by ring. qed. diff --git a/tests/named-index-instantiation.ec b/tests/named-index-instantiation.ec new file mode 100644 index 000000000..5c350c690 --- /dev/null +++ b/tests/named-index-instantiation.ec @@ -0,0 +1,168 @@ +(* Named (possibly partial) index instantiation, and its interaction + with named type-variable instantiation: `f[:n = 3, m = 4]<:'a = int>`. + The index and type sides are independent: each may be positional + or named. *) + +type {n} 'a vec. + +op f {n m} ['a, 'b] : 'a -> 'b -> bool. +op cat {n m} ['a] : 'a vec<:n> -> 'a vec<:m> -> 'a vec<:n+m>. + +(* both sides named *) +op g1 = f[:n = 3, m = 4]<:'a = int, 'b = real>. + +(* named indices, positional types *) +op g2 = f[:n = 3, m = 4]<:int, real>. + +(* positional indices, named types (rejected by the parser before) *) +op g3 = f[:3, 4]<:'a = int, 'b = real>. + +(* named indices need not follow declaration order *) +op g4 = f[:m = 4, n = 3]<:int, real>. + +(* partial named instantiation: [m] is inferred from the arguments *) +op g5 (u : int vec<:3>) (v : int vec<:5>) : int vec<:8> = + cat[:n = 3] u v. + +(* lemma-side named instantiation *) +lemma vec_refl {n} ['a] (u : 'a vec<:n>) : u = u. +proof. trivial. qed. + +lemma t1 (u : int vec<:7>) : u = u. +proof. apply (vec_refl[:n = 7]<:'a = int>). qed. + +(* partial named instantiation on a lemma: [n] inferred *) +lemma t2 (u : bool vec<:5>) : u = u. +proof. apply (vec_refl<:'a = bool>). qed. + +(* ------------------------------------------------------------------ *) +(* error paths *) + +(* duplicate named index *) +expect fail "an index variable appears at least twice: `n'" +op b1 = f[:n = 1, n = 2]<:int, real>. + +(* unknown index name on a lemma *) +lemma t3 (u : int vec<:7>) : u = u. +proof. +expect fail "unknown index variable: p" +apply (vec_refl[:p = 7]<:'a = int>). +apply (vec_refl[:n = 7]<:'a = int>). +qed. + +(* wrong positional index arity on a lemma *) +lemma t4 (u : int vec<:7>) : u = u. +proof. +expect fail "wrong number of index parameters (2, expecting 1)" +apply (vec_refl[:1, 2]<:'a = int>). +apply (vec_refl[:n = 7]<:'a = int>). +qed. + +(* unknown named type variable on a lemma (pre-existing check) *) +lemma t5 (u : int vec<:7>) : u = u. +proof. +expect fail "unknown type variable: 'c" +apply (vec_refl[:n = 7]<:'c = int>). +apply (vec_refl[:n = 7]<:'a = int>). +qed. + +(* ------------------------------------------------------------------ *) +(* printing: explicit indices survive in printed bodies (#1065, c2) *) + +expect "* In [operators, predicates or exceptions]: + +op g1 : int -> real -> bool = f[:3, 4]<:int, real>." by print g1. + +(* index inferable from the arguments: annotation stays suppressed *) +op vhead {n} ['a] : 'a vec<:n+1> -> 'a. +op vuse (u : int vec<:8>) : int = vhead u. + +expect "* In [operators, predicates or exceptions]: + +op vuse (u : int vec<:8>) : int = vhead u." by print vuse. + +(* index not inferable from arguments: printed *) +op vzero {n} ['a] : 'a vec<:n>. +op z5 : int vec<:5> = vzero. + +expect "* In [operators, predicates or exceptions]: + +op z5 : int vec<:5> = vzero[:5]<:int>." by print z5. + +(* ------------------------------------------------------------------ *) +(* diagnostics for bad instantiations (#1065, c3/c4): incompatible *) +(* explicit instantiations are classified per candidate instead of *) +(* degenerating to "unknown variable or constant" *) + +(* omitted indices: uninferrable index univars at declaration close. + (The message is `cannot infer all index parameters of this operator; + supply them explicitly (e.g. \`f[:n = 3]')' -- raised through hierror, + whose printed form embeds the location, so only failure is asserted.) *) +fail op b3 = f<:int, real>. + +(* same condition through the tactic path (tyerror prints bare) *) +lemma t6 : true. +proof. +expect fail "cannot infer all index parameters in this expression; supply them explicitly (e.g. `f[:n = 3]')" +have ? : f<:int, int> 0 0. +trivial. +qed. + +(* indices under +/* in an argument type are NOT recoverable from the + argument and must stay printed (review finding: goal display + collapsed distinct instantiations of compound-index ops) *) +op g {n m} (v : int vec<:n + m>) : int. +op v7 : int vec<:7>. +op p1 : int = g[:3, 4] v7. + +expect "* In [operators, predicates or exceptions]: + +op p1 : int = Top.g[:3, 4] v7." by print p1. + +(* diagnostics: index mismatches report honestly *) +op vv3 : int vec<:3>. + +expect fail "incompatible index arguments: `5' vs `3'" +module DM = { + proc f () : unit = { + var a : int vec<:5>; + a <- vv3; + } +}. + +(* subtraction in index position: dedicated parse error with hint + (`index expressions range over the naturals: subtraction is not + available') -- asserted manually; parse errors embed locations *) + +(* ------------------------------------------------------------------ *) +(* named index instantiation at TYPE applications (`t<:n = 3>`), + mirroring the op-site `f[:n = 3]` form: any order, partial. *) +type {tn tm} ('a, 'b) tmat. + +op tm1 : (int, bool) tmat<:tn = 3, tm = 5>. +op tm2 : (int, bool) tmat<:tm = 5, tn = 3> = tm1. (* swapped order *) +op tm3 : (int, bool) tmat<:3, 5> = tm2. (* = positional *) +op tm4 : (int, bool) tmat<:tn = 3> = tm3. (* partial: tm inferred *) + +expect fail "type `tmat' has no index parameter named `tk'" +op tbad1 : (int, bool) tmat<:tk = 3, tm = 5>. + +expect fail "an index variable appears at least twice: `tn'" +op tbad2 : (int, bool) tmat<:tn = 3, tn = 5>. + +(* ------------------------------------------------------------------ *) +(* both annotation orders are accepted: `f[:3]<:int>' and + `f<:int>[:3]', in positional and named form *) +op both {bn} ['a] : int. +op bo1 = both[:3]<:int>. +op bo2 = both<:int>[:3]. +op bo3 = both<:int>[:bn = 3]. +op bo4 = both[:bn = 3]<:'a = int>. +lemma bo_all : bo1 = bo2 /\ bo2 = bo3 /\ bo3 = bo4. +proof. by rewrite /bo1 /bo2 /bo3 /bo4. qed. + +(* mixed positional/named lists are rejected intentionally, on both + sides, with located messages (asserted manually -- parse errors + cannot be caught by [fail]): + g[:3, m = 4] -> "cannot mix positional and named index arguments" + h<:int, 'b = bool> -> "cannot mix positional and named type arguments" *) diff --git a/tests/op-application-errors.ec b/tests/op-application-errors.ec index a46582d1d..af1db2653 100644 --- a/tests/op-application-errors.ec +++ b/tests/op-application-errors.ec @@ -41,8 +41,12 @@ op bad_result : int = h 0. expect fail "operator `Top.List.filter' cannot be applied to arguments of type: [1]: int -> int [2]: int list +its type is + ('a -> bool) -> 'a list -> 'a list +where the type parameters were inferred as: + 'a = int its #1 argument is expected to have type - #a -> bool + int -> bool but is applied to a value of type int -> int" op bad_arg (s : int list) : int list = @@ -288,3 +292,43 @@ expect fail "no matching operator, named `List.frobnicate', for the following pa op unknown (s : int list) : int list = List.frobnicate s. +(* --- explicit index / type-parameter instantiations ---------------- *) + +type {k} 'a ivec. + +op ixop {n m} ['a, 'b] : 'a -> 'b -> bool. +op ivcat {n m} ['a] : 'a ivec<:n> -> 'a ivec<:m> -> 'a ivec<:n+m>. + +expect fail "operator `Top.ixop' cannot be applied: +it takes 2 index parameter(s) but is given 1" +op b1 = ixop[:3]<:int, real>. + +expect fail "operator `Top.ixop' cannot be applied: +it has no index parameter named `p'" +op b2 = ixop[:p = 3]<:int, real>. + +expect fail "operator `Top.ixop' cannot be applied: +it has no type parameter named `'c'" +op b3 = ixop<:'c = int>. + +expect fail "operator `Top.ixop' cannot be applied: +it takes 2 type parameter(s) but is given 1" +op b4 = ixop[:3, 4]<:int>. + +(* inferred index parameters are reported on application failures *) +expect fail "operator `Top.ivcat' cannot be applied to arguments of type: + [1]: int ivec<:3> + [2]: int ivec<:5> +its type is + 'a ivec<:n> -> 'a ivec<:m> -> 'a ivec<:n + m> +where the index parameters were inferred as: + n = 3 + m = 5 +where the type parameters were inferred as: + 'a = int +it returns a value of type + int ivec<:3 + 5> +but a value of type + int ivec<:9> +was expected" +op b5 (u : int ivec<:3>) (v : int ivec<:5>) : int ivec<:9> = ivcat u v. diff --git a/tests/ring-poly-instance.ec b/tests/ring-poly-instance.ec new file mode 100644 index 000000000..2968f4327 --- /dev/null +++ b/tests/ring-poly-instance.ec @@ -0,0 +1,66 @@ +(* Type-polymorphic ring instances (per-slot recorded instantiations: + the instance's tyvars rebind at the matched carrier, like indices). *) + +require import AllCore Ring. + +(* type-polymorphic carrier: the pointwise-integer function ring *) +op fzero ['a] : 'a -> int = fun _ => 0. +op fone ['a] : 'a -> int = fun _ => 1. +op fadd ['a] (f g : 'a -> int) : 'a -> int = fun x => f x + g x. +op fmul ['a] (f g : 'a -> int) : 'a -> int = fun x => f x * g x. +op fopp ['a] (f : 'a -> int) : 'a -> int = fun x => - f x. + +lemma L_oner_neq0 ['a] : fone<:'a> <> fzero. +proof. by apply/negP=> /fun_ext /(_ witness). qed. + +lemma L_addr0 ['a] (f : 'a -> int) : fadd f fzero = f. +proof. by apply/fun_ext=> x; rewrite /fadd /fzero. qed. + +lemma L_addrA ['a] (f g h : 'a -> int) : + fadd f (fadd g h) = fadd (fadd f g) h. +proof. by apply/fun_ext=> x; rewrite /fadd /#. qed. + +lemma L_addrC ['a] (f g : 'a -> int) : fadd f g = fadd g f. +proof. by apply/fun_ext=> x; rewrite /fadd /#. qed. + +lemma L_addrN ['a] (f : 'a -> int) : fadd f (fopp f) = fzero. +proof. by apply/fun_ext=> x; rewrite /fadd /fopp /fzero /#. qed. + +lemma L_mulr1 ['a] (f : 'a -> int) : fmul f fone = f. +proof. by apply/fun_ext=> x; rewrite /fmul /fone /#. qed. + +lemma L_mulrA ['a] (f g h : 'a -> int) : + fmul f (fmul g h) = fmul (fmul f g) h. +proof. by apply/fun_ext=> x; rewrite /fmul /#. qed. + +lemma L_mulrC ['a] (f g : 'a -> int) : fmul f g = fmul g f. +proof. by apply/fun_ext=> x; rewrite /fmul /#. qed. + +lemma L_mulrDl ['a] (f g h : 'a -> int) : + fmul (fadd f g) h = fadd (fmul f h) (fmul g h). +proof. by apply/fun_ext=> x; rewrite /fadd /fmul /#. qed. + +instance ring [pfun] with ['a] ('a -> int) + op rzero = fzero + op rone = fone + op add = fadd + op mul = fmul + op opp = fopp + + proof oner_neq0 by exact L_oner_neq0 + proof addr0 by exact L_addr0 + proof addrA by exact L_addrA + proof addrC by exact L_addrC + proof addrN by exact L_addrN + proof mulr1 by exact L_mulr1 + proof mulrA by exact L_mulrA + proof mulrC by exact L_mulrC + proof mulrDl by exact L_mulrDl. + +lemma pf_test ['a] (f g : 'a -> int) : + fadd f (fadd g (fopp f)) = g. +proof. by ring [pfun]. qed. + +lemma pf_bool (f g : bool -> int) : + fmul f g = fmul g f. +proof. by ring [pfun]. qed. diff --git a/theories/algebra/IntDiv.ec b/theories/algebra/IntDiv.ec index 8e6f9ef27..06639d556 100644 --- a/theories/algebra/IntDiv.ec +++ b/theories/algebra/IntDiv.ec @@ -1460,6 +1460,24 @@ by rewrite -mulNr mulrA divzMDr 1:expf_eq0 // mulNr addrC divzMl 1,2:expr_ge0. qed. *) +(* -------------------------------------------------------------------- *) +(* Range facts packaging [edivzP]/[ltz_divLR] in the forms bit-level + developments consume (cf. IWord). *) +lemma gt0_pow2 (k : int) : 0 < 2 ^ k. +proof. by rewrite expr_gt0. qed. + +lemma dvd2_pow2 (m : int) : 1 <= m => 2 %| 2 ^ m. +proof. by move=> hm; rewrite -{1}expr1 dvdz_exp2l /#. qed. + +lemma modz_cmp (m d : int) : 0 < d => 0 <= m %% d < d. +proof. smt(edivzP). qed. + +lemma divz_cmp (d i m : int) : 0 < d => 0 <= i < m * d => 0 <= i %/ d < m. +proof. by move=> hd [hi1 hi2]; rewrite divz_ge0 // hi1 /= ltz_divLR. qed. + +lemma bound_abs (i j : int) : 0 <= i < j => 0 <= i < `|j|. +proof. smt(). qed. + (* -------------------------------------------------------------------- *) require import Real. diff --git a/theories/datatypes/IArray.ec b/theories/datatypes/IArray.ec new file mode 100644 index 000000000..c81ae76fa --- /dev/null +++ b/theories/datatypes/IArray.ec @@ -0,0 +1,171 @@ +(* -------------------------------------------------------------------- *) +(* Length-indexed arrays. [ 'a array<:n> ] is the type of arrays of [ 'a ] + of length [n]; the length lives in the index rather than in a runtime + [size] field. Indexed counterpart of [Array.ec] (subsuming [Word.eca]). + + The derived operators and lemmas live in a [declare index {n}] section, so they + are written without a [{n}] binder and get one back on section close. + Proofs that need [0 <= n] obtain it explicitly from [Int.ge0_index]. *) + +require import AllCore List. + +(* -------------------------------------------------------------------- *) +(* Signature: the indexed type and its reflection to lists. Model for + the three axioms: ['a array<:n>] IS the length-[n] ['a list]s, with + [ofarr]/[mkarr] the identity (and [mkarr] arbitrary off-length). *) +type {n} 'a array. + +op ofarr {n} ['a] (a : 'a array<:n>) : 'a list. +op mkarr {n} ['a] (s : 'a list) : 'a array<:n>. + +axiom size_ofarr {n} ['a] (a : 'a array<:n>) : + size (ofarr a) = n. + +axiom ofarrK {n} ['a] (a : 'a array<:n>) : + mkarr (ofarr a) = a. + +axiom mkarrK {n} ['a] (s : 'a list) : + size s = n => ofarr (mkarr[:n] s) = s. + +(* ==================================================================== *) +section IArray. +declare index {n}. + +(* -------------------------------------------------------------------- *) +(* Single-head accessors, [opaque] as in Array.ec: the lemmas below are + the interface; simplify/delta do not see the list model. *) +op [opaque] "_.[_]" ['a] (a : 'a array<:n>) (i : int) : 'a = + nth witness (ofarr a) i. + +op [opaque] "_.[_<-_]" ['a] (a : 'a array<:n>) (i : int) (x : 'a) : 'a array<:n> = + mkarr (mkseq (fun k => if i = k then x else a.[k]) n). + +(* -------------------------------------------------------------------- *) +lemma getE ['a] (a : 'a array<:n>) i : + a.[i] = nth witness (ofarr a) i. +proof. by rewrite /"_.[_]". qed. + +lemma get_neg ['a] (a : 'a array<:n>) (i : int) : + i < 0 => a.[i] = witness. +proof. by rewrite getE; apply/nth_neg. qed. + +lemma get_default ['a] (a : 'a array<:n>) (i : int) : + n <= i => a.[i] = witness. +proof. by rewrite getE -(size_ofarr a); apply/nth_default. qed. + +lemma eq_from_get ['a] (a1 a2 : 'a array<:n>) : + (forall i, 0 <= i < n => a1.[i] = a2.[i]) => a1 = a2. +proof. +move=> eq_get; rewrite -(ofarrK a1) -(ofarrK a2); congr. +apply/(eq_from_nth witness); first by rewrite !size_ofarr. +by move=> i; rewrite (size_ofarr a1) -!getE => /eq_get. +qed. + +lemma arrayP ['a] (a1 a2 : 'a array<:n>) : + (a1 = a2) <=> (forall i, 0 <= i < n => a1.[i] = a2.[i]). +proof. by split=> [-> //|]; apply/eq_from_get. qed. + +lemma ofarr_inj ['a] (a1 a2 : 'a array<:n>) : + ofarr a1 = ofarr a2 => a1 = a2. +proof. by move=> h; rewrite -(ofarrK a1) -(ofarrK a2) h. qed. + +(* [mkarr] is injective on length-[n] lists only (off-length lists are + mapped arbitrarily). *) +lemma mkarr_pinj ['a] (s1 s2 : 'a list) : + size s1 = n => size s2 = n => + mkarr[:n] s1 = mkarr[:n] s2 => s1 = s2. +proof. by move=> h1 h2 h; rewrite -(mkarrK[:n] s1) // -(mkarrK[:n] s2) // h. qed. + +lemma arrayW ['a] (P : 'a array<:n> -> bool) : + (forall s, size s = n => P (mkarr s)) => forall a, P a. +proof. by move=> ih a; rewrite -(ofarrK a); apply/ih; rewrite size_ofarr. qed. + +(* -------------------------------------------------------------------- *) +lemma setE ['a] (a : 'a array<:n>) (i : int) (x : 'a) : + a.[i <- x] = mkarr (mkseq (fun k => if i = k then x else a.[k]) n). +proof. by rewrite /"_.[_<-_]". qed. + +lemma get_set_if ['a] (a : 'a array<:n>) (x : 'a) (i j : int) : + a.[i <- x].[j] = if 0 <= i < n /\ j = i then x else a.[j]. +proof. +have ge0n := ge0_index[:n]; rewrite getE setE mkarrK. +- by rewrite size_mkseq; clear a; smt(). +rewrite nth_mkseq_if /= !getE. +move: (size_ofarr a); move: (ofarr a) => s hs; clear a. +smt(nth_neg nth_default). +qed. + +lemma get_set ['a] (a : 'a array<:n>) (x : 'a) (i j : int) : + 0 <= i < n => a.[i <- x].[j] = if j = i then x else a.[j]. +proof. by move=> lt_in; rewrite get_set_if lt_in. qed. + +lemma set_out ['a] (i : int) (x : 'a) (a : 'a array<:n>) : + ! (0 <= i < n) => a.[i <- x] = a. +proof. +move=> Nlt_in; apply/eq_from_get=> j lt_jn. +by rewrite get_set_if Nlt_in. +qed. + +lemma set_neg ['a] (i : int) (y : 'a) (a : 'a array<:n>) : + i < 0 => a.[i <- y] = a. +proof. by move=> lt0_i; rewrite set_out // lezNgt lt0_i. qed. + +lemma set_above ['a] (i : int) (y : 'a) (a : 'a array<:n>) : + n <= i => a.[i <- y] = a. +proof. by move=> le_ni; rewrite set_out // ltzNge le_ni. qed. + +lemma set_set_if ['a] (a : 'a array<:n>) (k k' : int) (x x' : 'a) : + a.[k <- x].[k' <- x'] + = if k = k' + then a.[k' <- x'] + else a.[k' <- x'].[k <- x]. +proof. +apply/eq_from_get=> i lt_in; case: (0 <= k < n)=> [lt_kn|Nk]; last first. +- by rewrite !(set_out k) //; case: (k = k'). +case: (0 <= k' < n)=> [lt_k'n|Nk']; last first. +- by rewrite !(set_out k') //; case: (k = k'). +rewrite fun_if2 !get_set //. +case: (k = k')=> [->>|]; first by case: (i = k'). +by case: (i = k')=> //; case: (i = k). +qed. + +lemma set_set_eq ['a] (a : 'a array<:n>) (k : int) (x x' : 'a) : + a.[k <- x].[k <- x'] = a.[k <- x']. +proof. by rewrite set_set_if. qed. + +lemma set_set_swap ['a] (a : 'a array<:n>) (k k' : int) (x x' : 'a) : + k <> k' => a.[k <- x].[k' <- x'] = a.[k' <- x'].[k <- x]. +proof. by rewrite set_set_if=> ->. qed. + +(* -------------------------------------------------------------------- *) +op offun ['a] (f : int -> 'a) : 'a array<:n> = + mkarr (mkseq f n). + +lemma offunifE ['a] (f : int -> 'a) i : + (offun f).[i] = if 0 <= i < n then f i else witness. +proof. +have ge0n := ge0_index[:n]; rewrite getE /offun mkarrK; first by rewrite size_mkseq; smt(). +by rewrite nth_mkseq_if. +qed. + +lemma offunE ['a] (f : int -> 'a) i : + 0 <= i < n => (offun f).[i] = f i. +proof. by move=> lt_in; rewrite offunifE lt_in. qed. + +(* -------------------------------------------------------------------- *) +op map ['a 'b] (f : 'a -> 'b) (a : 'a array<:n>) : 'b array<:n> = + mkarr (List.map f (ofarr a)). + +lemma mapE ['a 'b] (f : 'a -> 'b) (a : 'a array<:n>) i : + 0 <= i < n => (map f a).[i] = f a.[i]. +proof. +move=> lt_in; rewrite getE /map mkarrK. +- by rewrite size_map size_ofarr. +by rewrite (nth_map witness) ?size_ofarr // -getE. +qed. + +lemma map_comp ['a 'b 'c] (g : 'b -> 'c) (f : 'a -> 'b) (a : 'a array<:n>) : + map (g \o f) a = map g (map f a). +proof. by rewrite /map map_comp mkarrK // size_map size_ofarr. qed. + +end section IArray. diff --git a/theories/datatypes/IWord.ec b/theories/datatypes/IWord.ec new file mode 100644 index 000000000..93ec2602d --- /dev/null +++ b/theories/datatypes/IWord.ec @@ -0,0 +1,764 @@ +(* -------------------------------------------------------------------- *) +(* Length-indexed bit words, built on top of [IArray]: a [ word<:n> ] wraps + a [ bool array<:n> ] but reads [false] out of range (like [BitWord.eca]). + The width [n] lives in the index; the derived layer is developed in a + [declare index {n}] section (so ops/lemmas drop their [{n}] binder). + + Not yet ported (vs BitWord.eca / Jasmin's JWord): + - the uniform distribution (DWord) -- blocked on an indexed + counterpart of FinType/Distr; + - division/remainder ([\udiv], [\umod], [\sdiv], [\smod]); + - the [sar] law kit and JWord's [rol_xor] shift tricks; + - richer [int_bit] machinery (splitting/recombination lemmas). *) + +require import AllCore Bool IntDiv Ring StdOrder List BitEncoding. +import BS2Int. +require import IArray. + +(* -------------------------------------------------------------------- *) +(* Signature. *) +type {n} word. + +(* Model for the two axioms: [word<:n>] IS [bool array<:n>] (i.e. + length-[n] bool lists), [ofword]/[mkword] the identity. *) +op ofword {n} (w : word<:n>) : bool array<:n>. +op mkword {n} (a : bool array<:n>) : word<:n>. + +axiom ofwordK {n} (w : word<:n>) : mkword (ofword w) = w. +axiom mkwordK {n} (a : bool array<:n>) : ofword (mkword[:n] a) = a. + +(* ==================================================================== *) +section IWord. +declare index {n}. + +(* Out-of-range bits read as [false]. *) +op "_.[_]" (w : word<:n>) (i : int) : bool = + if 0 <= i < n then (ofword w).[i] else false. + +lemma getE (w : word<:n>) i : + w.[i] = if 0 <= i < n then (ofword w).[i] else false. +proof. by rewrite /"_.[_]". qed. + +lemma get_in (w : word<:n>) i : + 0 <= i < n => w.[i] = (ofword w).[i]. +proof. by move=> hi; rewrite getE (ifT _ _ _ hi). qed. + +lemma get_out (w : word<:n>) i : + !(0 <= i < n) => w.[i] = false. +proof. by move=> hi; rewrite getE (ifF _ _ _ hi). qed. + +(* -------------------------------------------------------------------- *) +lemma wordP (w1 w2 : word<:n>) : + (forall i, 0 <= i < n => w1.[i] = w2.[i]) <=> w1 = w2. +proof. +split=> [eqi|-> //]; rewrite -(ofwordK w1) -(ofwordK w2); congr. +apply/IArray.eq_from_get=> i hi; move: (eqi i hi). +by rewrite !getE hi. +qed. + +lemma ofword_inj (w1 w2 : word<:n>) : + ofword w1 = ofword w2 => w1 = w2. +proof. by move=> h; rewrite -(ofwordK w1) -(ofwordK w2) h. qed. + +(* [mkwordK] is unconditional, so [mkword] is genuinely injective + (unlike the subtype-based Word.eca, whose mkword collapses + off-size lists). *) +lemma mkword_inj (a1 a2 : bool array<:n>) : + mkword[:n] a1 = mkword[:n] a2 => a1 = a2. +proof. by move=> h; rewrite -(mkwordK[:n] a1) -(mkwordK[:n] a2) h. qed. + +lemma wordW (P : word<:n> -> bool) : + (forall a, P (mkword a)) => forall w, P w. +proof. by move=> ih w; rewrite -(ofwordK w); apply/ih. qed. + +(* -------------------------------------------------------------------- *) +(* Bit-set, delegated to IArray's set layer. *) +op "_.[_<-_]" (w : word<:n>) (i : int) (b : bool) : word<:n> = + mkword ((ofword w).[i <- b]). + +lemma setE (w : word<:n>) (i : int) (b : bool) : + w.[i <- b] = mkword ((ofword w).[i <- b]). +proof. by rewrite /"_.[_<-_]". qed. + +lemma get_set_if (w : word<:n>) (x : bool) (i j : int) : + w.[i <- x].[j] = if 0 <= i < n /\ j = i then x else w.[j]. +proof. +rewrite getE setE mkwordK; case: (0 <= j < n) => hj. ++ by rewrite IArray.get_set_if getE; smt(). ++ by rewrite getE hj /=; smt(). +qed. + +lemma get_set (w : word<:n>) (x : bool) (i j : int) : + 0 <= i < n => w.[i <- x].[j] = if j = i then x else w.[j]. +proof. by move=> lt_in; rewrite get_set_if lt_in. qed. + +lemma set_out (i : int) (x : bool) (w : word<:n>) : + ! (0 <= i < n) => w.[i <- x] = w. +proof. by move=> Nlt_in; rewrite setE IArray.set_out // ofwordK. qed. + +lemma set_neg (i : int) (a : bool) (w : word<:n>) : + i < 0 => w.[i <- a] = w. +proof. by move=> lt0_i; rewrite set_out // lezNgt lt0_i. qed. + +lemma set_above (i : int) (a : bool) (w : word<:n>) : + n <= i => w.[i <- a] = w. +proof. by move=> le_ni; rewrite set_out // ltzNge le_ni. qed. + +lemma set_set_if (w : word<:n>) (k k' : int) (x x' : bool) : + w.[k <- x].[k' <- x'] + = if k = k' + then w.[k' <- x'] + else w.[k' <- x'].[k <- x]. +proof. +by apply/wordP=> i hi; case: (k = k') => h; rewrite !get_set_if; smt(). +qed. + +lemma set_set_eq (w : word<:n>) (k : int) (x x' : bool) : + w.[k <- x].[k <- x'] = w.[k <- x']. +proof. by rewrite set_set_if. qed. + +lemma set_set_swap (w : word<:n>) (k k' : int) (x x' : bool) : + k <> k' => w.[k <- x].[k' <- x'] = w.[k' <- x'].[k <- x]. +proof. by rewrite set_set_if => ->. qed. + +(* -------------------------------------------------------------------- *) +op offunw (f : int -> bool) : word<:n> = mkword (offun[:n] f). + +lemma offunwE (f : int -> bool) i : + (offunw f).[i] = if 0 <= i < n then f i else false. +proof. +rewrite getE /offunw mkwordK. +by case: (0 <= i < n) => hi //=; rewrite offunE. +qed. + +(* -------------------------------------------------------------------- *) +op zerow : word<:n> = offunw (fun _ => false). +op onew : word<:n> = offunw (fun _ => true). + +op ( +^ ) (w1 w2 : word<:n>) : word<:n> = + offunw (fun i => w1.[i] ^^ w2.[i]). + +op andw (w1 w2 : word<:n>) : word<:n> = + offunw (fun i => w1.[i] /\ w2.[i]). + +op oppw (w : word<:n>) : word<:n> = w. + +op orw (w1 w2 : word<:n>) : word<:n> = + offunw (fun i => w1.[i] \/ w2.[i]). + +op invw (w : word<:n>) : word<:n> = + offunw (fun i => !w.[i]). + +(* -------------------------------------------------------------------- *) +lemma zerowE i : (zerow).[i] = false. +proof. by rewrite offunwE if_same. qed. + +lemma onewE i : (onew).[i] = (0 <= i < n). +proof. by rewrite offunwE; case: (0 <= i < n). qed. + +lemma xorwE (w1 w2 : word<:n>) i : + (w1 +^ w2).[i] = w1.[i] ^^ w2.[i]. +proof. +rewrite offunwE; case: (0 <= i < n) => hi //=. +by rewrite !get_out // xor_false. +qed. + +lemma andwE (w1 w2 : word<:n>) i : + (andw w1 w2).[i] = (w1.[i] /\ w2.[i]). +proof. +rewrite offunwE; case: (0 <= i < n) => hi //=. +by rewrite !get_out. +qed. + +lemma orwE (w1 w2 : word<:n>) i : + (orw w1 w2).[i] = (w1.[i] \/ w2.[i]). +proof. +rewrite offunwE; case: (0 <= i < n) => hi //=. +by rewrite !get_out. +qed. + +lemma invwE (w : word<:n>) i : + 0 <= i < n => (invw w).[i] = !w.[i]. +proof. by move=> hi; rewrite offunwE hi. qed. + +lemma oppwE (w : word<:n>) i : (oppw w).[i] = w.[i]. +proof. by rewrite /oppw. qed. + +lemma oppwK (w : word<:n>) : oppw w = w. +proof. by rewrite /oppw. qed. + +hint rewrite bwordE : zerowE onewE xorwE andwE orwE invwE. + +(* -------------------------------------------------------------------- *) +lemma onew_neq0 : 0 < n => onew <> zerow. +proof. +move=> gt0n; apply/negP => /wordP /(_ 0). +by rewrite !bwordE /= gt0n. +qed. + +lemma xorw0 : right_id zerow ( +^ ). +proof. by move=> w; apply/wordP=> i _; rewrite !bwordE xor_false. qed. + +lemma xorwA : associative (( +^ )). +proof. by move=> w1 w2 w3; apply/wordP=> i _; rewrite !bwordE xorA. qed. + +lemma xorwC : commutative (( +^ )). +proof. by move=> w1 w2; apply/wordP=> i _; rewrite !bwordE xorC. qed. + +lemma xorwK (w : word<:n>) : w +^ w = zerow. +proof. by apply/wordP=> i _; rewrite !bwordE xorK. qed. + +lemma andw1 : right_id onew andw. +proof. by move=> w; apply/wordP=> i h; rewrite !bwordE h. qed. + +lemma andwA : associative (andw). +proof. by move=> w1 w2 w3; apply/wordP=> i h; rewrite !bwordE andbA. qed. + +lemma andwC : commutative (andw). +proof. by move=> w1 w2; apply/wordP=> i h; rewrite !bwordE andbC. qed. + +lemma andwK : idempotent (andw). +proof. by move=> w; apply/wordP=> i h; rewrite !bwordE andbb. qed. + +lemma andwDl : left_distributive (andw) ( +^ ). +proof. +move=> w1 w2 w3; apply/wordP=> i h; rewrite !bwordE. +by move: (w1.[i]) (w2.[i]) (w3.[i]) => b1 b2 b3; case: b1; case: b2; case: b3. +qed. + +lemma andw0 (w : word<:n>) : andw w zerow = zerow. +proof. by apply/wordP=> i _; rewrite !bwordE andbF. qed. + +lemma orwA : associative (orw). +proof. by move=> w1 w2 w3; apply/wordP=> i _; rewrite !bwordE orbA. qed. + +lemma orwC : commutative (orw). +proof. by move=> w1 w2; apply/wordP=> i _; rewrite !bwordE orbC. qed. + +lemma orwK : idempotent (orw). +proof. by move=> w; apply/wordP=> i _; rewrite !bwordE orbb. qed. + +lemma orw0 (w : word<:n>) : orw w zerow = w. +proof. by apply/wordP=> i _; rewrite !bwordE orbF. qed. + +lemma orw1 (w : word<:n>) : orw w onew = onew. +proof. by apply/wordP=> i h; rewrite !bwordE h orbT. qed. + +end section IWord. + +(* ==================================================================== *) +(* Boolean-ring structure. [ word<:n> ] is the trivial ring at [n = 0] + ([onew = zerow]), so no ring instance holds for the whole family. We + instead register the instance over [ word<:n+1> ], whose width is + provably positive: [oner_neq0] discharges unconditionally, and instance + resolution then fires for any manifestly-nonzero width — concrete + ([word<:8>]) or symbolic ([word<:k+1>]) — while refusing an arbitrary + [word<:m>] (which could be [word<:0>]). *) +section IWordRing. +declare index {n}. + +pred unitw (w : word<:n+1>) = w = onew. + +clone import Ring.BoolRing as WRing with + type t <- word<:n+1>, + op zeror <- zerow[:n+1], + op ( + ) <- ( +^ )[:n+1], + op [ - ] <- oppw[:n+1], + op oner <- onew[:n+1], + op ( * ) <- andw[:n+1], + op invr <- oppw[:n+1], + pred unit <- unitw + proof *. +realize addrA. proof. by apply/xorwA. qed. +realize addrC. proof. by apply/xorwC. qed. +realize add0r. proof. by move=> x; rewrite xorwC xorw0. qed. +realize addNr. proof. by move=> x; rewrite /oppw; apply/xorwK. qed. +realize oner_neq0. proof. by apply/onew_neq0; smt(ge0_index). qed. +realize mulrA. proof. by apply/andwA. qed. +realize mulrC. proof. by apply/andwC. qed. +realize mul1r. proof. by move=> x; rewrite andwC andw1. qed. +realize mulrDl. proof. by apply/andwDl. qed. +realize mulrr. proof. by move=> x; apply/andwK. qed. +realize unitout. proof. by move=> x hnu; apply/oppwK. qed. +realize mulVr. +proof. by move=> x; rewrite /unitw => hx; rewrite oppwK andwK; exact hx. qed. +realize unitP. +proof. +move=> x y; rewrite /unitw -wordP => h; rewrite -wordP => i hi. +by move: (h i hi); rewrite andwE onewE hi; smt(). +qed. +end section IWordRing. + +(* ==================================================================== *) +(* Numeric interpretation. [to_uint] reads a word as an unsigned integer + in [ [0, 2^n) ]; [of_int] is its (mod 2^n) inverse. The bridge + [get_to_uint] ties the bit view to the numeric view. The signed view + ([to_sint]/[msb]) needs a positive width, so its range lemmas carry a + [0 < n] hypothesis. *) + +section IWordNum. +declare index {n}. + +abbrev modulus = 2 ^ n. + +op w2bits (w : word<:n>) : bool list = ofarr (ofword w). +op bits2w (s : bool list) : word<:n> = mkword (mkarr s). + +op to_uint (w : word<:n>) : int = bs2int (w2bits w). +op of_int (x : int) : word<:n> = bits2w (int2bs n (x %% modulus)). + +lemma size_w2bits (w : word<:n>) : size (w2bits w) = n. +proof. by rewrite /w2bits size_ofarr. qed. + +lemma w2bitsE (w : word<:n>) i : 0 <= i < n => nth false (w2bits w) i = w.[i]. +proof. +move=> hi; rewrite /w2bits get_in //= IArray.getE. +by rewrite (nth_change_dfl witness false) // size_ofarr. +qed. + +lemma get_to_uint (w : word<:n>) i : + w.[i] = (0 <= i < n /\ to_uint w %/ 2 ^ i %% 2 <> 0). +proof. +case: (0 <= i < n) => hi /=; last by rewrite get_out. +rewrite -w2bitsE // /to_uint -{1}(bs2intK (w2bits w)) size_w2bits. +by rewrite /int2bs nth_mkseq //= size_w2bits. +qed. + +lemma gt0_modulus : 0 < modulus. +proof. by rewrite StdOrder.IntOrder.expr_gt0. qed. + +lemma bits2wK (s : bool list) : size s = n => w2bits (bits2w s) = s. +proof. by move=> hs; rewrite /w2bits /bits2w mkwordK mkarrK. qed. + +lemma w2bitsK (w : word<:n>) : bits2w (w2bits w) = w. +proof. by rewrite /bits2w /w2bits ofarrK ofwordK. qed. + +lemma to_uint_cmp (w : word<:n>) : 0 <= to_uint w < modulus. +proof. +rewrite /to_uint; split; first by apply bs2int_ge0. +by move=> _; rewrite -(size_w2bits w) bs2int_le2Xs. +qed. + +lemma of_uintK (x : int) : to_uint (of_int x) = x %% modulus. +proof. +have ge0 := ge0_index[:n]; rewrite /to_uint /of_int bits2wK. +- by rewrite size_int2bs; smt(). +rewrite int2bsK //; smt(gt0_modulus modz_ge0 ltz_pmod). +qed. + +lemma to_uintK (w : word<:n>) : of_int (to_uint w) = w. +proof. +rewrite /of_int pmod_small 1:to_uint_cmp. +by rewrite /to_uint -(size_w2bits w) bs2intK w2bitsK. +qed. + +lemma to_uint_eq (w1 w2 : word<:n>) : (w1 = w2) <=> (to_uint w1 = to_uint w2). +proof. by split=> [->//|h]; rewrite -(to_uintK w1) -(to_uintK w2) h. qed. + +(* Dual of [get_to_uint]: the bit of a numeral. *) +lemma of_intwE (x : int) i : + (of_int x).[i] = (0 <= i < n /\ (x %% modulus) %/ 2 ^ i %% 2 <> 0). +proof. +rewrite get_to_uint; case: (0 <= i < n) => //= hi. +by rewrite of_uintK. +qed. + +(* -------------------------------------------------------------------- *) +(* The [n]-bit slice of an integer, i.e. the value of bit [i] of [x] once + [x] has been reduced modulo [modulus]. This is what indexing a word + [(of_int x).[i]] computes; the two lemmas below are pure-integer facts + about how multiplying / dividing by [2^k] shifts those bits. The + generic integer range facts they rely on (gt0_pow2, modz_cmp, ...) + live in IntDiv. *) +op int_bit (x i : int) : bool = (x %% modulus) %/ 2 ^ i %% 2 <> 0. + +lemma of_intbE (x i : int) : (of_int x).[i] = (0 <= i < n /\ int_bit x i). +proof. by rewrite of_intwE. qed. + +lemma int_bitMP x j k : 0 <= k => 0 <= j < n => + int_bit (x * 2 ^ k) j = (0 <= j - k < n /\ int_bit x (j - k)). +proof. +move=> hk [h0j hjn]; rewrite /int_bit modz_pow2_div 1:/# modz_dvd. ++ by apply dvd2_pow2 => /#. +case: (0 <= j - k < n) => [[hjk1 hjk2] | hjk] /=; last first. ++ have hlt : j < k by smt(). + have ->: k = (k - j - 1) + 1 + j by ring. + rewrite exprD_nneg 1:/# 1:// -mulzA mulzK; 1: by smt(gt0_pow2). + by rewrite exprD_nneg 1:/# //= expr1 -mulzA modzMl. +rewrite (modz_pow2_div n) 1:/# modz_dvd. ++ by apply dvd2_pow2 => /#. +have {1}-> : j = (j - k) + k by ring. +by rewrite exprD_nneg 1,2:// divzMpr 1:gt0_pow2. +qed. + +lemma int_bitDP x j k : 0 <= x < modulus => 0 <= k => 0 <= j < n => + int_bit (x %/ 2 ^ k) j = (0 <= j + k < n /\ int_bit x (j + k)). +proof. +move=> hx hk [h0j hjn]; rewrite /int_bit. +rewrite !(modz_small _ modulus); 1,2: apply bound_abs; 2:done. ++ by apply divz_cmp; [apply gt0_pow2 | smt(gt0_pow2)]. +case: (0 <= j + k < n) => hjk. ++ have {1}-> := divz_eq x (2 ^ (j + k)). + have {1}-> := divz_eq (x %% 2 ^ (j + k)) (2 ^ k). + pose xd := x %/ 2 ^ (j + k). pose xm := x %% 2 ^ (j + k). + have -> : xd * 2 ^ (j + k) + (xm %/ 2 ^ k * 2 ^ k + xm %% 2 ^ k) = + (xd * 2 ^ j + xm %/ 2 ^ k) * 2 ^ k + xm %% 2 ^ k. + + by rewrite exprD_nneg 1,2://; ring. + rewrite divzMDl. smt(gt0_pow2). + rewrite (divz_small (xm %% 2 ^ k) (2 ^ k)). + + apply bound_abs; apply modz_cmp; apply gt0_pow2. + rewrite /= divzMDl. smt(gt0_pow2). + rewrite (divz_small (xm %/ 2 ^ k) (2 ^ j)) 2://. + apply bound_abs; apply divz_cmp; 1: by apply gt0_pow2. + by rewrite -exprD_nneg 1,2://; apply modz_cmp; apply gt0_pow2. +rewrite /= (divz_small (x %/ 2 ^ k) (2 ^ j)) 2://. +apply bound_abs; apply divz_cmp; 1: by apply gt0_pow2. +by rewrite -exprD_nneg 1,2://; smt(StdOrder.IntOrder.ler_weexpn2l). +qed. + +lemma w2bits_zerow : w2bits zerow = nseq n false. +proof. +have ge0 := ge0_index[:n]; apply/(eq_from_nth false); first by rewrite size_w2bits size_nseq; smt(). +by move=> i; rewrite size_w2bits => hi; rewrite w2bitsE // zerowE nth_nseq. +qed. + +lemma w2bits_onew : w2bits onew = nseq n true. +proof. +have ge0 := ge0_index[:n]; apply/(eq_from_nth false); first by rewrite size_w2bits size_nseq; smt(). +by move=> i; rewrite size_w2bits => hi; rewrite w2bitsE // onewE hi nth_nseq. +qed. + +lemma to_uint_zerow : to_uint zerow = 0. +proof. by rewrite /to_uint w2bits_zerow bs2int_nseq_false. qed. + +lemma to_uint_onew : to_uint onew = modulus - 1. +proof. by have ge0 := ge0_index[:n]; rewrite /to_uint w2bits_onew bs2int_nseq_true. qed. + +lemma zerowP : zerow = of_int 0. +proof. by rewrite -(to_uintK zerow) to_uint_zerow. qed. + +lemma onewP : onew = of_int (modulus - 1). +proof. by rewrite -(to_uintK onew) to_uint_onew. qed. + +(* -------------------------------------------------------------------- *) +(* Signed interpretation. The signed range needs a positive width, so + the range/msb lemmas carry a [0 < n] hypothesis (vacuous at [word<:0>], + the one-element word). *) +abbrev min_sint = - 2 ^ (n - 1). +abbrev max_sint = 2 ^ (n - 1) - 1. + +op smod (i : int) : int = if 2 ^ (n - 1) <= i then i - modulus else i. +op to_sint (w : word<:n>) : int = smod (to_uint w). +op msb (w : word<:n>) : bool = 2 ^ (n - 1) <= to_uint w. + +lemma half_modulus : 0 < n => 2 * 2 ^ (n - 1) = modulus. +proof. by move=> gt0; rewrite -exprS 1:/# /#. qed. + +lemma gt0_half : 0 < n => 0 < 2 ^ (n - 1). +proof. by move=> gt0; rewrite StdOrder.IntOrder.expr_gt0. qed. + +lemma to_sint_cmp (w : word<:n>) : 0 < n => min_sint <= to_sint w <= max_sint. +proof. by move=> gt0; rewrite /to_sint /smod; smt(to_uint_cmp half_modulus). qed. + +(* The 2^(n-1) power is generalized away before any arithmetic step, so + no prover ever sees an exponential (CI provers rejected the one-shot + smt of the previous version). *) +lemma msbE (w : word<:n>) : 0 < n => msb w = w.[n - 1]. +proof. +move=> gt0; rewrite /msb get_to_uint. +have -> /=: 0 <= n - 1 < n by smt(). +have hcmp: 0 <= to_uint w < 2 * 2 ^ (n - 1). +- by rewrite half_modulus //; apply/to_uint_cmp. +move: hcmp (gt0_half gt0); move: (2 ^ (n - 1)) => p hcmp gt0_p. +rewrite modz_small. +- by rewrite /= divz_ge0 //= ltz_divLR //= (mulzC 2) /#. +rewrite eq_iff -{1}(mul1r p) -lez_divRL //. +smt(divz_ge0 ltz_divLR). +qed. + +(* -------------------------------------------------------------------- *) +(* Arithmetic (ℤ/2ⁿ) operators: [+]/[*]/unary [-] lift the integer + operations through [to_uint]/[of_int], i.e. act modulo [modulus]. The + comm-ring structure is registered below over [word<:n+1>]. *) +op ( + ) (x y : word<:n>) : word<:n> = of_int (to_uint x + to_uint y). +op oppa (x : word<:n>) : word<:n> = of_int (- to_uint x). +op ( * ) (x y : word<:n>) : word<:n> = of_int (to_uint x * to_uint y). + +lemma of_int_mod (x : int) : of_int (x %% modulus) = of_int x. +proof. by rewrite /of_int modz_mod. qed. + +lemma to_uintD (x y : word<:n>) : to_uint (x + y) = (to_uint x + to_uint y) %% modulus. +proof. by rewrite /( + ) of_uintK. qed. + +lemma to_uintM (x y : word<:n>) : to_uint (x * y) = (to_uint x * to_uint y) %% modulus. +proof. by rewrite /( * ) of_uintK. qed. + +lemma to_uintN (x : word<:n>) : to_uint (oppa x) = (- to_uint x) %% modulus. +proof. by rewrite /oppa of_uintK. qed. + +lemma of_intD (x y : int) : of_int (x + y) = of_int x + of_int y. +proof. by rewrite to_uint_eq to_uintD !of_uintK modzDm. qed. + +lemma of_intN (x : int) : of_int (- x) = oppa (of_int x). +proof. by rewrite to_uint_eq to_uintN !of_uintK modzNm. qed. + +lemma of_intM (x y : int) : of_int (x * y) = of_int x * of_int y. +proof. by rewrite to_uint_eq to_uintM !of_uintK modzMm. qed. + +(* -------------------------------------------------------------------- *) +(* Unsigned / signed comparisons. *) +op ( \ule ) (x y : word<:n>) = to_uint x <= to_uint y. +op ( \ult ) (x y : word<:n>) = to_uint x < to_uint y. +op ( \sle ) (x y : word<:n>) = to_sint x <= to_sint y. +op ( \slt ) (x y : word<:n>) = to_sint x < to_sint y. + +lemma uleNgt (x y : word<:n>) : (x \ule y) = !(y \ult x). +proof. by rewrite /( \ule ) /( \ult ) lezNgt. qed. + +lemma ultNge (x y : word<:n>) : (x \ult y) = !(y \ule x). +proof. by rewrite /( \ult ) /( \ule ) ltzNge. qed. + +lemma sleNgt (x y : word<:n>) : (x \sle y) = !(y \slt x). +proof. by rewrite /( \sle ) /( \slt ) lezNgt. qed. + +lemma sltNge (x y : word<:n>) : (x \slt y) = !(y \sle x). +proof. by rewrite /( \slt ) /( \sle ) ltzNge. qed. + +(* -------------------------------------------------------------------- *) +(* Order theory of the unsigned comparisons. *) +lemma ule_refl (x : word<:n>) : x \ule x. +proof. by rewrite /( \ule ). qed. + +lemma ule_trans (y x z : word<:n>) : x \ule y => y \ule z => x \ule z. +proof. by rewrite /( \ule ); apply lez_trans. qed. + +lemma ule_anti (x y : word<:n>) : x \ule y => y \ule x => x = y. +proof. +by rewrite /( \ule ) => h1 h2; rewrite to_uint_eq eqz_leq h1 h2. +qed. + +lemma ule_total (x y : word<:n>) : x \ule y \/ y \ule x. +proof. by rewrite /( \ule ); exact lez_total. qed. + +lemma ult_irr (x : word<:n>) : ! (x \ult x). +proof. by rewrite /( \ult ) ltzz. qed. + +lemma ultW (x y : word<:n>) : x \ult y => x \ule y. +proof. by rewrite /( \ult ) /( \ule ); apply ltzW. qed. + +(* -------------------------------------------------------------------- *) +(* Subtraction. *) +abbrev ( - ) (x y : word<:n>) : word<:n> = x + oppa y. + +lemma to_uintD_small (x y : word<:n>) : + to_uint x + to_uint y < modulus => + to_uint (x + y) = to_uint x + to_uint y. +proof. by move=> h; rewrite to_uintD modz_small //; smt(to_uint_cmp). qed. + +lemma to_uintB (x y : word<:n>) : + y \ule x => to_uint (x - y) = to_uint x - to_uint y. +proof. +rewrite /( \ule ) => hle. +by rewrite to_uintD to_uintN modzDmr modz_small //; smt(to_uint_cmp). +qed. + +(* -------------------------------------------------------------------- *) +(* Shifts and rotates. All are bit reindexings: [ >>> ] logical right, + [ <<< ] left, [ sar ] arithmetic right (sign-extends the top bit), + [ ror ]/[ rol ] rotate. Out-of-range bit reads give [false]. *) +op ( `>>>` ) (x : word<:n>) (i : int) : word<:n> = offunw (fun j => x.[j + i]). +op ( `<<<` ) (x : word<:n>) (i : int) : word<:n> = offunw (fun j => x.[j - i]). +op sar (x : word<:n>) (i : int) : word<:n> = offunw (fun j => x.[min (n - 1) (j + i)]). +op ror (x : word<:n>) (i : int) : word<:n> = offunw (fun j => x.[(j + i) %% n]). +op rol (x : word<:n>) (i : int) : word<:n> = offunw (fun j => x.[(j - i) %% n]). + +lemma shrwE (x : word<:n>) i j : 0 <= j < n => (x `>>>` i).[j] = x.[j + i]. +proof. by move=> hj; rewrite offunwE hj. qed. + +lemma shlwE (x : word<:n>) i j : 0 <= j < n => (x `<<<` i).[j] = x.[j - i]. +proof. by move=> hj; rewrite offunwE hj. qed. + +lemma sarwE (x : word<:n>) i j : 0 <= j < n => (sar x i).[j] = x.[min (n - 1) (j + i)]. +proof. by move=> hj; rewrite offunwE hj. qed. + +lemma rorwE (x : word<:n>) i j : 0 <= j < n => (ror x i).[j] = x.[(j + i) %% n]. +proof. by move=> hj; rewrite offunwE hj. qed. + +lemma rolwE (x : word<:n>) i j : 0 <= j < n => (rol x i).[j] = x.[(j - i) %% n]. +proof. by move=> hj; rewrite offunwE hj. qed. + +(* -------------------------------------------------------------------- *) +(* Shift <-> arithmetic: [ >>> ] is unsigned division by [2^i]. *) +(* [ >>> ] is unsigned division, [ <<< ] is (truncated) multiplication. + Both reduce to [int_bitDP] / [int_bitMP] via [of_int]. *) +lemma shlMP x k : 0 <= k => (of_int x `<<<` k) = of_int (x * 2 ^ k). +proof. +move=> hk; apply/wordP => j hj. +by rewrite (shlwE _ _ _ hj) !of_intbE hj /= -(int_bitMP x j k hk hj). +qed. + +lemma shrDP x k : 0 <= k => (of_int x `>>>` k) = of_int (x %% modulus %/ 2 ^ k). +proof. +move=> hk; rewrite -(of_int_mod x); apply/wordP => j hj. +rewrite (shrwE _ _ _ hj) !of_intbE hj /= -(int_bitDP (x %% modulus) j k _ hk hj) //. +by apply modz_cmp; apply gt0_modulus. +qed. + +lemma to_uint_shl (w : word<:n>) i : + 0 <= i => to_uint (w `<<<` i) = (to_uint w * 2 ^ i) %% modulus. +proof. by move=> hi; rewrite -{1}(to_uintK w) shlMP // of_uintK. qed. + +lemma to_uint_shr (w : word<:n>) i : + 0 <= i => to_uint (w `>>>` i) = to_uint w %/ 2 ^ i. +proof. +move=> hi; rewrite -{1}(to_uintK w) shrDP // of_uintK. +rewrite (modz_small (to_uint w)). ++ by apply bound_abs; apply to_uint_cmp. +rewrite modz_small 2://. +apply bound_abs; apply divz_cmp; 1: by apply gt0_pow2. +smt(to_uint_cmp gt0_pow2). +qed. + +(* -------------------------------------------------------------------- *) +(* Shift-by-zero, shift composition, rotate normalization/inverses. + None of these need [0 < n]: at width 0, [%% 0] is the identity and + [wordP]'s quantification is vacuous. *) +lemma shrw0 (x : word<:n>) : x `>>>` 0 = x. +proof. by apply/wordP=> i hi; rewrite shrwE // addz0. qed. + +lemma shlw0 (x : word<:n>) : x `<<<` 0 = x. +proof. by apply/wordP=> i hi; rewrite shlwE // subz0. qed. + +lemma shrw_add (x : word<:n>) (i j : int) : + 0 <= i => 0 <= j => x `>>>` i `>>>` j = x `>>>` (i + j). +proof. +move=> hi hj; apply/wordP=> k hk. +rewrite /( `>>>` ) !offunwE hk /= offunwE. +case: (0 <= k + j < n) => hkj /=; first by congr; ring. +by rewrite get_out /#. +qed. + +lemma shlw_add (x : word<:n>) (i j : int) : + 0 <= i => 0 <= j => x `<<<` i `<<<` j = x `<<<` (i + j). +proof. +move=> hi hj; apply/wordP=> k hk. +rewrite /( `<<<` ) !offunwE hk /= offunwE. +case: (0 <= k - j < n) => hkj /=; first by congr; ring. +by rewrite get_out /#. +qed. + +lemma rorw_mod (x : word<:n>) (i : int) : ror x (i %% n) = ror x i. +proof. by apply/wordP=> k hk; rewrite !rorwE // modzDmr. qed. + +lemma rolw_mod (x : word<:n>) (i : int) : rol x (i %% n) = rol x i. +proof. +apply/wordP=> k hk; rewrite !rolwE //; congr. +by rewrite -{1}(modz_small k n) 1:/# modzBm. +qed. + +lemma rorwK (x : word<:n>) (i : int) : rol (ror x i) i = x. +proof. +apply/wordP=> k hk; rewrite rolwE // rorwE; first by smt(modz_cmp). +by congr; rewrite modzDml; smt(modz_small). +qed. + +lemma rolwK (x : word<:n>) (i : int) : ror (rol x i) i = x. +proof. +apply/wordP=> k hk; rewrite rorwE // rolwE; first by smt(modz_cmp). +by congr; rewrite modzDml; smt(modz_small). +qed. + +end section IWordNum. + +(* ==================================================================== *) +(* Arithmetic comm-ring structure (ℤ/2ⁿ⁺¹). Registered over [word<:n+1>] + for the same positivity reason as the boolean ring: [oner_neq0] needs a + modulus [> 1]. [ComRingDflInv] supplies the (choice-based) unit/inverse + and discharges [mulVr]/[unitP]/[unitout]; only the ring axioms remain. *) +section IWordRingA. +declare index {n}. + +clone import Ring.ComRingDflInv as WRingA with + type t <- word<:n+1>, + op zeror <- of_int[:n+1] 0, + op ( + ) <- ( + )[:n+1], + op [ - ] <- oppa[:n+1], + op oner <- of_int[:n+1] 1, + op ( * ) <- ( * )[:n+1] + proof *. +realize addrA. +proof. by move=> x y z; rewrite to_uint_eq !to_uintD modzDmr modzDml addrA. qed. +realize addrC. +proof. by move=> x y; rewrite to_uint_eq !to_uintD addzC. qed. +realize add0r. +proof. +move=> x; rewrite to_uint_eq to_uintD of_uintK mod0z /=. +by rewrite pmod_small 1:to_uint_cmp. +qed. +realize addNr. +proof. by move=> x; rewrite to_uint_eq to_uintD to_uintN of_uintK modzDml addNz. qed. +realize oner_neq0. +proof. +have ge0 := ge0_index[:n]; rewrite to_uint_eq !of_uintK. +have h1 : 2 ^ (n + 1) = 2 * 2 ^ n by rewrite exprS //. +have h2 : 0 < 2 ^ n by rewrite StdOrder.IntOrder.expr_gt0. +smt(). +qed. +realize mulrA. +proof. by move=> x y z; rewrite to_uint_eq !to_uintM modzMmr modzMml mulrA. qed. +realize mulrC. +proof. by move=> x y; rewrite to_uint_eq !to_uintM mulzC. qed. +realize mul1r. +proof. +move=> x; rewrite to_uint_eq to_uintM of_uintK. +by rewrite modzMml /= pmod_small 1:to_uint_cmp. +qed. +realize mulrDl. +proof. +move=> x y z; rewrite to_uint_eq to_uintM !to_uintD !to_uintM. +by rewrite modzMml modzDml modzDmr mulzDl. +qed. + +end section IWordRingA. + +(* The BoolRing clone registers its (anonymous) instance on the same + carrier [word<:n+1>], and instance lookup returns the first match: + the arithmetic structure would be unreachable by the [ring] tactic. + Register it NAMED, index-parametrically: [ring [warith]] selects + ℤ/2ⁿ, bare [ring] keeps selecting the boolean structure. + + Every instance operator records its OWN instantiation at the + carrier, so predecessor-shaped operators fit directly: the + clone-generalized [WRingA.exp {n} : word<:n+1> -> ...] is recorded + at [wsz] for the carrier [word<:wsz+1>]. *) +op zeroa {n} : word<:n> = of_int 0. +op onea {n} : word<:n> = of_int 1. + +lemma oner_neq0_a {n} : onea[:n+1] <> zeroa[:n+1]. +proof. rewrite /onea /zeroa; exact WRingA.oner_neq0. qed. + +instance ring [warith] with {wsz} word<:wsz+1> + op rzero = zeroa + op rone = onea + op add = ( + ) + op mul = ( * ) + op opp = oppa + op expr = WRingA.exp + op ofint = of_int + + proof oner_neq0 by exact (oner_neq0_a[:wsz]) + proof addr0 by exact (WRingA.addr0[:wsz]) + proof addrA by exact (WRingA.addrA[:wsz]) + proof addrC by exact (WRingA.addrC[:wsz]) + proof addrN by exact (WRingA.addrN[:wsz]) + proof mulr1 by exact (WRingA.mulr1[:wsz]) + proof mulrA by exact (WRingA.mulrA[:wsz]) + proof mulrC by exact (WRingA.mulrC[:wsz]) + proof mulrDl by exact (WRingA.mulrDl[:wsz]) + proof expr0 by exact (WRingA.expr0[:wsz]) + proof exprS by exact (WRingA.exprS[:wsz]) + proof ofint0 by rewrite /zeroa + proof ofint1 by rewrite /onea + proof ofintS by (move=> i _; rewrite /onea addzC of_intD) + proof ofintN by exact (of_intN[:wsz+1]). + diff --git a/theories/datatypes/Int.ec b/theories/datatypes/Int.ec index cf40d374f..825151dc7 100644 --- a/theories/datatypes/Int.ec +++ b/theories/datatypes/Int.ec @@ -18,6 +18,21 @@ lemma intind (p:int -> bool): (forall i, 0 <= i => p i). proof. exact/CoreInt.intind. qed. +(* -------------------------------------------------------------------- *) +(* Index expressions range over the NATURALS, and the system enforces + that discipline at every entry point: the surface index grammar has + no negative literals, index arithmetic (addition, multiplication) + is closed over the naturals, the affine index solver refuses + solutions that could go negative, and the proof-term bridge + ([propagate_idx_link]) only instantiates an index variable with + indices built from the goal's own index variables. This axiom + makes the enforced invariant available as a fact — e.g. + [ge0_index[:n]] inside a [declare index {n}] section. Every + reachable instantiation satisfies it; breaking any of the entry + points above re-opens the derivations of [false] pinned by + tests/indexed-nonneg.ec. *) +axiom ge0_index {k} : 0 <= k. + (* -------------------------------------------------------------------- *) lemma addzA : forall x y z, x + (y + z) = (x + y) + z by smt(). lemma addzC : forall x y, x + y = y + x by smt().