diff --git a/memory.md b/memory.md new file mode 100644 index 000000000..a51ec885b --- /dev/null +++ b/memory.md @@ -0,0 +1,745 @@ +# Indexed-types branch — work-in-progress notes + +This file tracks ongoing decisions and progress on the `indexed-types` +branch. The end goal is to add integer-indexed types to EasyCrypt: +types parametrised by both type variables and integer indices, with a +small index language and decidable equality on indices. + +## Confirmed design decisions + +- **`tindex` grammar.** `TIVar | TIConst zint | TIAdd | TIMul` + ([src/ecAst.ml:60-64](src/ecAst.ml#L60-L64)). No `TINeg`/`TISub`; + surface syntax must reject subtraction. +- **Indices are non-negative integers (ℕ).** `TIConst` should be + guarded against negative `zint`. +- **Equality is decided by polynomial normal form.** Normalize to + sorted sum-of-monomials with `EcBigInt` coefficients (all ≥ 1), then + compare structurally. No SMT. +- **`TIVar` shares the term-level identifier namespace with `int` + formula vars.** A substitution `n ↦ φ` is required at construction + time to have `φ` representable as a `tindex` — i.e. + `tindex_of_form φ` must succeed. `tindex_subst` may then + `Option.get` the conversion. +- **Indices appear on every polymorphic declaration:** tydecls, + operators (incl. predicates / abbreviations / notations), + axioms / lemmas. Not modules. +- **No constraint annotations in the MVP.** `'a vec[n-3]` is not + expressible (no subtraction); `'a vec[0]` is allowed and just + useless. +- **SMT export: punted.** Block proof obligations touching indexed + types until a later phase. + +## Phase 0 — Stop the bleeding (DONE) + +Goal: clean `dune build` with the existing `targs` / +`ty_params = {idxvars; tyvars}` data model, without changing semantics. + +### What changed + +- [src/ecInductive.ml](src/ecInductive.ml) — fixed the stray `)` + syntax error at line 188; renamed `args.indexes` → `args.indices`; + threaded `tyd_params.tyvars`; switched constructor calls to keyword + form (`tconstr ~tyargs`, `f_op ~tyargs`). +- [src/ecDecl.ml](src/ecDecl.ml) — restored `gen_op` / `mk_op` bodies + to match the existing mli (the WIP rewrite referenced unbound names + `tparams` / `ty` / `lc` / `op_params`); threaded `tparams.tyvars` in + `ty_instantiate` and `axiomatized_op`; `ax_tparams` now wraps a + `ty_params` record. +- [src/ecUnify.ml](src/ecUnify.ml) — `UniEnv.create` / `opentvi` / + `subst_tv` / `tparams` now consume / produce `ty_params` records + (extracting `.tyvars` internally; `ue_decl` still stores the tyvar + list). +- [src/ecEnv.ml](src/ecEnv.ml) — `Op.reduce`, `Ax.instantiate`, + `Ty.unfold`, `Ty.scheme_of_ty`, `Ty.get_top_decl` thread + `targs.types` / `tyvars` correctly; algebra instances and TC-op + helpers wrap empty `ty_params`. +- Mechanical migration across + [src/ecCallbyValue.ml](src/ecCallbyValue.ml), + [src/ecReduction.ml](src/ecReduction.ml), + [src/ecMatching.ml](src/ecMatching.ml), + [src/ecPV.ml](src/ecPV.ml), + [src/ecHiInductive.ml](src/ecHiInductive.ml), + [src/ecHiGoal.ml](src/ecHiGoal.ml), + [src/ecLowGoal.ml](src/ecLowGoal.ml), + [src/ecProofTyping.ml](src/ecProofTyping.ml), + [src/ecProofTerm.ml](src/ecProofTerm.ml), + [src/ecSearch.ml](src/ecSearch.ml), + [src/ecTyping.ml](src/ecTyping.ml), + [src/ecScope.ml](src/ecScope.ml), + [src/ecTheoryReplay.ml](src/ecTheoryReplay.ml), + [src/ecAlgTactic.ml](src/ecAlgTactic.ml), + [src/ecSection.ml](src/ecSection.ml), + [src/ecSubst.ml](src/ecSubst.ml), + [src/ecSmt.ml](src/ecSmt.ml), + [src/ecPrinting.ml](src/ecPrinting.ml), + [src/ecThCloning.ml](src/ecThCloning.ml), and several + [src/phl/](src/phl/) modules: + - `tyd_params` / `op_tparams` / `ax_tparams` → `.tyvars` + - `targs` consumers → `.types` / `.indices` + - positional `tconstr p tys` / `e_op p tys` / `f_op p tys` → + keyword form (`~tyargs:` / `~indices:`) + - `[]` placeholders for `ty_params` → `{idxvars=[]; tyvars=[]}` + +### Notable Phase-0 design choices + +- Kept `ue_decl : EcIdent.t list` inside `ecUnify` (only tyvars), + wrapping into `ty_params` at the boundary. +- Several places that consume `targs` for type comparison currently + `assert (List.is_empty tys.indices)` (e.g. `ecMatching`, + `ecCallbyValue`, `ecReduction`'s rule patterns, `ecSmt`) — explicit + panics where Phase 1 will replace with proper polynomial-equality + logic. +- SMT translation now hard-asserts no indices (per the SMT-punt + decision); a cleaner user-facing error belongs to Phase 5. + +## Roadmap (remaining phases) + +### Phase 1 — Polynomial normal form & equality (DONE) + +#### What changed + +- [src/ecAst.ml](src/ecAst.ml) — added `tindex_canonical` record + (`{cn_konst : zint; cn_mons : (mono * zint) list}` with `mono = + (ident * exponent) list`), the helpers `mono_compare` / `mono_mul` + / `mons_normalize` / `canonical_const` / `canonical_var` / + `canonical_add` / `canonical_mul`, and the entry point + `tindex_canonicalize`. Coefficients are stored as `EcBigInt.zint` + with the invariants `cn_konst ≥ 0`, every `mons` coefficient ≥ 1, + `cn_mons` strictly sorted by `mono_compare`. `canonical_const` + guards against negative `TIConst` with `invalid_arg`. +- `tindex_equal` now does `(==)` first, then compares canonical + forms; `tindex_hash` hashes the canonical form so hashconsing of + `Tconstr` agrees with equality. +- `targs_equal` checks lengths before `List.all2` (previously could + raise `Invalid_argument`). +- [src/ecAst.mli](src/ecAst.mli) — exposed `tindex_hash`. +- [src/ecUnify.ml](src/ecUnify.ml) — fixed the inverted-polarity bug + in the unification of `Tconstr` arms (was `if all2 ... then + failure ()` instead of `if not all2`); now also length-checks + indices before iterating types. +- [src/ecReduction.ml](src/ecReduction.ml) — + `EqTest_base.for_targs` actually compares indices (previous FIXME). + +#### Verified + +Built `dune build`, then ran an ephemeral smoke executable (deleted +after success) covering: commutativity (`n+1 ≡ 1+n`), associativity +(`(n+m)+1 ≡ n+(m+1)`), distribution + constant folding +(`(n+1)·2 ≡ 2n+2`), monomials (`n·n`), binomial expansion +(`(n+m)² ≡ n²+2nm+m²`), inequality (`n ≢ n+1`, `2 ≢ 3`), and hash +consistency between equal canonical forms. + +#### Deferred from Phase 1 + +- Index unification variables (a `TIUnivar` constructor and + participation in `EcUnify.UF`) — only needed if Phase 3 lets users + elide indices at applications. Defer until parser work surfaces a + concrete need. + +### Phase 2 — Substitution & FV (DONE) + +#### What changed + +- [src/ecCoreFol.ml](src/ecCoreFol.ml) + [src/ecCoreFol.mli](src/ecCoreFol.mli) + — added `tindex_of_form : form -> tindex option` recognising the + polynomial fragment over ℕ (`Fint n` with `n ≥ 0`, int-typed + `Flocal`, `p_int_add`, `p_int_mul`); returns `None` on anything + else. +- [src/ecCoreSubst.ml](src/ecCoreSubst.ml) — `is_ty_subst_id` now + also checks `Mid.is_empty s.fs_loc`, since indices share the + formula-locals namespace and so `fs_loc` can affect types via + `Tconstr` indices. `tindex_subst` consults `s.fs_loc` per `TIVar`, + converts via `tindex_of_form`, and panics with a descriptive + message if a binding is non-polynomial. `targs_subst`'s + short-circuit follows automatically. +- [src/ecCoreSubst.mli](src/ecCoreSubst.mli) — exposed + `tindex_subst`. +- [src/ecSubst.ml](src/ecSubst.ml) — same treatment for + `subst_tindex` against `sb_flocal`. +- [src/ecAst.ml](src/ecAst.ml) — added `tindex_fv_acc` / `tindex_fv` + (each `TIVar` contributes its identifier with multiplicity 1). + `targs_fv` now folds over `indices` too. `Hsty.fv` already routed + through `targs_fv`, so `ty.ty_fv` now includes index-variable + identifiers; `Fsubst.f_subst_local`'s per-formula + `Mid.mem x f.f_fv` short-circuit therefore triggers correctly on + types whose `Tconstr` carries `TIVar x`. +- [src/ecAst.mli](src/ecAst.mli) — exposed `tindex_fv`, `targs_fv`. + +#### Verified + +Built `dune build`, then ran an ephemeral smoke executable (deleted +after success) covering: +- `fv(n*m+1) = {n, m}` and `k ∉ fv`. +- `targs_fv` carries indices. +- `(n+1)[n:=5] ≡ 6` (constant folds via canonicalisation). +- `(n+1)[n:=1+m] ≡ m+2` (substitution composes with normalisation). +- `(2n+nm)[n:=5] ≡ 10+5m`. +- `targs_subst` actually rewrites `TIVar`. +- `ty_fv` of a `Tconstr` with an index reports the index variable. + +#### Notable Phase-2 design choices + +- `tindex_subst` does not re-canonicalise after substitution; the AST + may hold non-canonical shapes (e.g. `(1+m)+1` rather than `m+2`) + but `tindex_equal` / `tindex_hash` always canonicalise lazily, so + hashconsing of `Tconstr` still identifies them. Pretty-printing + (Phase 6) will canonicalise for display. +- Substitution looks at `fs_loc` only; `fs_eloc` (expression-only + bindings) is not consulted. `f_bind_rename` writes both maps so + α-renaming still propagates into indices. + +#### Risk left for later + +- Audit of `f_bind_local` callers for the substitution invariant: if + any pass binds an `int`-typed local to a non-polynomial formula and + that local later appears as a `TIVar` inside a type, EasyCrypt will + crash mid-proof from `tindex_subst`. Worth a tactical sweep before + merging to main. + +### Phase 3 — Parser & typing (DONE) + +#### Final concrete syntax + +- **Index binders** are plain identifiers (no apostrophe) inside + `[...]`, e.g. `type [n m] ('a, 'b) vec.`. On op / pred / axiom / + lemma headers, `[...]` accepts a *mixed* list — apostrophe-prefixed + → tyvar, plain → index — bucketed in the parser prelude: + `op f [n 'a] (xs : 'a vec<:n>) : 'a vec<:n+1>`. +- **Index applications** use `<: ... >` framing (LTCOLON / GT), e.g. + `'a vec<:n+1, m*2>`. We avoid `[...]` here because it would + shift/reduce-conflict with the codepos brackets in + `module M = N with { proc f [ var x : T [..] ] }`. The framing also + matches the existing operator type-arg syntax `f<:int>`. +- **Index-expression sub-grammar**: literals, identifiers, `+`, `*` + with standard precedence. The grammar guarantees only the + polynomial fragment. +- **Disambiguation rule** (shared namespace): inside `[...]` and + `<:...>` an identifier is read as an index variable; everywhere + else it's a formula/expression local. Apostrophe-prefixed names are + always type variables. + +#### What changed + +- [src/ecParsetree.ml](src/ecParsetree.ml) — `pindex_r` / `pindex` + added, mutually recursive with `pty_r`. `PTapp` now carries + `pindex list`. `ptydecl` / `poperator` / `ppredicate` / `paxiom` + each grow an `*_idxvars : psymbol list` field. +- [src/ecParser.mly](src/ecParser.mly) — `idxvars_decl` (tydecl + prefix), `idx_args` (postfix `<: ... >` on `simpl_type_exp`), + `pindex` sub-grammar, `mixed_tyvars_item` / `mixed_tyvars_decl` + (mixed binder list), and a `bucket_mixed` helper in the prelude. + `tyd_name`, `operator`, `predicate`, `lemma_decl` updated to + produce the new fields. +- [src/ecTyping.ml](src/ecTyping.ml) + [.mli](src/ecTyping.mli) — + `transtyvars` gains `?idxparams:psymbol list`. `transtindex` + translates a `pindex` to a `tindex`, looking variables up via + `EcUnify.UniEnv.getnamed_idx`. `transty` `PTapp` validates index + arity and translates each index argument. New `tyerror` variants: + `InvalidIndexAppl`, `UnboundIndexVariable`, `DuplicatedIndexVar`, + with printer entries in + [src/ecUserMessages.ml](src/ecUserMessages.ml). +- [src/ecUnify.ml](src/ecUnify.ml) + [.mli](src/ecUnify.mli) — + `unienv` carries a separate `ue_idxnamed` / `ue_idxdecl`. New + `getnamed_idx`. `tparams` propagates `idxvars` into the returned + `ty_params`. +- [src/ecScope.ml](src/ecScope.ml) — tydecl path threads + `pty_idxvars` for abstract / alias bodies, refuses indices on + datatype / record with a clean error. Op + axiom call sites pass + `~idxparams`. +- [src/ecHiPredicates.ml](src/ecHiPredicates.ml) — predicate-decl + passes `~idxparams`. +- [src/ecThCloning.ml](src/ecThCloning.ml) + [.mli](src/ecThCloning.mli) + — new `CE_IndexedNotYetSupported` clone-error; `ty_ovrd` refuses + cloning of indexed types with a clean printer entry. +- [tests/indexed-types.ec](tests/indexed-types.ec) — regression + exercising tydecl binders + applications, op / pred / axiom + binders. + +#### Verified + +- `_build/default/src/ec.exe compile -boot tests/indexed-types.ec` + succeeds (12 indexed-type declarations and 3 indexed + op/pred/axiom binders). +- Ad-hoc negative cases: unbound index, index arity mismatch, + duplicated index variable, cloning of an indexed type — each + raises a clean message at the right location. + +#### Notable Phase-3 design choices + +- The `<:...>` framing for index applications was chosen over the + user-preferred `[...]` after a real shift/reduce conflict surfaced + in `mod_update_fun`. Reuses the existing operator-tvi framing. +- `pindex` is its own AST (not a re-use of `pformula`) to avoid + pulling `pformula` into `pty_r`'s mutual recursion. +- `transtyvars` keeps its existing positional `(loc, tparams option)` + argument; the new `?idxparams` is an optional keyword. Backward + compatible — every existing call site still compiles unchanged. + +#### Risks left for later + +- **Index inference at op application sites.** Indexed ops *declare* + fine but *calling* them doesn't yet work — `EcUnify` has no + `TIUnivar` machinery, so an op's index parameter stays as a fresh + ident that can't be unified against the caller's index expression. + This is the deferred Phase-1 question (introduce `TIUnivar`, + decide polynomial-with-univars unification). Without it, indexed + ops are mostly cosmetic. +- **Datatype / Record indexed types.** Refused with a clean error in + `ecScope`. Adding support is mostly threading idxvars through + `ecHiInductive.trans_datatype` / `trans_record`. +- **Cloning of indexed types/ops.** Refused with `CE_IndexedNotYetSupported`. + Real support needs index-instantiation surface syntax in + `clone with`, plus a way to substitute indices through the cloned + declarations. + +### Phase 3.5 — Index inference at op-application sites (DONE) + +Added the `TIUnivar`-based machinery that Phase 3 deferred. Without +this, indexed ops could be *declared* but not *called* — the unifier +had no way to instantiate an op's index parameter against the +caller's index expression. + +#### What changed + +- [src/ecAst.ml](src/ecAst.ml) + [.mli](src/ecAst.mli) — new + `TIUnivar of EcUid.uid` variant on `tindex`. The canonical-form + monomial key is now `tindex_var = TVVar of EcIdent.t | TVUni of + EcUid.uid`, so univars are first-class atoms in the polynomial. + New helpers `tindex_naked_univar` (detects `TIUnivar u` modulo + canonicalisation) and `tindex_occurs_univar` (occurs check). + `tindex_canonicalize`, `tindex_fv_acc`, `dump_tindex` extended. +- [src/ecCoreSubst.ml](src/ecCoreSubst.ml) + + [.mli](src/ecCoreSubst.mli) — `f_subst` gains `fs_idx : tindex + Mid.t` (op-application instantiation, ident → tindex) and `fs_iu : + tindex Muid.t` (univar resolution after unification). + `tindex_subst` consults both. + **Critical fix**: `ty_subst`'s `Tconstr` case now substitutes + through `targs.indices` directly; the previous `ty_map` catch-all + left them untouched, which silently dropped the op-application + index substitution. This was the immediate cause of every "no + matching operator" error on indexed op calls. +- [src/ecUnify.ml](src/ecUnify.ml) + [.mli](src/ecUnify.mli) — + `unienv_r` gains `ue_iuf : tindex Muid.t` (assignments) and + `ue_iuf_alloc : Suid.t` (alloc tracking, for the close-time + check). `unify_core` rewritten to take a `unienv` directly and + handle a new `IxUni` work-list case. `pb` extended to + `[ TyUni | IxUni ]`. `idx_fresh` allocates fresh TIUnivars; + `openidx` produces the ident → univar substitution map; `openty_r` + threads it. `closed`/`close` now also require all index univars + resolved; new `iu_close` / `iu_assubst` expose the assignment map. +- [src/ecTyping.ml](src/ecTyping.ml) + [.mli](src/ecTyping.mli) — + `unify_or_fail` handles `IxUni`; new `IndexMismatch` tyerror with + a printer in [src/ecUserMessages.ml](src/ecUserMessages.ml). +- [src/ecTypes.mli](src/ecTypes.mli) — exposed `dump_tindex`. +- [tests/indexed-types.ec](tests/indexed-types.ec) — extended with + the polynomial-equality regression: single-call `cons`, the + chained `concat (cons x ys) zs`, two variants annotated with + `(n+1)+m` vs `n+(1+m)` proving normal-form equality across + associativity. + +#### MVP scope + +- **Handled**: "naked `TIUnivar` ≟ arbitrary polynomial" + (with occurs check), and canonical-equality after univar + resolution. Covers the common chained-op pattern. +- **Not handled**: general polynomial unification. + `?u + 1 ≟ n` would need to invert subtraction; refused with + `IndexMismatch`. + +#### Verified + +55 declarations in `tests/indexed-types.ec` compile, including +`single`, `test1` (`(n+1)+m`) and `test2` (`n+(1+m)`). +Negative case (`vec<:n+2>` annotated as the result of `cons x ys`) +errors out cleanly (with a slightly misleading "no matching +operator" message — Phase-6 polish issue). + +### Phase 4 — Theories & smoke tests (DONE) + +Implemented cloning of indexed types and extended the regression +accordingly. `theories/Array.ec` migration deliberately skipped for +the first landing. + +#### Final clone-with-type syntax + +`clone T as T2 with type [k] 'a vec = body` — `[k]` is the optional +idxvar list (mirroring tydecl binder syntax), body is a type +expression that may reference the idx binders (and the tyvars). +Applied textually when `vec<:e>` occurs in the source theory: the +body's idx binders get bound to `e`. + +#### What changed + +- [src/ecParsetree.ml](src/ecParsetree.ml) — `ty_override_def` + widened from `psymbol list * pty` to + `psymbol list * psymbol list * pty` (idxvars, tyvars, body). +- [src/ecParser.mly](src/ecParser.mly) — `clone_override`'s TYPE + rule accepts an optional `[]` prefix; reuses the existing + `idxvars_decl` from Phase 3. +- [src/ecSubst.ml](src/ecSubst.ml) + [.mli](src/ecSubst.mli) — + `subst` gains `sb_idxvar : tindex Mid.t`. `sb_tydef` widened to + `(idxvars, tyvars, body)`. `subst_tindex` consults `sb_idxvar` + first (then `sb_flocal` fallback). `subst_ty`'s `Tconstr`-with- + tydef branch binds *both* the source idxvars (to `ta.indices`) + and tyvars (to `ta.types`) before substituting through the body. + `add_tydef`'s tuple widened correspondingly. +- [src/ecThCloning.ml](src/ecThCloning.ml) + + [.mli](src/ecThCloning.mli) — `ty_ovrd` checks index *and* type + arity. The Phase-3 blanket-refusal `CE_IndexedNotYetSupported` is + replaced by the more precise `CE_IdxArgMism` (with a printer in + [src/ecUserMessages.ml](src/ecUserMessages.ml)). +- [src/ecTheoryReplay.ml](src/ecTheoryReplay.ml) — `BySyntax` case + threads `nidxs` through `transtyvars` and into the `add_tydef` + tuple. +- [src/ecEnv.ml](src/ecEnv.ml), [src/ecAlgTactic.ml](src/ecAlgTactic.ml), + [src/ecSection.ml](src/ecSection.ml), + [src/ecScope.ml](src/ecScope.ml) — mechanical updates to existing + `add_tydef` callers (widen `(ids, ty)` → `(idxs, ids, ty)`). +- [tests/indexed-types.ec](tests/indexed-types.ec) — added three + indexed-type clone cases: drop-the-index to `int`, propagate as + `'a coll<:k>`, use a polynomial `'a coll<:k+1>`. + +#### Verified + +77 declarations in `tests/indexed-types.ec` compile (was 55 after +Phase 3.5). `CE_IdxArgMism` correctly catches wrong-arity idx-binder +lists. + +#### Gaps worth flagging + +- Reaching *into* a cloned theory to call ops whose signature got + touched by an indexed-type override is awkward: `T2.make_vec` came + back as "unknown variable" in experimentation. Looks orthogonal to + indexed types — likely a clone-with-substitution / namespace + artefact — but worth a note. +- No explicit index-instantiation syntax at op call sites + (`f<:idx, ty>`) yet; tests that need index-passing at the call + site rely on inference. A Phase-6 polish could add this. + +### Phase 5 — SMT gating (DONE) + +Replaced the two `assert (List.is_empty *.indices)` panics in +[src/ecSmt.ml](src/ecSmt.ml) (`trans_ty` for `Tconstr`, +`trans_app` for `Fop`) with `raise CanNotTranslate`. Hoisted the +`CanNotTranslate` exception declaration above `trans_ty` so both +call sites are in scope. Wrapped `check`'s `init` and the inner +`make_task` call in `try/with CanNotTranslate` handlers — the user +now sees a `SMT: skipped goal containing constructs not yet +exported to Why3 (e.g. indexed types)` warning followed by +`cannot prove goal`, rather than an anomaly crash. + +Verified: `lemma … (x y : 'a vec<:1>) : x = y \/ x <> y by smt()` +fails cleanly. + +Out of scope (per the original Phase-0 punt): actually translating +indexed types to Why3 — would need monomorphisation per concrete +index used in the goal, or a polymorphic Why3 export taking int +arguments. + +Other vestigial `assert (List.is_empty *.indices)` panics survive +in [src/ecReduction.ml:796](src/ecReduction.ml#L796), +[src/ecInductive.ml:161](src/ecInductive.ml#L161), +[src/ecInductive.ml:181](src/ecInductive.ml#L181), +[src/ecMatching.ml:685](src/ecMatching.ml#L685). These are not on +the SMT path — they belong in the Phase-6 polish pass. + +### Phase 6 — Polish (DONE) + +#### What changed + +- [src/ecPrinting.ml](src/ecPrinting.ml) — new `pp_tindex_atom` / + `pp_tindex_prod` / `pp_tindex_sum` / `pp_tindex` with + `*`-tighter-than-`+` precedence. `pp_type_r`'s `Tconstr` branch + now emits a `<:e, ...>` suffix when the type application carries + indices. Errors and transcripts that formerly printed `'a vec` + for `vec<:n>` (dropping the index entirely, a Phase-0 placeholder) + now show `'a vec<:n>`. +- [src/ecReduction.ml](src/ecReduction.ml) — the Phase-0 + `assert (List.is_empty ta.indices)` in user-rewrite-rule matching + (around line 796) becomes `if not empty then raise NotReducible`. + Indexed-op heads in a rewrite rule no longer crash; they just + fail to match. +- [src/ecMatching.ml](src/ecMatching.ml) — the Phase-0 assert in + `Fop` pattern matching (line 685) becomes a proper length + + polynomial-equality check, with a clean `failure ()` on mismatch. + +#### Left as-is (deliberate) + +- The two asserts in + [src/ecInductive.ml:161](src/ecInductive.ml#L161) and + [src/ecInductive.ml:181](src/ecInductive.ml#L181) — they guard a + recursive-positivity case where the type being defined references + itself. Since Phase-3 Slice-A refuses indexed binders on + datatype/record declarations, the self-reference cannot carry + indices; the asserts are "should never happen" internal-invariant + guards. +- `IndexMismatch` error messages still use `EcTypes.dump_tindex` + (the internal serialisation). Swapping to `EcPrinting.pp_tindex` + would require ecUserMessages to gain a `PPEnv` dependency, which + is out of proportion for an edge-case message. Acceptable for now. +- `CHANGELOG` update: out of scope, that's release admin. + +#### Known remaining gaps (documented but not scheduled) + +(none — Gaps B, C, F all landed.) + +#### Plan for the remaining gaps (B → C → F) + +Original A–F plan: A, D, E landed in the post-Phase-6 batch. The +remaining three are scheduled as follows. + +- **Gap B — polynomial unification beyond naked TIUnivar.** Today + only `?u = poly` is solved. Extend `IxUni` work-list to handle + `?u + k = poly` and (more generally) any equation where exactly + one TIUnivar appears in `lhs - rhs` with coefficient ±1 — solve + `?u := ±(poly - other)` and fail if the result would be negative + or non-integer. Defer multi-univar Diophantine to a separate + constraint-set effort; not motivated by any current example. + Files: [src/ecUnify.ml](src/ecUnify.ml) (`unify_core` IxUni case). + Effort: ~0.5d. +- **Gap C — indexed datatypes / records (non-refining).** Lift the + Phase-3 Slice-A refusal in [src/ecHiInductive.ml](src/ecHiInductive.ml) + and the datatype/record paths in [src/ecScope.ml](src/ecScope.ml). + Constructor signatures may reference idxvars; pattern match does + *not* refine the index. Document explicitly that `vec<:0>` admits + a `VCons`-shaped value at the type level; matches OCaml/Haskell + parametric ADT semantics. Index-refining matches are a separate, + much bigger feature (true dependent typing) and out of scope. + Effort: ~1.5d (datatypes), records similar but smaller. +- **Gap F — SMT translation of indexed types.** Default strategy: + monomorphize per concrete index. `'a vec<:e>` with closed `e` + becomes a fresh memoized Why3 sort `vec_ 'a`; goals + with free index variables still hit `CanNotTranslate`. Add a + per-theory `[smt erase indices]` pragma as escape hatch for + theories where the user has manually discharged the index + discipline (drops indices, translates `'a vec<:e>` → `'a vec`). + Files: [src/ecSmt.ml](src/ecSmt.ml) (the two `CanNotTranslate` + raise sites, `trans_ty` Tconstr case, plus a small monomorphize + cache module). Effort: ~1d for the default; +0.5d for the pragma. + +Order: **B → C → F** (B is smallest and broadens unification; +C is the largest scope expansion but unblocks real ADT users; +F lands last to translate everything we now support). + +### Post-Phase-6 — gaps B / C (DONE) + +- **B** — polynomial unification beyond naked TIUnivar. + New `EcAst.tindex_solve_for_univar` walks the signed difference + of two canonical polynomials and returns `Some (u, value)` when + exactly one TIUnivar has non-zero net coefficient ±1, every mixed + monomial cancels, and the residual is non-negative. Wired into + `unify_ix` *after* the original "naked univar = anything" fast + path (the fast path stays because it handles `?u = ?v` which the + new function refuses — two univars with non-zero net). MVP scope + excludes multi-univar Diophantine and `?u + 1 = n` (free n) where + the residual could be negative without symbolic guarantees. + + **Multi-univar Diophantine is a deliberate non-goal, not a punt.** + Equations like `?m + ?n = 5` admit every `(k, 5-k)` for + `0 <= k <= 5` as a nat solution — no canonical answer, nothing + to "prefer". Guessing one would be wrong; the unifier correctly + refuses. The MVP workaround is explicit index instantiation at + the call site: `make_sum[:2, 3]` instead of bare `make_sum`. If + ever revisited, the only sensible option is + **constraint-accumulate-and-commit** — collect `?m + ?n = 5` as + a pending equation and commit once a later context (arg type, + scrutinee, …) pins one univar and makes the solution unique. + Worth building only if a real use case surfaces; until then, + explicit `[:...]` is the answer. +- **C** — non-refining indexed datatypes and records. + `EcHiInductive.trans_datatype` and `trans_record` now take an + optional `~idxparams` argument; `EcScope.add_types` threads it + through both paths (the previous `no_indices_for` refusal is + removed). Constructor and projector signatures in `EcEnv` build + their result type as `tconstr ~indices ~tyargs path`, so + `INil : 'a vec<:n>` is registered correctly. The positivity + checker drops its `args.indices = []` asserts: indices play no + role in positivity since the recursion is on the type, and indices + carry no embedded type information. + + Match elaboration in `EcTyping.trans_branch` (and the matchfix + twin in `EcHiInductive`) was bug-prone for 0-field constructors: + `opentys` was being called with empty field list, allocating + fresh index univars that never appeared in any unified type and + so stayed dangling at `closed`-check time. Fix: prepend a hand- + built result type to the opened list, anchoring the freshly + allocated univars to a type that participates in the subsequent + unification against the scrutinee's index. + + Out of scope (deliberate): index refinement on match. Pattern + matching does not learn anything about the scrutinee's index from + the constructor that fired; e.g., a `vec<:0>` value still admits + an `ICons`-shaped pattern at the type level. Matches OCaml/Haskell + parametric ADT semantics. True dependent matching is a separate, + much larger feature and not on the roadmap. + + Also out of scope: **per-constructor result indices** (GADT-style). + Every constructor's result type is hard-wired to + `tconstr ~indices ~tyargs path` using the type's *own* idxvars + (see [src/ecEnv.ml:794-798]). So every ctor is universally + quantified over the index just like over type variables: `INil` + has type `forall n 'a. 'a ivec<:n>`, valid at every index. The + index carries no information about which constructor fired. + Achieving the GADT-style declaration + ``` + type [n] 'a vec = + | VNil : 'a vec<:0> + | VCons of 'a & 'a vec<:n> : 'a vec<:n+1> + ``` + would require (1) per-constructor result-type syntax (~1d of + parser/elaborator plumbing) AND (2) index refinement on match + (much larger — genuine dependent matching, intersects with SMT + discharge of unification, new machinery in `trans_branch` and a + refinement-aware unifier). Shipping (1) without (2) would be + worse than the current uniform-indices behavior because users + would expect refinement and not get it. + + Verified: 6 new declarations in `tests/indexed-types.ec` covering + constructor application, plain match, matchfix, indexed records, + and field projection (139 declarations total). Non-indexed + datatypes and records continue to compile unchanged. + +### Post-Phase-6 — gap F (DONE) + +- **F** — SMT translation of indexed types via per-concrete-index + monomorphisation. + + The two former `CanNotTranslate` raise sites in + [src/ecSmt.ml](src/ecSmt.ml) (`trans_ty` Tconstr / `trans_app` + Fop) now check whether all indices reduce to closed integers via + the new `EcAst.tindex_to_int`. Closed indices dispatch to fresh + monomorphised symbols; non-closed indices still raise + `CanNotTranslate`, preserving the per-goal skip behaviour + (warning emitted, lemma falls through to "no provers", no crash). + + New caches in `tenv`: `te_ty_idx` and `te_op_idx`, both + string-keyed by `path<:i,j,...>`. New helpers `trans_pty_idx`, + `trans_tydecl_idx`, `trans_op_idx`, `create_op_idx`. The + declaration paths substitute idxvars by `TIConst` integers via + `EcCoreSubst.f_subst_init ~idx:...` then build a fresh Why3 + sort/lsymbol named `__...`. Constructors and + projectors of indexed datatypes/records get their per-index + variants populated as a side-effect of `trans_tydecl_idx`; + `trans_op_idx` checks `op_kind` and forces type monomorphisation + before falling back to `create_op_idx` for plain ops. + + Plain indexed operators are translated as **abstract** Why3 + symbols (no body). This is sound but limits SMT's ability to + unfold definitions across index instances. Lifting this would + require substituting idxvars in the operator's body (form/expr) + via `Fsubst.f_subst` and recursing through `trans_body`. Punted + for now — concrete bodies for indexed ops are rare in practice + and the user can add explicit lemmas if needed. + + Verified by 4 new SMT-discharge lemmas in `tests/indexed-types.ec` + (160 declarations total): a simple equality on `vec<:5>`, + equality on a constructor of an indexed datatype at index 0, + conjunction of equalities on two distinct concrete-index sorts + (`vec<:3>` and `vec<:5>`), and a use of explicit index + instantiation `vfn[:5]`. Non-indexed SMT discharge unchanged + (smoke-tested via list/match goals). + +### Post-Phase-6 — gaps E / D / A (DONE) + +- **E** — index binders on abbreviations and notations. + `tyvars_decl` was already shared with ops/preds/axioms via + Phase-3 Slice B; abbreviation and notation rules now use + `mixed_tyvars_decl` too. New `ab_idx` / `nt_idx` fields on + `pabbrev` / `pnotation`; `ecHiNotations` threads them via + `~idxparams` on `transtyvars`. +- **D** — investigation. The Phase-4 "T2.make_vec unknown after + clone-with-override" report turned out to be a misuse of the + alias `=` operator instead of the inline `<-` operator (alias + creates a new name that requires explicit qualification; inline + propagates the body and adopts the source signature). Both modes + work correctly. While tracing, `fresh_tparams` was found to + freshen tyvars but not idxvars — fixed so op_tparams alpha- + renaming covers both. +- **A** — explicit index instantiation at op call sites. New + lexer token `LBRACKETCOLON` (matches `[:` glued, no whitespace). + Grammar: `f[:n+1]` provides indices; `f<:int>` provides types + (existing); `f[:n+1]<:int>` does both, in that order. Parsetree + `TVIunamed` and ecUnify `tvar_inst.TVIunamed` both widened to + `(idx list * ty list)`; producers updated mechanically. + `EcUnify.openidx` now uses user-supplied indices when given, + falling back to fresh `TIUnivar`s otherwise. Filter logic in + `select_op` validates either side independently when non-empty. + Useful when the op has indices that aren't reachable by argument- + type inference (e.g. `op count [n 'a] : int` called as + `count[:5]<:int>`). + + Verified: 91 declarations in `tests/indexed-types.ec` compile, + including the new explicit-instantiation cases. + +## Idxvars: architectural fragility (TODO: principled treatment) + +The Phase-2 design has idxvars occupy a **hybrid namespace**: +- listed in `h_tvar.idxvars` like type parameters (so they appear + in `ax_tparams`, get printed as "Index variables: …" in the + proof state, etc.); +- but **also** semantically int-typed locals usable in formulas + (per `bind_idx_locals`), in tindex positions (`vec<:n>`), and + bridged at concretize time via `pte_idx_link`. + +Every pass that walks formulas / locals / hypotheses has to be +taught about this hybridness. Each one has been patched ad-hoc: + +- `EcTyping.bind_idx_locals` — register as int local at typecheck. +- `EcEnv.Op.reduce` / `Ax.instantiate` — substitute `Flocal n_lem` + via `f_of_tindex` alongside the tindex substitution. +- `EcProofTerm.pte_idx_link` — record `(idxvar ident, fresh univar)` + pairs so `concretize_env` can synthesise the form binding once + unification pins the univar. +- `EcSmt.lenv_of_tparams_for_hyp` — register each idxvar as an + int constant in `te_lc` so `trans_app`'s `Flocal` case finds it. +- `EcLowGoal.LowSubst.is_eq_for_subst` — skip idxvars during the + formula's free-variable walk (else `LDecl.by_id` errors with + "unknown identifier"). +- `EcMatching` matcher — best-effort index unification on `Fop` + heads, defer-and-retry on mixed-monomial failure. +- `EcUnify.unify_core` — deferred IxUni queue, retry after every + assignment. + +Each fix is small and correct, but the pattern (forget about +idxvars somewhere → mysterious crash → patch the one site) keeps +recurring. Every future feature that touches the form/local/hyp +machinery will need similar care. + +**Architectural directions to consider** (not scheduled): + +1. **Unify idxvars and formula-locals at the AST level.** Make + idxvars "just" int-typed `LD_var` hypotheses with no body, + stored alongside ordinary locals. Carry the "is-idxvar" tag + on the hyp itself rather than a separate `h_tvar.idxvars` + field. Then every existing local-walking pass just works. + Trade-off: tparams.idxvars no longer mirrors tparams.tyvars, + so existing code paths that treat them analogously need a + different anchor. + +2. **A dedicated `Findex` form constructor.** `Findex of tindex` + typed as int, eagerly used wherever an idxvar appears as an + int term. Substitution rules walk into the `tindex` via + `tindex_subst`. Removes the need for `pte_idx_link` and the + `f_of_tindex` partiality. Trade-off: introducing a new `f_node` + variant is wide and touches every form pattern-match. + +3. **Status quo with an audit checklist.** Document the seven + patch sites above as a "when adding a pass that touches forms, + check these" checklist. Cheapest, but the bug-of-the-week + pattern continues. + +If a fourth user surfaces a fourth crash of this shape, (1) or (2) +becomes worth the upfront cost. + +## Critical path & open risks + +- Phases 0 → 1 → 2 are sequential; the rest can branch. +- **Risk:** the shared-namespace invariant (Phase 2 step 2) is + enforced by panic. If any existing pass binds an int-typed local to + a non-polynomial formula and that local later appears in a `tindex` + context, EasyCrypt will crash mid-proof. Worth a tactical audit of + `f_bind_local` / `f_subst_local` callers before merging. +- **Open:** index unification variables (Phase 1 step 4) — if the + parser always demands an explicit index, you can defer this + indefinitely. If you want `vec[]` inference, it's needed before + Phase 3 is usable. diff --git a/src/ecAlgTactic.ml b/src/ecAlgTactic.ml index f926a7ff3..efdcbee72 100644 --- a/src/ecAlgTactic.ml +++ b/src/ecAlgTactic.ml @@ -80,7 +80,7 @@ module Axioms = struct let addctt = fun subst x f -> EcSubst.add_opdef subst (xpath x) ([], f) in let subst = - EcSubst.add_tydef EcSubst.empty (xpath tname) ([], cr.r_type) in + EcSubst.add_tydef EcSubst.empty (xpath tname) ([], [], cr.r_type) in let subst = List.fold_left (fun subst (x, p) -> add subst x p) subst crcore in let subst = odfl subst (cr.r_opp |> omap (fun p -> add subst opp p)) in @@ -123,7 +123,7 @@ module Axioms = struct let for1 axname = let ax = EcEnv.Ax.by_path (EcPath.pqname tmod axname) env in - assert (ax.ax_tparams = [] && is_axiom ax.ax_kind); + assert (ax.ax_tparams.tyvars = [] && ax.ax_tparams.idxvars = [] && is_axiom ax.ax_kind); (axname, EcSubst.subst_form subst ax.ax_spec) in List.map for1 axs diff --git a/src/ecAlgebra.ml b/src/ecAlgebra.ml index 2cd7f1aa7..153eb6cef 100644 --- a/src/ecAlgebra.ml +++ b/src/ecAlgebra.ml @@ -75,7 +75,7 @@ type eq = form * form (* -------------------------------------------------------------------- *) let rapp r op args = let opty = toarrow (List.map f_ty args) r.r_type in - f_app (f_op op [] opty) args r.r_type + f_app (f_op op opty) args r.r_type let rzero r = rapp r r.r_zero [] let rone r = rapp r r.r_one [] diff --git a/src/ecAlphaInvHashtbl.ml b/src/ecAlphaInvHashtbl.ml index 653da4a3e..5b34db73c 100644 --- a/src/ecAlphaInvHashtbl.ml +++ b/src/ecAlphaInvHashtbl.ml @@ -78,7 +78,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 (combine_list (EcPath.p_hash p) (List.map ty_hash tys.types)) | 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..3487dc7d1 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,350 @@ 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) + +(* 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 +1576,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 +1590,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 +1602,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 +1627,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 +1671,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 +1709,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 +1760,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 +1815,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 +1855,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..f7d7046dc 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,27 @@ 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 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 + 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..f5735d785 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -217,7 +217,7 @@ and betared st s bd f args = (* -------------------------------------------------------------------- *) and try_reduce_record_projection - (st : state) ((p, _tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, _tys) : EcPath.path * targs) (args : args) = let exception Bailout in @@ -245,7 +245,7 @@ and try_reduce_record_projection (* -------------------------------------------------------------------- *) and try_reduce_fixdef - (st : state) ((p, tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, tys) : EcPath.path * targs) (args : args) = let exception Bailout in @@ -300,7 +300,7 @@ and try_reduce_fixdef let body = EcFol.form_of_expr body in let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + Tvar.f_subst ~freshen:true op.EcDecl.op_tparams.tyvars tys.types body in Some (cbv st subst body (Args.create ty eargs)) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 3f9dae3d1..2964b2a9e 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/ecCoreFol.ml b/src/ecCoreFol.ml index 04a8d03d8..50f2f857f 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,46 @@ 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 + +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 +466,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 +514,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 +1010,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 +1056,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 +1098,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 +1129,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 19291f3f7..371060b5f 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 d045b8f93..3d720534c 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/ecCoreSubst.ml b/src/ecCoreSubst.ml index cb99d5b5f..238e72056 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 diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index f829b8d38..2334e0873 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 @@ -55,8 +57,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 @@ -70,6 +74,8 @@ module Fsubst : sig ?freshen:bool -> ?tu:ty Muid.t -> ?tv:ty Mid.t + -> ?idx:tindex Mid.t + -> ?iu:tindex Muid.t -> ?esloc:expr Mid.t -> unit -> f_subst diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 365253413..1f168c668 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 @@ -294,7 +300,7 @@ let axiomatized_op : axiom = let axbd, axpm = - let bdpm = tparams in + let bdpm = tparams.tyvars in let axpm = List.map EcIdent.fresh bdpm in (CS.Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) axbd, axpm) @@ -310,11 +316,11 @@ let axiomatized_op let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in let tyargs = List.map EcTypes.tvar axpm in - let op = f_op path tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in + let op = f_op path ~tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in let op = f_app op opargs axbd.f_ty in let axspec = f_forall args (f_eq op axbd) in - { ax_tparams = axpm; + { ax_tparams = { idxvars = []; tyvars = axpm }; ax_spec = axspec; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 98e366a6c..5ffeb1e4c 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -6,8 +6,11 @@ open EcTypes open EcCoreFol (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t -type ty_params = ty_param list +type ty_params = { + idxvars : EcIdent.t list; + tyvars : EcIdent.t list; +} + type ty_pctor = [ `Int of int | `Named of ty_params ] type ty_record = diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 5826384a6..47b640fcb 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -829,9 +829,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) @@ -870,11 +873,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 @@ -895,7 +900,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 @@ -945,14 +950,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 @@ -962,7 +967,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 @@ -972,7 +977,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; @@ -2579,11 +2584,11 @@ module Ty = struct | Some { tyd_type = Concrete _ } -> true | _ -> false - let unfold (name : EcPath.path) (args : EcTypes.ty list) (env : env) = + let unfold (name : EcPath.path) (args : EcAst.targs) (env : env) = match by_path_opt name env with | Some ({ tyd_type = Concrete body } as tyd) -> Tvar.subst - (Tvar.init tyd.tyd_params args) + (Tvar.init tyd.tyd_params.tyvars args.types) body | _ -> raise (LookupFailure (`Path name)) @@ -2627,14 +2632,14 @@ module Ty = struct | Datatype _, `Case -> basename ^ "_case" | _, _ -> assert false in - Some (EcPath.pqoname prefix basename, tys) + Some (EcPath.pqoname prefix basename, tys.types) | _ -> None end | _ -> None let get_top_decl (ty : ty) (env : env) = match (ty_hnorm ty env).ty_node with - | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys) + | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys.types) | _ -> None let rebind name ty env = @@ -2740,9 +2745,44 @@ 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 + let tv = + if List.compare_lengths tys.types tparams.tyvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.tyvars tys.types + in + let idx = + if List.compare_lengths tys.indices tparams.idxvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.idxvars tys.indices + in + let fs = + EcCoreSubst.Fsubst.f_subst_init ~freshen:true ~tv ~idx () in + (* 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) @@ -2860,10 +2900,47 @@ 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 + if List.compare_lengths idxs tparams.idxvars <> 0 + && not (List.is_empty idxs) then + raise (LookupFailure (`Path p)); + let idx_map = + if List.is_empty idxs then EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.idxvars idxs + in + let tv_map = + if List.compare_lengths tys tparams.tyvars <> 0 then + EcIdent.Mid.empty + else + List.fold_left2 + (fun m id v -> EcIdent.Mid.add id v m) + EcIdent.Mid.empty tparams.tyvars tys + in + let fs = + EcCoreSubst.Fsubst.f_subst_init + ~freshen:true ~tv:tv_map ~idx:idx_map () in + (* 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) = @@ -2878,15 +2955,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 (* -------------------------------------------------------------------- *) @@ -3117,9 +3194,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; @@ -3335,12 +3422,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 = @@ -3358,17 +3445,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 @@ -3376,10 +3463,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 751a19ab3..ac525927b 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -198,7 +198,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 +347,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 +381,7 @@ module Ty : sig val bind : ?import:bool -> symbol -> t -> env -> env val defined : path -> env -> bool - val unfold : path -> EcTypes.ty list -> env -> EcTypes.ty + val unfold : path -> targs -> env -> EcTypes.ty val hnorm : EcTypes.ty -> env -> EcTypes.ty val decompose_fun : EcTypes.ty -> env -> EcTypes.dom * EcTypes.ty diff --git a/src/ecFol.ml b/src/ecFol.ml index 7a9fbf494..cc89e4437 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -55,7 +55,7 @@ let ts_inv_eqglob mp1 ml mp2 mr = (* -------------------------------------------------------------------- *) let f_op_real_of_int = (* CORELIB *) - f_op CI.CI_Real.p_real_of_int [] (tfun tint treal) + f_op CI.CI_Real.p_real_of_int (tfun tint treal) let f_real_of_int f = f_app f_op_real_of_int [f] treal let f_rint n = f_real_of_int (f_int n) @@ -75,15 +75,15 @@ let destr_rint f = | _ -> destr_error "destr_rint" (* -------------------------------------------------------------------- *) -let fop_int_le = f_op CI.CI_Int .p_int_le [] (toarrow [tint ; tint ] tbool) -let fop_int_lt = f_op CI.CI_Int .p_int_lt [] (toarrow [tint ; tint ] tbool) -let fop_real_le = f_op CI.CI_Real.p_real_le [] (toarrow [treal; treal] tbool) -let fop_real_lt = f_op CI.CI_Real.p_real_lt [] (toarrow [treal; treal] tbool) -let fop_real_add = f_op CI.CI_Real.p_real_add [] (toarrow [treal; treal] treal) -let fop_real_opp = f_op CI.CI_Real.p_real_opp [] (toarrow [treal] treal) -let fop_real_mul = f_op CI.CI_Real.p_real_mul [] (toarrow [treal; treal] treal) -let fop_real_inv = f_op CI.CI_Real.p_real_inv [] (toarrow [treal] treal) -let fop_real_abs = f_op CI.CI_Real.p_real_abs [] (toarrow [treal] treal) +let fop_int_le = f_op CI.CI_Int .p_int_le (toarrow [tint ; tint ] tbool) +let fop_int_lt = f_op CI.CI_Int .p_int_lt (toarrow [tint ; tint ] tbool) +let fop_real_le = f_op CI.CI_Real.p_real_le (toarrow [treal; treal] tbool) +let fop_real_lt = f_op CI.CI_Real.p_real_lt (toarrow [treal; treal] tbool) +let fop_real_add = f_op CI.CI_Real.p_real_add (toarrow [treal; treal] treal) +let fop_real_opp = f_op CI.CI_Real.p_real_opp (toarrow [treal] treal) +let fop_real_mul = f_op CI.CI_Real.p_real_mul (toarrow [treal; treal] treal) +let fop_real_inv = f_op CI.CI_Real.p_real_inv (toarrow [treal] treal) +let fop_real_abs = f_op CI.CI_Real.p_real_abs (toarrow [treal] treal) let f_int_le f1 f2 = f_app fop_int_le [f1; f2] tbool let f_int_lt f1 f2 = f_app fop_int_lt [f1; f2] tbool @@ -119,25 +119,31 @@ let f_decimal (n, (l, f)) = else f_real_add (f_real_of_int (f_int n)) fct (* soft-constructor - xreal *) -let fop_xreal_le = f_op CI.CI_Xreal.p_xle [] (toarrow [txreal; txreal] tbool) +let fop_xreal_le = f_op CI.CI_Xreal.p_xle (toarrow [txreal; txreal] tbool) let fop_interp_ehoare_form = - f_op CI.CI_Xreal.p_interp_form [] (toarrow [tbool; txreal] txreal) + f_op CI.CI_Xreal.p_interp_form (toarrow [tbool; txreal] txreal) -let is_interp_ehoare_form_op (p, tys) = EcPath.p_equal p CI.CI_Xreal.p_interp_form && tys = [] +let is_interp_ehoare_form_op (p, ta) = + EcPath.p_equal p CI.CI_Xreal.p_interp_form + && List.is_empty ta.types + && List.is_empty ta.indices let fop_Ep ty = - f_op CI.CI_Xreal.p_Ep [ty] (toarrow [tdistr ty; toarrow [ty] txreal] txreal) + f_op + CI.CI_Xreal.p_Ep + ~tyargs:[ty] + (toarrow [tdistr ty; toarrow [ty] txreal] txreal) let f_xreal_le f1 f2 = f_app fop_xreal_le [f1; f2] tbool let f_interp_ehoare_form f1 f2 = f_app fop_interp_ehoare_form [f1; f2] txreal let f_Ep ty d f = f_app (fop_Ep ty) [d; f] txreal -let fop_concave_incr = f_op CI.CI_Xreal.p_concave_incr [] (tfun (tfun txreal txreal) tbool) +let fop_concave_incr = f_op CI.CI_Xreal.p_concave_incr (tfun (tfun txreal txreal) tbool) let f_concave_incr f = f_app fop_concave_incr [f] tbool -let f_op_rp2xr = f_op CI.CI_Xreal.p_rp [] (tfun trealp txreal) -let f_op_of_real = f_op CI.CI_Xreal.p_of_real [] (tfun treal trealp) +let f_op_rp2xr = f_op CI.CI_Xreal.p_rp (tfun trealp txreal) +let f_op_of_real = f_op CI.CI_Xreal.p_of_real (tfun treal trealp) let f_rp2xr f = f_app f_op_rp2xr [f] txreal let f_r2rp f = f_app f_op_of_real [f] trealp @@ -145,21 +151,22 @@ let f_r2xr f = f_rp2xr (f_r2rp f) let f_b2r b = f_if b f_r1 f_r0 let f_b2xr b = f_r2xr (f_b2r b) - -let f_xreal_inf = f_op CI.CI_Xreal.p_inf [] txreal +let f_xreal_inf = f_op CI.CI_Xreal.p_inf txreal (* -------------------------------------------------------------------- *) -let tmap aty bty = - tconstr CI.CI_Map.p_map [aty; bty] +let tmap (aty : ty) (bty : ty) = + tconstr ~tyargs:[aty; bty] ?indices:None CI.CI_Map.p_map -let fop_map_cst aty bty = - f_op CI.CI_Map.p_cst [aty; bty] (toarrow [bty] (tmap aty bty)) +let fop_map_cst (aty : ty) (bty : ty) = + f_op CI.CI_Map.p_cst ~tyargs:[aty; bty] + (toarrow [bty] (tmap aty bty)) let fop_map_get aty bty = - f_op CI.CI_Map.p_get [aty; bty] (toarrow [tmap aty bty; aty] bty) + f_op CI.CI_Map.p_get ~tyargs:[aty; bty] + (toarrow [tmap aty bty; aty] bty) let fop_map_set aty bty = - f_op CI.CI_Map.p_set [aty; bty] + f_op CI.CI_Map.p_set ~tyargs:[aty; bty] (toarrow [tmap aty bty; aty; bty] (tmap aty bty)) let f_map_cst aty f = @@ -172,59 +179,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 +735,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 +759,7 @@ let rec f_eq_simpl f1 f2 = when f_equal op1 f_op_real_of_int && f_equal op2 f_op_real_of_int -> f_false - | Fop (op1, []), Fop (op2, []) when + | Fop (op1, _), Fop (op2, _) when (EcPath.p_equal op1 CI.CI_Bool.p_true && EcPath.p_equal op2 CI.CI_Bool.p_false ) || (EcPath.p_equal op2 CI.CI_Bool.p_true && @@ -854,7 +873,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 +941,10 @@ let int_of_form = | SFint x -> x - | SFop ((op, []), [a]) when op_kind op = Some `Int_opp -> + | SFop ((op, _), [a]) when op_kind op = Some `Int_opp -> BI.neg (doit a) - | SFop ((op, []), [a1; a2]) -> begin + | SFop ((op, _), [a1; a2]) -> begin match op_kind op with | Some `Int_add -> BI.add (doit a1) (doit a2) | Some `Int_mul -> BI.mul (doit a1) (doit a2) @@ -938,7 +957,7 @@ let int_of_form = let real_of_form f = match sform_of_form f with - | SFop ((op, []), [a]) -> + | SFop ((op, _), [a]) -> if EcPath.p_equal op CI.CI_Real.p_real_of_int then int_of_form a else None diff --git a/src/ecFol.mli b/src/ecFol.mli index 6be1d1aaf..81b82eee7 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -226,7 +226,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (path * ty list) * (form list) + | SFop of (path * targs) * (form list) | SFhoareF of sHoareF | SFhoareS of sHoareS diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index c3f8e89f6..38136ad7c 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -561,6 +561,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 @@ -713,9 +732,9 @@ let process_delta ?target ((s :rwside), o, p) tc = match op.EcDecl.op_kind with | EcDecl.OB_oper (Some (EcDecl.OP_Plain f)) -> - (snd p, op.EcDecl.op_tparams, f, args, Some (fst p)) + ((snd p).types, op.EcDecl.op_tparams.tyvars, f, args, Some (fst p)) | EcDecl.OB_pred (Some (EcDecl.PR_Plain f)) -> - (snd p, op.EcDecl.op_tparams, f, args, Some (fst p)) + ((snd p).types, op.EcDecl.op_tparams.tyvars, f, args, Some (fst p)) | _ -> tc_error !!tc "the operator cannot be unfolded" end @@ -770,7 +789,7 @@ let process_delta ?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 = Tvar.f_subst ~freshen:true tparams tvi.types body in let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body with EcEnv.NotReducible -> body diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 4d59c0f29..e2864d692 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 ([], 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); @@ -485,7 +501,7 @@ let trans_matchfix let codom = ty_subst ts codom in let opexpr = EcPath.pqname (EcEnv.root env) name in let args = List.map (snd_map (ty_subst ts)) args in - let opexpr = e_op opexpr (List.map tvar tparams) + let opexpr = e_op opexpr ~tyargs:(List.map tvar tparams.tyvars) (toarrow (List.map snd args) codom) in let ebsubst = bind_elocal ts opname opexpr diff --git a/src/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..d21b69c95 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 diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index dcf3440a8..33465fa79 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -40,7 +40,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 = diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 81f3be80d..395e210d1 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -38,15 +38,15 @@ let datatype_proj_path (p : EP.path) (x : symbol) = (* -------------------------------------------------------------------- *) let indsc_of_record (rc : record) = - let targs = List.map tvar rc.rc_tparams in - let recty = tconstr rc.rc_path targs in + let tyargs = List.map tvar rc.rc_tparams.tyvars in + let recty = tconstr_r rc.rc_path (mk_targs ~types:tyargs ()) in let recx = fresh_id_of_ty recty in let recfm = FL.f_local recx recty in let predty = tfun recty tbool in let predx = EcIdent.create "P" in let pred = FL.f_local predx predty in let ctor = record_ctor_path rc.rc_path in - let ctor = FL.f_op ctor targs (toarrow (List.map snd rc.rc_fields) recty) in + let ctor = FL.f_op ctor ~tyargs (toarrow (List.map snd rc.rc_fields) recty) in let prem = let ids = List.map (fun (_, fty) -> (fresh_id_of_ty fty, fty)) rc.rc_fields in let vars = List.map (fun (x, xty) -> FL.f_local x xty) ids in @@ -138,7 +138,7 @@ let ty_params_compat = declaration [decl] (with name [p]). This function provide error context in case the check fails. *) let rec check_positivity_in_decl fct p decl ident = - let check x () = check_positivity_ident fct p decl.tyd_params ident x + let check x () = check_positivity_ident fct p decl.tyd_params.tyvars ident x and iter l f = List.iter f l in match decl.tyd_type with @@ -158,12 +158,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 +180,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 +227,12 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = |> omap (FL.f_forall [x, GTty ty1]) and schemec mode (targs, p) pred (ctor, tys) = - let indty = tconstr p (List.map tvar targs) in + let tyargs = List.map tvar targs.tyvars in + let indty = tconstr ~tyargs p in let xs = List.map (fun xty -> (fresh_id_of_ty xty, xty)) tys in let cargs = List.map (fun (x, xty) -> FL.f_local x xty) xs in let ctor = EcPath.pqoname (EcPath.prefix tpath) ctor in - let ctor = FL.f_op ctor (List.map tvar targs) (toarrow tys indty) in + let ctor = FL.f_op ctor ~tyargs (toarrow tys indty) in let form = FL.f_app pred [FL.f_app ctor cargs indty] tbool in let form = match mode with @@ -247,7 +252,7 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = form and scheme mode (targs, p) ctors = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr ~tyargs:(List.map tvar targs.tyvars) p in let indx = fresh_id_of_ty indty in let indfm = FL.f_local indx indty in let predty = tfun indty tbool in @@ -264,7 +269,7 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = (* -------------------------------------------------------------------- *) let datatype_projectors (tpath, tparams, { tydt_ctors = ctors }) = - let thety = tconstr tpath (List.map tvar tparams) in + let thety = tconstr ~tyargs:(List.map tvar tparams.tyvars) tpath in let do1 i (cname, cty) = let thv = EcIdent.create "the" in @@ -378,7 +383,7 @@ let indsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = FL.f_forall ctor.prc_bds px in - let sc = FL.f_op p (List.map tvar pr.ip_tparams) prty in + let sc = FL.f_op p ~tyargs:(List.map tvar pr.ip_tparams.tyvars) prty in let sc = FL.f_imp (FL.f_app sc prag tbool) pred in let sc = FL.f_imps (List.map for1 pri.pri_ctors) sc in let sc = FL.f_forall [predx, FL.gtty tbool] sc in @@ -391,7 +396,7 @@ let introsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = let bds = List.map (snd_map FL.gtty) pri.pri_args in let clty = toarrow (List.map snd pri.pri_args) tbool in let clag = (List.map (curry FL.f_local) pri.pri_args) in - let cl = FL.f_op p (List.map tvar pr.ip_tparams) clty in + let cl = FL.f_op p ~tyargs:(List.map tvar pr.ip_tparams.tyvars) clty in let cl = FL.f_app cl clag tbool in let for1 ctor = diff --git a/src/ecLexer.mll b/src/ecLexer.mll index 99e22d777..58cea9b99 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -418,6 +418,7 @@ rule main = parse (* string symbols *) | ".." { [DOTDOT ] } | ".[" { [DLBRACKET] } + | "[:" { [LBRACKETCOLON] } | ".`" { [DOTTICK ] } | "{0,1}" { [RBOOL ] } diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 6117f7bcb..08f0c65b8 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -165,10 +165,10 @@ module LowApply = struct with LDecl.LdeclError _ -> raise InvalidProofTerm end - | PTGlobal (p, tys) -> + | PTGlobal (p, idxs, tys) -> (* FIXME: poor API ==> poor error recovery *) let env = LDecl.toenv (hyps_of_ckenv tc) in - (pt, EcEnv.Ax.instantiate p tys env, subgoals) + (pt, EcEnv.Ax.instantiate ~idxs p tys env, subgoals) | PTTerm pt -> let pt, ax, subgoals = check_ `Elim pt subgoals tc in @@ -680,7 +680,6 @@ let tt_apply ?(cutsolver : cutsolver option) (pt : proofterm) (tc : tcenv) = (* let env = FApi.tc_env tc in let ppe = EcPrinting.PPEnv.ofenv env in - (* FIXME: add this to the exception *) Format.eprintf "%a@.should be convertible to:@.%a@.but is not@." (EcPrinting.pp_form ppe) ax (EcPrinting.pp_form ppe) concl; @@ -1510,7 +1509,7 @@ let t_elim_prind_r ?reduce ?accept (_mode : [`Case | `Ind]) tc = | _ -> raise InvalidGoalShape - in t_apply_s p tv ~args:(args @ [f2]) ~sk tc + in t_apply_s p tv.types ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1691,7 +1690,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 @@ -1711,10 +1710,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 @@ -1909,12 +1908,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/ecMatching.ml b/src/ecMatching.ml index 29a4617cb..387ebe329 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -828,7 +828,11 @@ module MEV = struct v let assubst ue ev env = - let subst = f_subst_init ~tu:(EcUnify.UniEnv.assubst ue) () in + let subst = + f_subst_init + ~tu:(EcUnify.UniEnv.assubst ue) + ~iu:(EcUnify.UniEnv.iu_assubst ue) + () in let subst = EV.fold (fun x m s -> Fsubst.f_bind_mem s x m) ev.evm_mem subst in let subst = EV.fold (fun x mp s -> EcFol.f_bind_mod s x mp env) ev.evm_mod subst in let seen = ref Sid.empty in @@ -1048,7 +1052,25 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | Fop (op1, tys1), Fop (op2, tys2) -> begin if not (EcPath.p_equal op1 op2) then failure (); - try List.iter2 (EcUnify.unify env ue) tys1 tys2 + 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 is best-effort: a single + naked TIUnivar (e.g. [mk[:?u]] vs [mk[:m+n]]) binds via + my Gap-B path, but a polynomial-against-polynomial with + multiple univars (e.g. [bits[:?u_m + ?u_n]] vs + [bits[:m + n]]) is genuinely ambiguous in isolation — + defer to arg matching, which typically constrains the + individual univars first. So we try, but tolerate + failures here. Type unification of [tys1.types] is + still mandatory. *) + List.iter2 (fun i1 i2 -> + try EcUnify.unify_idx env ue i1 i2 + with EcUnify.UnificationFailure _ -> ()) + tys1.indices tys2.indices; + try + List.iter2 (EcUnify.unify env ue) tys1.types tys2.types with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecPV.ml b/src/ecPV.ml index 04fb55032..e41a87992 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 2707f2e2c..e10aec416 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -14,13 +14,35 @@ 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. *) + + (* Trailing `+` on an idxvar name only makes sense on lemma / + axiom binders (where it injects [0 <= n =>] into the proof + goal). Non-lemma consumers must reject it explicitly so the + mark is never silently dropped. *) + let reject_nonneg_marker + (where : string) + (nonneg : EcParsetree.psymbol list) + = + match nonneg with + | [] -> () + | x :: _ -> + parse_error (EcLocation.loc x) (Some + (Printf.sprintf + "the `+' marker on idxvar `%s' only applies to lemma / \ + axiom binders, not to %s declarations" + (EcLocation.unloc x) where)) + let map_gppterm f a = let fp_head = match a.fp_head with | FPNamed _ as x -> x @@ -88,14 +110,16 @@ let pflist loc ti (es : pformula list) : pformula = List.fold_right (fun e1 e2 -> pf_cons loc ti e1 e2) es (pf_nil loc ti) - let mk_axiom ~locality (x, 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, nonneg, ty, pv, vd, f) k = + { pa_name = x; + pa_idxvars = idx; + pa_idxvars_nneg = nonneg; + pa_tyvars = ty; + pa_pvars = pv; + pa_vars = vd; + pa_formula = f; + pa_kind = k; + pa_locality = locality; } let mk_simplify l = if l = [] then @@ -428,6 +452,7 @@ %token DECLARE %token DELTA %token DLBRACKET +%token LBRACKETCOLON %token DO %token DONE %token DOT @@ -930,11 +955,27 @@ tyvar_byname1: | x=tident EQ ty=loc(type_exp) { (x, ty) } tyvar_annot: -| lt = plist1(loc(type_exp), COMMA) { TVIunamed lt } +| lt = plist1(loc(type_exp), COMMA) { TVIunamed ([], lt) } | lt = plist1(tyvar_byname1, COMMA) { TVInamed lt } +(* Explicit op-index instantiation, e.g. `f[:n+1]` or `f[:n,m]<:int>`. + The `[:` form is parsed as a single LBRACKETCOLON token by the + lexer to avoid clashes with list literals. *) +%inline idx_app: +| LBRACKETCOLON ix=plist1(pindex, COMMA) RBRACKET { ix } + %inline tvars_app: -| LTCOLON k=loc(tyvar_annot) GT { k } +| LTCOLON k=loc(tyvar_annot) GT + { k } +| ix=loc(idx_app) + { mk_loc ix.pl_loc (TVIunamed (ix.pl_desc, [])) } +| ix=idx_app LTCOLON k=loc(tyvar_annot) GT + { match k.pl_desc with + | TVIunamed ([], tys) -> + mk_loc k.pl_loc (TVIunamed (ix, tys)) + | TVIunamed (_, _) | TVInamed _ -> + parse_error k.pl_loc + (Some "cannot mix explicit indices with named-tyvar syntax") } (* -------------------------------------------------------------------- *) %inline sexpr: f=sform { mk_loc f.pl_loc (Expr f) } @@ -1302,17 +1343,61 @@ pgtybindings: (* Type expressions *) simpl_type_exp: -| UNDERSCORE { PTunivar } -| x=qident { PTnamed x } -| x=tident { PTvar x } -| tya=type_args x=qident { PTapp (x, tya) } -| GLOB m=loc(mod_qident) { PTglob m } -| LPAREN ty=type_exp RPAREN { ty } +| UNDERSCORE { PTunivar } +| x=qident { PTnamed x } +| x=qident is=idx_args { PTapp (x, [], is) } +| x=tident { PTvar x } +| tya=type_args x=qident is=loption(idx_args) { PTapp (x, tya, is) } +| GLOB m=loc(mod_qident) { PTglob m } +| LPAREN ty=type_exp RPAREN { ty } type_args: | ty=loc(simpl_type_exp) { [ty] } | LPAREN tys=plist2(loc(type_exp), COMMA) RPAREN { tys } +(* Indexed-type index arguments: a comma-separated list of polynomial + expressions enclosed between `<:` and `>`, e.g. `'a vec<:n+1>` or + `('a, 'b) map<:n, m>`. We reuse the LTCOLON/GT framing already used + for operator type-variable instantiation (`f<:int>`); a square- + bracket framing would conflict with `mod_update_fun`'s codepos + ranges in `module M = N with { proc f [ var x : T [..] ] }`. *) +idx_args: +| LTCOLON xs=plist1(pindex, COMMA) GT { xs } + +(* Index-expression sub-grammar (polynomial fragment over the + naturals). Precedence: `*` binds tighter than `+`. *) +pindex_atom: +| x=lident { mk_loc x.pl_loc (PIvar x) } +| n=loc(UINT) + { mk_loc n.pl_loc (PIint n.pl_desc) } +| 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)) } + +(* 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`. + + A trailing `+` on an identifier marks it as "non-negative by + assumption": on lemma / axiom binders this adds a [0 <= n] + hypothesis to the proof goal. Ignored on other binder sites. *) +idxvar_item: +| x=lident PLUS { (x, true) } +| x=lident { (x, false) } + +idxvars_decl: +| LBRACE xs=idxvar_item+ RBRACE { xs } + type_exp: | ty=simpl_type_exp { ty } | ty=plist2(loc(simpl_type_exp), STAR) { PTtuple ty } @@ -1685,7 +1770,10 @@ typarams: { (xs : ptyparams) } %inline tyd_name: -| tya=typarams x=ident { (tya, x) } +| idx=loption(idxvars_decl) tya=typarams x=ident + { let nonneg = idx |> List.filter snd |> List.map fst in + reject_nonneg_marker "type" nonneg; + (List.map fst idx, tya, x) } dt_ctor_def: | x=oident { (x, []) } @@ -1785,38 +1873,62 @@ tyvars_decl: | LBRACKET tyvars=rlist2(tident, empty) RBRACKET { tyvars } +(* Combined `{idx}` then `['a]` binder. Indices come first; both are + independently optional. Returns [(idxvars, nonneg, tyvars_opt)] + where: + - [idxvars] is the idxvar names in order. + - [nonneg] is the subset of idxvars marked with a trailing `+`. + Used by lemma / axiom processing to inject [0 <= n] hypotheses; + other consumers ignore it. + - [tyvars_opt] is [None] when no [...] bracket appeared at all, + matching the legacy [tvs |> omap ...] convention so downstream + `po_tyvars`-style fields keep distinguishing "no binder given" + from "empty binder given". *) +ix_ty_binder: +| idx=idxvars_decl? ty=tyvars_decl? + { let items = EcUtils.odfl [] idx in + let idxs = List.map fst items in + let nonneg = items |> List.filter snd |> List.map fst in + (idxs, nonneg, ty) } + op_or_const: | OP { `Op } | 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, nonneg, po_tyvars) = tvs in + reject_nonneg_marker "operator" nonneg; { 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, nonneg, po_tyvars) = tvs in + reject_nonneg_marker "operator" nonneg; + { 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; @@ -1887,30 +1999,40 @@ 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, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "predicate" nonneg; + { 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, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "predicate" nonneg; + { 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, nonneg, pp_tyvars) = tvs in + reject_nonneg_marker "inductive predicate" nonneg; + { pp_name = x; + pp_idxvars = idxvars; + pp_tyvars = pp_tyvars; pp_def = PPind (odfl [] p, b); pp_tags = []; pp_locality = locality; } } @@ -1951,10 +2073,13 @@ 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, nonneg, nt_tv) = tvs in + reject_nonneg_marker "notation" nonneg; + { 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; @@ -1974,13 +2099,16 @@ 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, nonneg, ab_tv) = tvs in + reject_nonneg_marker "abbreviation" nonneg; { 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; @@ -1995,11 +2123,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, nonneg, tyvars) = tvs in + (x, idxvars, nonneg, tyvars, predvars, pd, f) } axiom_tc: | /* empty */ { PLemma None } @@ -2017,7 +2146,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 } @@ -3804,8 +3933,10 @@ 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) + { let nonneg = idx |> List.filter snd |> List.map fst in + reject_nonneg_marker "clone-with-type" nonneg; + (x, PTHO_Type (`BySyntax (List.map fst idx, ps, t), mode)) } | OP x=qoident tyvars=bracket(tident*)? p=ptybinding1* sty=ioption(prefix(COLON, loc(type_exp))) diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index a4d73b072..22fa763ab 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -109,13 +109,29 @@ type pty_r = | PTtuple of pty list | PTnamed of pqsymbol | PTvar of psymbol - | PTapp of pqsymbol * pty list + | PTapp of pqsymbol * pty list * pindex list | PTfun of pty * pty | PTglob of pmsymbol located and pty = pty_r located +(* Polynomial-fragment index expressions appearing inside `[ ... ]` + on type-constructor applications. The typechecker validates the + sub-grammar (only +, *, non-negative literals, and identifiers + bound as indices). *) +and pindex_r = + | PIvar of psymbol + | PIint of zint + | PIadd of pindex * pindex + | PImul of pindex * pindex + (* `_` placeholder — let the system infer this index by + allocating a fresh [TIUnivar] at typecheck time. *) + | PIhole +and pindex = pindex_r located + type ptyannot_r = - | TVIunamed of pty list + (* Explicit indices first, then explicit types. Either may be empty; + when both are empty, no instantiation was provided. *) + | TVIunamed of pindex list * pty list | TVInamed of (psymbol * pty) list and ptyannot = ptyannot_r located @@ -148,9 +164,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 +489,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 +524,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 +534,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 +549,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; @@ -1194,13 +1215,18 @@ 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; + (* Subset of [pa_idxvars] tagged with a trailing `+` in the binder + (e.g. [{n+ m}] marks [n]). For each such idxvar, [start_lemma] + wraps the proof goal with a [0 <= n =>] hypothesis. *) + pa_idxvars_nneg : psymbol list; + pa_tyvars : ptyparams option; + pa_vars : pgtybindings option; + pa_formula : pformula; + pa_kind : paxiom_kind; + pa_locality : locality; } (* -------------------------------------------------------------------- *) @@ -1340,7 +1366,8 @@ and 'a genoverride = [ | `BySyntax of 'a ] -and ty_override_def = psymbol list * pty +(* (idxvars, tyvars, body) — both binder lists may be empty. *) +and ty_override_def = psymbol list * psymbol list * pty and op_override_def = { opov_tyvars : psymbol list option; diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 22a39940d..69336d48b 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 ([], 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) -> @@ -1104,7 +1141,7 @@ 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 (* -------------------------------------------------------------------- *) let pp_opapp @@ -1555,7 +1592,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 +1760,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 +1771,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 +1851,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 +1898,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 +1916,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 @@ -1993,7 +2030,7 @@ and pp_form_core_r pp_let ~fv:f2.f_fv ppe pp_form_r outer fmt (lp, f1, f2) | Fop (op, tvi) -> - pp_opapp ppe outer fmt (op, tvi, [], Some f.f_ty) + pp_opapp ppe outer fmt (op, tvi.types, [], Some f.f_ty) | Fapp ({f_node = Fop (op, _)}, [{f_node = Fapp ({f_node = Fop (op', tys)}, [f1; f2])}]) @@ -2001,10 +2038,10 @@ and pp_form_core_r && EcPath.p_equal op' EcCoreLib.CI_Bool.p_eq -> let negop = EcPath.pqoname (EcPath.prefix op') "<>" in - pp_opapp ppe outer fmt (negop, tys, [f1; f2], Some f.f_ty) + pp_opapp ppe outer fmt (negop, tys.types, [f1; f2], Some f.f_ty) | Fapp ({f_node = Fop (p, tys)}, args) -> - pp_opapp ppe outer fmt (p, tys, args, Some f.f_ty) + pp_opapp ppe outer fmt (p, tys.types, args, Some f.f_ty) | Fapp (e, args) -> pp_app ppe ~pp_first:pp_form_r ~pp_sub:pp_form_r outer fmt (e, args) @@ -2351,19 +2388,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 +2442,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 +2578,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 +2630,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 +2650,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 +2736,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 +2763,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 +2803,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 +2827,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 +3236,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 +3502,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 +3556,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 +3723,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@]@ " @@ -3750,16 +3858,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 @@ -3793,7 +3901,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 @@ -3833,7 +3941,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = "%ainstance %s with [%a] %a@\n@[ %a@]" pp_locality lc name - (pp_paren (pp_list ",@ " (pp_tyvar ppe))) typ + (pp_paren (pp_list ",@ " (pp_tyvar ppe))) typ.tyvars (pp_type ppe) ty (pp_list "@\n" (fun fmt (name, op) -> diff --git a/src/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 4235c079a..ed10d25f6 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -19,6 +19,16 @@ type pt_env = { pte_hy : LDecl.hyps; pte_ue : EcUnify.unienv; pte_ev : EcMatching.mevmap ref; + (* Idxvars opened by [pt_of_uglobal_r] live in two namespaces + simultaneously: the lemma's body references them in tindex + positions (substituted via [fs_idx] to a fresh [TIUnivar]) and + in formula positions as int-typed [Flocal]. The tindex side + resolves through the unifier; the formula side does not, so + [concretize] would leave dangling [Flocal n_lem] nodes. We + record the (lemma idxvar ident, fresh tindex univar) pairs + here so [concretize_env] can synthesise the missing form + bindings once the tindex univar is resolved. *) + pte_idx_link : (EcIdent.t * EcUid.uid) list ref; } type pt_ev = { @@ -82,18 +92,22 @@ let ptenv pe hyps (ue, ev) = { pte_pe = pe; pte_hy = hyps; pte_ue = EcUnify.UniEnv.copy ue; - pte_ev = ref ev; } + pte_ev = ref ev; + pte_idx_link = ref []; } (* -------------------------------------------------------------------- *) let copy pe = - ptenv pe.pte_pe pe.pte_hy (pe.pte_ue, !(pe.pte_ev)) + let cp = ptenv pe.pte_pe pe.pte_hy (pe.pte_ue, !(pe.pte_ev)) in + cp.pte_idx_link := !(pe.pte_idx_link); + cp (* -------------------------------------------------------------------- *) let ptenv_of_penv (hyps : LDecl.hyps) (pe : proofenv) = { pte_pe = pe; pte_hy = hyps; pte_ue = PT.unienv_of_hyps hyps; - pte_ev = ref EcMatching.MEV.empty; } + pte_ev = ref EcMatching.MEV.empty; + pte_idx_link = ref []; } (* -------------------------------------------------------------------- *) let rec get_head_symbol (pt : pt_env) (f : form) = @@ -106,12 +120,76 @@ let rec get_head_symbol (pt : pt_env) (f : form) = | _ -> f (* -------------------------------------------------------------------- *) +(* Bridge bound form-evars and tindex univars in [pte_idx_link]: + + - If the form-evar [fresh] got bound to a form that projects into a + [tindex] (e.g. [Flocal m_lem]), resolve the tindex univar [u] + accordingly so [closed ue] succeeds. + - If the tindex univar [u] got resolved to a [TIVar tid] / [TIConst k] + by index unification (e.g. via [word<:?u> = word<:m_lem>] in a + bound-var type), set the form-evar [fresh] to the matching form + so [MEV.filled] succeeds. + + The matcher binds either side independently; this bridge keeps the + two namespaces in sync prior to the [can_concretize] check. *) +let propagate_idx_link (pt : pt_env) : unit = + let iu = EcUnify.UniEnv.iu_assubst pt.pte_ue in + List.iter (fun (fresh, u) -> + let fresh_set = + match EcMatching.MEV.get fresh `Form !(pt.pte_ev) with + | Some (`Set (`Form _)) -> true + | _ -> false + in + let u_resolved = + match EcUid.Muid.find_opt u iu with + | Some (EcAst.TIUnivar v) when EcUid.uid_equal v u -> None + | x -> x + in + match fresh_set, u_resolved with + | true, _ -> + (match EcMatching.MEV.get fresh `Form !(pt.pte_ev) with + | Some (`Set (`Form f)) -> + (match EcCoreFol.tindex_of_form f with + | Some ti -> + (try EcUnify.unify_idx (LDecl.toenv pt.pte_hy) + pt.pte_ue (EcAst.TIUnivar u) ti + with EcUnify.UnificationFailure _ -> ()) + | None -> ()) + | _ -> ()) + | false, Some ti -> + (match EcCoreFol.f_of_tindex_opt ti with + | Some f when EcMatching.MEV.mem fresh `Form !(pt.pte_ev) + && not (EcMatching.MEV.isset fresh `Form !(pt.pte_ev)) -> + pt.pte_ev := EcMatching.MEV.set fresh (`Form f) !(pt.pte_ev) + | _ -> ()) + | false, None -> ()) + !(pt.pte_idx_link) + let can_concretize (pt : pt_env) = + propagate_idx_link pt; EcMatching.can_concretize !(pt.pte_ev) pt.pte_ue (* -------------------------------------------------------------------- *) let concretize_env pe = - CPTEnv (EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) (LDecl.toenv pe.pte_hy)) + let subst = EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) + (LDecl.toenv pe.pte_hy) in + (* For each (idxvar ident, tindex univar) link recorded by + [pt_of_uglobal_r]: if the tindex univar resolved to a [TIVar + concrete] in the unifier, add a form-level binding + [n_lem -> Flocal concrete] (typed int) so dangling references + in the lemma's body get resolved alongside the tindex side. *) + let iu = EcUnify.UniEnv.iu_assubst pe.pte_ue in + let subst = + List.fold_left (fun s (id, u) -> + match EcUid.Muid.find_opt u iu with + | Some (EcAst.TIVar tid) -> + EcCoreSubst.Fsubst.f_bind_local s id (f_local tid tint) + | Some (EcAst.TIConst k) -> + EcCoreSubst.Fsubst.f_bind_local s id (f_int k) + | _ -> s) + subst !(pe.pte_idx_link) + in + CPTEnv subst (* -------------------------------------------------------------------- *) let concretize_e_form_gen (CPTEnv subst) ids f = @@ -137,7 +215,10 @@ and concretize_e_head ((CPTEnv subst) as cptenv) head = | PTCut (f, s) -> PTCut (Fsubst.f_subst subst f, s) | PTHandle h -> PTHandle h | PTLocal x -> PTLocal x - | PTGlobal (p, tys) -> PTGlobal (p, List.map (ty_subst subst) tys) + | PTGlobal (p, idxs, tys) -> + PTGlobal (p, + List.map (EcCoreSubst.tindex_subst subst) idxs, + List.map (ty_subst subst) tys) | PTTerm pt -> PTTerm (concretize_e_pt cptenv pt) and concretize_e_pt ((CPTEnv subst) as cptenv) pt = @@ -223,12 +304,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; } (* -------------------------------------------------------------------- *) @@ -452,7 +566,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 @@ -517,11 +631,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 = @@ -529,8 +676,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 af3d0509f..64c737063 100644 --- a/src/ecProofTerm.mli +++ b/src/ecProofTerm.mli @@ -35,6 +35,13 @@ type pt_env = { pte_hy : LDecl.hyps; (* local context *) pte_ue : EcUnify.unienv; (* unification env. *) pte_ev : mevmap ref; (* metavar env. *) + (* Link from a lemma's idxvar idents to their fresh tindex-univar + uids. Used by [concretize_env] to bridge tindex resolution and + formula-locals: when [?u_id := TIVar concrete] is set in [pte_ue], + [Flocal n_lem] in the lemma's body is rewritten to [Flocal + concrete] (typed int) by adding a corresponding [fs_loc] entry + to the substitution. *) + pte_idx_link : (EcIdent.t * EcUid.uid) list ref; } type pt_ev = { diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 6dffd0f6d..dcf3439ae 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -233,11 +233,12 @@ let tc1_process_Xhl_formula_xreal tc pf = (* FIXME: TC HOOK - check parameter constraints *) (* ------------------------------------------------------------------ *) let pf_check_tvi (pe : proofenv) (typ : EcDecl.ty_params) (tvi : tvar_inst option) = + let typ = typ.tyvars in match tvi with | None -> () - | Some (EcUnify.TVIunamed tyargs) -> - if List.length tyargs <> List.length typ then + | Some (EcUnify.TVIunamed (_ix, tyargs)) -> + if tyargs <> [] && List.length tyargs <> List.length typ then tc_error pe "wrong number of type parameters (%d, expecting %d)" (List.length tyargs) (List.length typ) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 9740a9f5e..28d0172e5 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 -> @@ -698,14 +716,20 @@ let reduce_local ri hyps x = then try LDecl.unfold x hyps with NotReducible -> raise nohead else raise nohead -let reduce_op ri env nargs p tys = +let reduce_op + (ri : reduction_info) + (env : EcEnv.env) + (nargs : int) + (p : EcPath.path) + (ta : targs) += match ri.delta_p p with | `No -> raise nohead | #Op.redmode as mode -> try - Op.reduce ~mode ~nargs env p tys + Op.reduce ~mode ~nargs env p ta with NotReducible -> raise nohead let is_record env f = @@ -766,13 +790,17 @@ let reduce_user_gen simplify ri env hyps f = let rec doit f ptn = match destr_app f, ptn with - | ({ f_node = Fop (p, tys) }, args), R.Rule (`Op (p', tys'), args') + | ({ f_node = Fop (p, ta) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> + (* User rewrite-rule patterns don't yet carry index args. + Rather than crash, treat indexed-op heads as non-matching. *) + if not (List.is_empty ta.indices) then raise NotReducible; + let tys' = List.map (Tvar.subst tvi) tys' in begin - try List.iter2 (EcUnify.unify env ue) tys tys' + try List.iter2 (EcUnify.unify env ue) ta.types tys' with EcUnify.UnificationFailure _ -> raise NotReducible end; List.iter2 doit args args' @@ -879,11 +907,11 @@ let reduce_logic ri env hyps f p args = then f_false else f_ands (List.map2 f_eq args1 args2) - | (Fop (p1, tys1), args1), (Fop (p2, tys2), args2) + | (Fop (p1, ta1), args1), (Fop (p2, ta2), args2) when EcPath.p_equal p1 p2 && EcEnv.Op.is_record_ctor env p1 && EcEnv.Op.is_record_ctor env p2 - && List.for_all2 (EqTest_i.for_type env) tys1 tys2 -> + && EqTest_i.for_targs env ta1 ta2 -> f_ands (List.map2 f_eq args1 args2) @@ -906,11 +934,11 @@ let reduce_logic ri env hyps f p args = (* -------------------------------------------------------------------- *) let reduce_delta ri env _hyps f = match f.f_node with - | Fop (p, tys) when ri.delta_p p <> `No -> - reduce_op ri env 0 p tys + | Fop (p, ta) when ri.delta_p p <> `No -> + reduce_op ri env 0 p ta - | Fapp ({ f_node = Fop (p, tys) }, args) when ri.delta_p p <> `No -> - let op = reduce_op ri env (List.length args) p tys in + | Fapp ({ f_node = Fop (p, ta) }, args) when ri.delta_p p <> `No -> + let op = reduce_op ri env (List.length args) p ta in f_app_simpl op args f.f_ty | _ -> raise nohead @@ -1063,8 +1091,7 @@ let reduce_head simplify ri env hyps f = let body = EcFol.form_of_expr body in (* FIXME subst-refact can we do both subst in once *) - let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + let body = Tvar.f_subst ~freshen:true op.EcDecl.op_tparams.tyvars tys.types body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1462,8 +1489,8 @@ let rec conv ri env f1 f2 stk = | exception NotConv -> force_head ri env f1 f2 stk end - | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 && List.all2 (EqTest_i.for_type env) ty1 ty2 -> + | Fop(p1, ta1), Fop(p2,ta2) + when EcPath.p_equal p1 p2 && EqTest_i.for_targs env ta1 ta2 -> conv_next ri env f1 stk | Fapp(f1', args1), Fapp(f2', args2) @@ -1745,7 +1772,7 @@ module User = struct let compile ~opts ~prio (env : EcEnv.env) p = let simp = if opts.EcTheory.ur_delta then - let hyps = EcEnv.LDecl.init env [] in + let hyps = EcEnv.LDecl.init env { idxvars = []; tyvars = [] } in fun f -> odfl f (h_red_opt delta hyps f) else fun f -> f in @@ -1779,8 +1806,8 @@ module User = struct let rule = let rec rule (f : form) : EcTheory.rule_pattern = match EcFol.destr_app f with - | { f_node = Fop (p, tys) }, args -> - R.Rule (`Op (p, tys), List.map rule args) + | { f_node = Fop (p, ta) }, args when List.is_empty ta.indices -> (* FIXME *) + R.Rule (`Op (p, ta.types), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fproj (target, i) }, [] -> @@ -1817,7 +1844,7 @@ module User = struct in doit empty_cst rule in let s_bds = Sid.of_list (List.map fst bds) - and s_tybds = Sid.of_list ax.ax_tparams in + and s_tybds = Sid.of_list ax.ax_tparams.tyvars in (* Variables appearing in types and formulas are always, respectively, * type and formula variables. @@ -1889,7 +1916,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 05e238012..35c68b0a2 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -19,6 +19,7 @@ type 'a eqantest = env -> ?alpha:(EcIdent.t * ty) Mid.t -> ?norm:bool -> 'a -> ' module EqTest : sig val for_type_exn : env -> ty -> ty -> unit + val for_targs : targs eqtest val for_type : ty eqtest val for_pv : prog_var eqntest val for_lv : lvalue eqntest diff --git a/src/ecScope.ml b/src/ecScope.ml index 19cddec23..e64b28ee0 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -949,13 +949,32 @@ 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 ?(nneg_idxs : EcIdent.t list = []) ?(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 - let proof = EcCoreGoal.start hyps axd.ax_spec in + (* For each idxvar marked with `+` in the lemma binder, inject + a [0 <= n =>] hypothesis INSIDE the outermost foralls of + the goal (so [pa_vars] auto-intro still fires). Unmarked + idxvars get no such hypothesis. The implications never + leak into the saved [ax_spec]. *) + let mk_imps body = + List.fold_right (fun id acc -> + let h = f_int_le f_i0 (f_local id tint) in + f_imp h acc) + nneg_idxs body + in + let rec push f = + match f.f_node with + | Fquant (Lforall, bds, body) -> + f_forall bds (push body) + | _ -> mk_imps f + in + let proof = EcCoreGoal.start hyps (push axd.ax_spec) in PSCheck proof in let puc = @@ -979,7 +998,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 @@ -1001,8 +1022,7 @@ module Ax = struct if not (EcUnify.UniEnv.closed ue) then hierror "the formula contains free type variables"; - let uidmap = EcUnify.UniEnv.close ue in - let fs = Tuni.subst uidmap in + let fs = EcUnify.UniEnv.close_subst ue in let concl = Fsubst.f_subst fs concl in let tparams = EcUnify.UniEnv.tparams ue in @@ -1031,16 +1051,25 @@ module Ax = struct let pucflags = { puc_smt = axd.ax_smt; puc_local = local; } in let pucflags = (([], None), pucflags) in + (* Map each `+`-marked idxvar name to its EcIdent.t (matching + by name against the just-created [tparams.idxvars]). *) + let nneg_idxs = + let names = List.map unloc ax.pa_idxvars_nneg in + List.filter + (fun id -> List.mem (EcIdent.name id) names) + tparams.idxvars + in + match tc with | None -> let scope = - start_lemma ~strict scope ~name:(unloc ax.pa_name) + start_lemma ~nneg_idxs ~strict scope ~name:(unloc ax.pa_name) pucflags check (axd, None) in let scope = snd (Tactics.process1_r false `Check scope tintro) in None, scope | Some tc -> - start_lemma_with_proof ~strict scope + start_lemma_with_proof ~nneg_idxs ~strict scope (Some tintro) pucflags (mode, mk_loc loc tc) check ~name:(unloc ax.pa_name) axd end @@ -1114,10 +1143,13 @@ 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 + ?(nneg_idxs : EcIdent.t list = []) ?(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 + let scope = start_lemma ~nneg_idxs ~strict scope pucflags check ?name (axd, None) in let scope = tintro |> ofold (fun t sc -> snd (Tactics.process1_r false `Check sc t)) @@ -1283,7 +1315,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 +1345,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 @@ -1321,8 +1355,7 @@ module Op = struct if not (EcUnify.UniEnv.closed ue) then hierror ~loc "this operator type contains free type variables"; - let uidmap = EcUnify.UniEnv.close ue in - let ts = Tuni.subst uidmap in + let ts = EcUnify.UniEnv.close_subst ue in let fs = Fsubst.f_subst ts in let ty = ty_subst ts ty in let tparams = EcUnify.UniEnv.tparams ue in @@ -1391,8 +1424,8 @@ module Op = struct List.fold_left (fun scope (rname, xs, ax, codom) -> let ax = let opargs = List.map (fun (x, xty) -> e_local x xty) xs in - let opapp = List.map tvar tparams in - let opapp = e_app (e_op opname opapp ty) opargs codom in + let opapp = List.map tvar tparams.tyvars in + let opapp = e_app (e_op opname ~tyargs:opapp ty) opargs codom in let subst = EcSubst.add_opdef EcSubst.empty opname ([], opapp) in let ax = EcSubst.subst_form subst ax in @@ -1406,12 +1439,12 @@ module Op = struct in let ax, axpm = - let bdpm = tparams in + let bdpm = tparams.tyvars in let axpm = List.map EcIdent.fresh bdpm in (Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) ax, axpm) in let ax = - { ax_tparams = axpm; + { ax_tparams = { idxvars = []; tyvars = axpm }; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -1426,11 +1459,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 +1480,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 +1492,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 +1591,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 +1615,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 +1640,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 +1662,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 +1677,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 +1711,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 @@ -2274,7 +2308,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; @@ -2282,16 +2316,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; @@ -2302,7 +2339,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 @@ -2327,7 +2367,7 @@ module Ty = struct 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.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."; @@ -2337,7 +2377,7 @@ module Ty = struct let scope = let decl = EcDecl.{ - tyd_params = []; + tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Abstract; tyd_loca = `Global; tyd_clinline = false; @@ -2404,7 +2444,7 @@ module Ty = struct let tvi = List.map (TT.transty tp_tydecl env ue) tvi in let selected = EcUnify.select_op ~filter:(fun _ -> EcDecl.is_oper) - (Some (EcUnify.TVIunamed tvi)) env (unloc op) ue ([], None) + (Some (EcUnify.TVIunamed ([], tvi))) env (unloc op) ue ([], None) in let op = match selected with @@ -2412,13 +2452,13 @@ module Ty = struct | op1::op2::_ -> hierror ~loc:op.pl_loc "ambiguous operator (%s / %s)" - (EcPath.tostring (fst (proj4_1 op1))) - (EcPath.tostring (fst (proj4_1 op2))) - | [((p, _), _, _, _)] -> + (EcPath.tostring (proj3_1 (proj4_1 op1))) + (EcPath.tostring (proj3_1 (proj4_1 op2))) + | [((p, _, _), _, _, _)] -> let op = EcEnv.Op.by_path p env in let opty = Tvar.subst - (Tvar.init op.op_tparams tvi) + (Tvar.init op.op_tparams.tyvars tvi) op.op_ty in (p, opty) @@ -2466,7 +2506,7 @@ module Ty = struct (fun (x, req) -> if not (Mstr.mem x symbs) then let ax = { - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = req; ax_kind = `Lemma; ax_loca = lc; @@ -2481,7 +2521,7 @@ module Ty = struct let t = { pl_loc = pt.pl_loc; pl_desc = Pby (Some [t]) } in let t = { pt_core = t; pt_intros = []; } in let ax = { - ax_tparams = []; + ax_tparams = { idxvars = []; tyvars = [] }; ax_spec = f; ax_kind = `Lemma; ax_smt = false; @@ -2536,7 +2576,7 @@ module Ty = struct let uidmap = EcUnify.UniEnv.close ue in (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) in - if not (List.is_empty (fst ty)) then + if not (List.is_empty (fst ty).tyvars && List.is_empty (fst ty).idxvars) then hierror "ring instances cannot be polymorphic"; let symbols = EcAlgTactic.ring_symbols env kind (snd ty) in @@ -2554,7 +2594,7 @@ module Ty = struct { scope with sc_env = List.fold_left add (let item = - EcTheory.Th_instance (([], snd ty), `Ring cr, tci.pti_loca) in + EcTheory.Th_instance (({ idxvars = []; tyvars = [] }, snd ty), `Ring cr, tci.pti_loca) in let item = EcTheory.mkitem ~import item in EcSection.add_item item scope.sc_env) [p_zmod; p_ring; p_idomain] } @@ -2579,7 +2619,7 @@ module Ty = struct let uidmap = EcUnify.UniEnv.close ue in (EcUnify.UniEnv.tparams ue, ty_subst (Tuni.subst uidmap) ty) in - if not (List.is_empty (fst ty)) then + if not (List.is_empty (fst ty).tyvars && List.is_empty (fst ty).idxvars) then hierror "field instances cannot be polymorphic"; let symbols = EcAlgTactic.field_symbols env (snd ty) in let symbols = check_tci_operators env ty tci.pti_ops symbols in @@ -2596,7 +2636,7 @@ module Ty = struct sc_env = List.fold_left add (let item = - EcTheory.Th_instance (([], snd ty), `Field cr, tci.pti_loca) in + EcTheory.Th_instance (({ idxvars = []; tyvars = [] }, snd ty), `Field cr, tci.pti_loca) in let item = EcTheory.mkitem ~import item in EcSection.add_item item scope.sc_env) [p_zmod; p_ring; p_idomain; p_field] } @@ -2605,7 +2645,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 @@ -2680,7 +2720,7 @@ end module Circuit = struct type preoperator = [ | `Path of path - | `Direct of ty_params * expr + | `Direct of EcIdent.t list * expr | `Form of pformula ] @@ -2786,8 +2826,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) } @@ -2804,7 +2844,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_)); @@ -2835,7 +2875,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 @@ -2872,7 +2912,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_)); @@ -2909,7 +2949,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 @@ -3040,13 +3080,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 @@ -3142,7 +3182,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 @@ -3185,7 +3225,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/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..478ee48ce 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 = @@ -664,17 +664,18 @@ let add_declared_mod to_gen id modty = } let add_declared_ty to_gen path tydecl = - assert (tydecl.tyd_params = []); + assert (tydecl.tyd_params.tyvars = [] && tydecl.tyd_params.idxvars = []); let name = "'" ^ basename path in let id = EcIdent.create name in { to_gen with - tg_params = to_gen.tg_params @ [id]; - tg_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 +696,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 +718,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 +749,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 +794,7 @@ let notation_fv nota = EcIdent.fv_union (Mid.remove id fv) (ty_fv_and_tvar ty)) fv nota.ont_args let generalize_extra_ty to_gen fv = - List.filter (fun id -> Mid.mem id fv) to_gen.tg_params + List.filter (fun id -> Mid.mem id fv) to_gen.tg_params.tyvars let rec generalize_extra_args binds fv = match binds with @@ -828,10 +829,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 +847,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 +866,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 +905,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 +918,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 +931,17 @@ let generalize_opdecl to_gen prefix (name, operator) = | OB_oper (Some body) -> let fv = op_body_fv body operator.op_ty in let extra_t = generalize_extra_ty to_gen fv in - let tparams = extra_t @ operator.op_tparams in + let tparams : ty_params = + { idxvars = operator.op_tparams.idxvars; + tyvars = extra_t @ operator.op_tparams.tyvars; } in let extra_a = generalize_extra_args to_gen.tg_binds fv in let opty = toarrow (List.map snd extra_a) operator.op_ty in - let t_args = List.map tvar tparams in - let eop = e_op path t_args opty in + let t_args = List.map tvar tparams.tyvars in + let eop = e_op path ~tyargs:t_args opty in let e = e_app eop (List.map (fun (id,ty) -> e_local id ty) extra_a) operator.op_ty in - let tosubst = (operator.op_tparams, e) in + let tosubst = (operator.op_tparams.tyvars, e) in let tg_subst = EcSubst.add_opdef to_gen.tg_subst path tosubst in let body = @@ -961,15 +971,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 +1004,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 +1041,13 @@ let generalize_axiom to_gen prefix (name, ax) = generalize_extra_forall ~imply:true to_gen.tg_binds ax.ax_spec in let extra_t = generalize_extra_ty to_gen (fv_and_tvar_f ax_spec) in - let ax_tparams = extra_t @ ax.ax_tparams in + let ax_tparams : ty_params = + { idxvars = ax.ax_tparams.idxvars; + tyvars = extra_t @ ax.ax_tparams.tyvars; } in to_gen, Some (Th_axiom (name, {ax with ax_tparams; ax_spec})) | `Declare -> assert (is_axiom ax.ax_kind); - assert (ax.ax_tparams = []); + assert (ax.ax_tparams.tyvars = [] && ax.ax_tparams.idxvars = []); let to_gen = add_clear to_gen (`Ax path) in let to_gen = { to_gen with tg_binds = add_imp to_gen.tg_binds ax.ax_spec } in @@ -1192,8 +1208,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" @@ -1562,7 +1578,7 @@ and generalize_lc_items (genenv : to_gen) (prefix : path) (items : sc_item list) let genenv_of_scenv (scenv : scenv) : to_gen = { tg_env = Option.get (scenv.sc_top) - ; tg_params = [] + ; tg_params = { idxvars = []; tyvars = [] } ; tg_binds = [] ; tg_subst = EcSubst.empty ; tg_clear = empty_locals } diff --git a/src/ecSmt.ml b/src/ecSmt.ml index f4a167b17..7b1e37403 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -78,6 +78,11 @@ type tenv = { (*---*) tk_known_w3 : (kpattern * w3_known_op) list; (*---*) te_ty : w3ty Hp.t; (*---*) te_op : w3op Hp.t; + (* Per-index monomorphisation caches (Gap F). The key encodes the + path and the canonical integer values of the indices, so that + [vec<:3>] and [vec<:5>] map to distinct fresh Why3 symbols. *) + (*---*) te_ty_idx : (string, w3ty) Hashtbl.t; + (*---*) te_op_idx : (string, w3op) Hashtbl.t; (*---*) te_lc : w3op Hid.t; mutable te_lam : WTerm.term Mta.t; (*---*) te_gen : WTerm.term Hf.t; @@ -93,6 +98,8 @@ let empty_tenv env task (kwty, kw, kwk) = tk_known_w3 = kwk; te_ty = Hp.create 0; te_op = Hp.create 0; + te_ty_idx = Hashtbl.create 0; + te_op_idx = Hashtbl.create 0; te_lc = Hid.create 0; te_lam = Mta.empty; te_gen = Hf.create 0; @@ -265,20 +272,38 @@ 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) + ts.idxvars; + (env, tysyms) (* -------------------------------------------------------------------- *) let instantiate tparams ~textra targs tres tys = @@ -364,6 +389,35 @@ 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 + +(* Try to reduce an index list to a list of native ints. Returns + [None] if any index has free variables, leftover univars, or a + value too large for [int]. The Gap-F monomorphisation requires + closed indices to key the cache. *) +let tindices_to_ints (tis : tindex list) : int list option = + let rec go acc = function + | [] -> Some (List.rev acc) + | ti :: rest -> + match tindex_to_int ti with + | None -> None + | Some z -> + try go (BI.to_int z :: acc) rest + with _ -> None + in go [] tis + +let idx_key (p : path) (idxs : int list) : string = + Printf.sprintf "%s<:%s>" + (EcPath.tostring p) + (String.concat "," (List.map string_of_int idxs)) + +let idx_suffix (idxs : int list) : string = + String.concat "_" (List.map string_of_int idxs) + (* -------------------------------------------------------------------- *) let rec trans_ty ((genv, lenv) as env) ty = match ty.ty_node with @@ -375,8 +429,17 @@ 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) + let id = + if List.is_empty tys.indices then trans_pty genv p + else + (* Gap F — monomorphise per concrete index. If any index has + free variables or unresolved univars, we still cannot + translate this goal. *) + match tindices_to_ints tys.indices with + | None -> raise CanNotTranslate + | Some idxs -> trans_pty_idx genv p idxs + in + WTy.ty_app id (trans_tys env tys.types) | Tfun (t1, t2) -> WTy.ty_func (trans_ty env t1) (trans_ty env t2) @@ -394,6 +457,14 @@ and trans_pty genv p = ts | None -> trans_tydecl genv (p, EcEnv.Ty.by_path p genv.te_env) +and trans_pty_idx genv p idxs = + let key = idx_key p idxs in + match Hashtbl.find_opt genv.te_ty_idx key with + | Some ts -> ts + | None -> + let tydecl = EcEnv.Ty.by_path p genv.te_env in + trans_tydecl_idx genv (p, tydecl, idxs, key) + and trans_tydecl genv (p, tydecl) = let pid = preid_p p in let lenv, tparams = lenv_of_tparams tydecl.tyd_params in @@ -415,7 +486,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 +505,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,6 +533,112 @@ and trans_tydecl genv (p, tydecl) = List.iter (fun (p, wop) -> Hp.add genv.te_op p wop) opts; ts +(* Gap F — translate an indexed instance of a type declaration. The + call site has already canonicalised the indices to a list of native + ints; we substitute every idxvar in the body by the corresponding + integer constant and then create fresh Why3 sort/op symbols, all + memoised under [(p, idxs)]. *) +and trans_tydecl_idx genv (p, tydecl, idxs, key) = + if List.compare_lengths tydecl.tyd_params.idxvars idxs <> 0 then + raise CanNotTranslate; + let idx_subst = + let mapping = + List.fold_left2 + (fun m id v -> Mid.add id (TIConst (BI.of_int v)) m) + Mid.empty tydecl.tyd_params.idxvars idxs + in + EcCoreSubst.f_subst_init ~idx:mapping () + in + let subst_ty = EcCoreSubst.ty_subst idx_subst in + + (* Idxvars are erased at the Why3 level — they have been replaced by + concrete integers. The new sort is parametrised only by tyvars. *) + let pid = + str_p (Printf.sprintf "%s_%s" + (EcPath.tostring p) (idx_suffix idxs)) in + let lenv, tparams = + lenv_of_tparams { tydecl.tyd_params with idxvars = [] } in + ignore key; + + let mangle q = pqoname (prefix q) + (Printf.sprintf "%s_%s" (basename q) (idx_suffix idxs)) in + + let ts, opts, decl = + match tydecl.tyd_type with + | Abstract -> + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + (ts, [], WDecl.create_ty_decl ts) + + | Concrete ty -> + let ty = trans_ty (genv, lenv) (subst_ty ty) in + let ts = WTy.create_tysymbol pid tparams (WTy.Alias ty) in + (ts, [], WDecl.create_ty_decl ts) + + | Datatype dt -> + let ncs = List.length dt.tydt_ctors in + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + + Hashtbl.add genv.te_ty_idx key ts; + + let wdom = + tconstr p + ~indices:(List.map (fun id -> TIVar id) []) + ~tyargs:(List.map tvar tydecl.tyd_params.tyvars) + in + (* Use the just-created [ts] directly rather than recursing + through [trans_ty], which would not find this entry yet + in the cache (the entry uses the original path's idx_key + but [wdom] above carries no indices). *) + let _ = wdom in + let wdom = WTy.ty_app ts (List.map (trans_ty (genv, lenv)) + (List.map tvar tydecl.tyd_params.tyvars)) in + + let for_ctor (c, ctys) = + let wcid = mangle (pqoname (prefix p) c) in + let wctys = List.map (fun t -> trans_ty (genv, lenv) (subst_ty t)) ctys in + let wcls = WTerm.create_lsymbol ~constr:ncs (preid_p wcid) wctys (Some wdom) in + let w3op = plain_w3op ~name:(basename wcid) tparams wcls in + ((c, w3op), (wcls, List.make (List.length ctys) None)) + in + + let opts, wdtype = List.split (List.map for_ctor dt.tydt_ctors) in + (ts, opts, WDecl.create_data_decl [ts, wdtype]) + + | Record (_, rc) -> + let ts = WTy.create_tysymbol pid tparams WTy.NoDef in + + Hashtbl.add genv.te_ty_idx key ts; + + let wdom = WTy.ty_app ts (List.map (trans_ty (genv, lenv)) + (List.map tvar tydecl.tyd_params.tyvars)) in + + let for_field (fname, fty) = + let wfid = mangle (pqoname (prefix p) fname) in + let wfty = trans_ty (genv, lenv) (subst_ty fty) in + let wcls = WTerm.create_lsymbol ~proj:true (preid_p wfid) [wdom] (Some wfty) in + let w3op = plain_w3op ~name:(basename wfid) tparams wcls in + ((fname, w3op), wcls) + in + + let wcid = mangle (EI.record_ctor_path p) in + let wctys = List.map (fun t -> trans_ty (genv, lenv) (subst_ty t)) + (List.map snd rc) in + let wcls = WTerm.create_lsymbol ~constr:1 (preid_p wcid) wctys (Some wdom) in + let w3op = plain_w3op ~name:(basename wcid) tparams wcls in + + let opts, wproj = List.split (List.map for_field rc) in + let wproj = List.map some wproj in + + (ts, (basename wcid, w3op) :: opts, WDecl.create_data_decl [ts, [wcls, wproj]]) + in + + genv.te_task <- WTask.add_decl genv.te_task decl; + Hashtbl.replace genv.te_ty_idx key ts; + List.iter (fun (cname, wop) -> + let cpath = pqoname (prefix p) cname in + Hashtbl.add genv.te_op_idx (idx_key cpath idxs) wop) opts; + ts + (* -------------------------------------------------------------------- *) let trans_memtype ((genv, _) as env) mt = match EcMemory.local_type mt with @@ -471,7 +648,6 @@ let trans_memtype ((genv, _) as env) mt = wty_tuple genv [ty; ty_mem] (* -------------------------------------------------------------------- *) -exception CanNotTranslate let trans_binding genv lenv (x, xty) = let lenv, wty = match xty with @@ -706,7 +882,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) @@ -738,8 +914,16 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = trans_fun env bds body args | Fop (p, ts) -> - let wop = trans_op genv p in - let tys = List.map (trans_ty (genv,lenv)) ts in + let wop = + if List.is_empty ts.indices then trans_op genv p + else + (* Gap F — monomorphise per concrete index, just like the + type path does for [Tconstr] above. *) + match tindices_to_ints ts.indices with + | None -> raise CanNotTranslate + | Some idxs -> trans_op_idx genv p idxs + in + let tys = List.map (trans_ty (genv,lenv)) ts.types in apply_wop genv wop tys args | Flocal x when Hid.mem genv.te_lc x -> @@ -791,7 +975,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,6 +1033,83 @@ and trans_letbinding (genv, lenv) (lp, f1, f2) args = and trans_op (genv:tenv) p = try Hp.find genv.te_op p with Not_found -> create_op ~body:true genv p +(* Gap F — translate an indexed instance of an operator. Constructors + and projectors are populated as a side-effect of [trans_tydecl_idx], + so we trigger the carrying type's monomorphisation first. Plain + indexed operators get a fresh abstract Why3 symbol with idxvars + substituted by their concrete integer values; the body is dropped + in this MVP (treat the op as opaque to SMT, which is sound). *) +and trans_op_idx (genv : tenv) p idxs = + let key = idx_key p idxs in + match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> + let op = EcEnv.Op.by_path p genv.te_env in + (* For constructors / projectors / record-makers, force the + carrying type's monomorphisation: it will populate + [te_op_idx] with all the per-index ctor/proj symbols. *) + let owner = + match op.op_kind with + | OB_oper (Some (OP_Constr (q, _))) + | OB_oper (Some (OP_Proj (q, _, _))) + | OB_oper (Some (OP_Record q)) -> Some q + | _ -> None + in + (match owner with + | None -> () + | Some q -> ignore (trans_pty_idx genv q idxs)); + (match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> create_op_idx genv p idxs key) + +and create_op_idx (genv : tenv) p idxs key = + let op = EcEnv.Op.by_path p genv.te_env in + if List.compare_lengths op.op_tparams.idxvars idxs <> 0 then + raise CanNotTranslate; + + let idx_subst = + let mapping = + List.fold_left2 + (fun m id v -> Mid.add id (TIConst (BI.of_int v)) m) + Mid.empty op.op_tparams.idxvars idxs + in + EcCoreSubst.f_subst_init ~idx:mapping () + in + let op_ty' = EcCoreSubst.ty_subst idx_subst op.op_ty in + + let op_tparams' = { op.op_tparams with idxvars = [] } in + let lenv, wparams = lenv_of_tparams op_tparams' in + let dom, codom = EcEnv.Ty.signature genv.te_env op_ty' in + let textra = + List.filter + (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op_ty'))) + op_tparams'.tyvars in + let textra = + List.map (fun tv -> trans_ty (genv,lenv) (tvar tv)) textra in + let wdom = trans_tys (genv, lenv) dom in + let wcodom = + if ER.EqTest.is_bool genv.te_env codom + then None + else Some (trans_ty (genv, lenv) codom) + in + + match Hashtbl.find_opt genv.te_op_idx key with + | Some wop -> wop + | None -> + let pid = str_p (Printf.sprintf "%s_%s" + (EcPath.tostring p) (idx_suffix idxs)) in + let ls = WTerm.create_lsymbol pid (textra@wdom) wcodom in + let name = ls.WTerm.ls_name.WIdent.id_string in + let w3op = { + w3op_fo = `LDecl ls; + w3op_ta = instantiate wparams ~textra wdom wcodom; + w3op_ho = `HO_TODO (name, textra@wdom, wcodom); + } in + Hashtbl.add genv.te_op_idx key w3op; + let decl = WDecl.create_param_decl ls in + genv.te_task <- WTask.add_decl genv.te_task decl; + w3op + (* -------------------------------------------------------------------- *) and trans_pvar ((genv, lenv) as env) pv ty mem = let pv = NormMp.norm_pvar genv.te_env pv in @@ -1061,7 +1322,7 @@ and create_op ?(body = false) (genv : tenv) p = let lenv, wparams = lenv_of_tparams op.op_tparams in let dom, codom = EcEnv.Ty.signature genv.te_env op.op_ty in let textra = - List.filter (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op.op_ty))) op.op_tparams in + List.filter (fun tv -> not (Mid.mem tv (EcTypes.Tvar.fv op.op_ty))) op.op_tparams.tyvars in let textra = List.map (fun tv -> trans_ty (genv,lenv) (tvar tv)) textra in let wdom = trans_tys (genv, lenv) dom in @@ -1690,7 +1951,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 +1977,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 a94a4738a..15b0fb342 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,22 @@ 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 + let s = { s with sb_idxvar = Mid.add x (TIVar newx) s.sb_idxvar } in + (s, newx) + (* -------------------------------------------------------------------- *) let fresh_tparams (s : subst) (tparams : ty_params) = - 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) = @@ -1150,7 +1216,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 *) @@ -1242,12 +1308,12 @@ let init_tparams (params : (EcIdent.t * ty) list) : subst = (* -------------------------------------------------------------------- *) let open_oper op tys = - let s = List.combine op.op_tparams tys in + let s = List.combine op.op_tparams.tyvars tys in let s = init_tparams s in (subst_ty s op.op_ty, subst_op_kind s op.op_kind) let open_tydecl tyd tys = - let s = List.combine tyd.tyd_params tys in + let s = List.combine tyd.tyd_params.tyvars tys in let s = init_tparams s in subst_tydecl_body s tyd.tyd_type diff --git a/src/ecSubst.mli b/src/ecSubst.mli index 64ae60cf0..6da0cd5a5 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -25,7 +25,7 @@ val is_empty : subst -> bool (* -------------------------------------------------------------------- *) val add_module : subst -> EcIdent.t -> mpath -> subst val add_path : subst -> src:path -> dst:path -> subst -val add_tydef : subst -> path -> (EcIdent.t list * ty) -> subst +val add_tydef : subst -> path -> (EcIdent.t list * EcIdent.t list * ty) -> subst val add_opdef : subst -> path -> (EcIdent.t list * expr) -> subst val add_pddef : subst -> path -> (EcIdent.t list * form) -> subst val add_moddef : subst -> src:path -> dst:mpath -> subst (* Only concrete modules *) diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index d2093c52b..150af207a 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -40,6 +40,10 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IdxArgMism of ovkind * qsymbol +(* Cloning of indexed declarations is not yet supported (Phase 3 + landed the binders but not the index-instantiation surface). *) +| CE_IndexedNotYetSupported of ovkind * qsymbol | CE_NoExceptions exception CloneError of EcEnv.env * clone_error @@ -61,7 +65,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 (* ------------------------------------------------------------------ *) @@ -315,10 +319,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 @@ -327,7 +334,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 2a1c98e1e..7009cc7fe 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -34,6 +34,8 @@ type clone_error = | CE_InvalidRE of string | CE_InlinedOpIsForm of qsymbol | CE_ProofForLemma of qsymbol +| CE_IdxArgMism of ovkind * qsymbol +| CE_IndexedNotYetSupported of ovkind * qsymbol | CE_NoExceptions exception CloneError of EcEnv.env * clone_error @@ -47,7 +49,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/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index d85b49c23..029ee1f6c 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -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,9 +104,9 @@ end = struct let check (b : bool) = if not b then raise CoreIncompatible - let for_tparams rtyvars ntyvars = - let rlen = List.length rtyvars - and nlen = List.length ntyvars in + let for_tparams (rtp : ty_params) (ntp : ty_params) = + let rlen = List.length rtp.tyvars + and nlen = List.length ntp.tyvars in if rlen <> nlen then raise (Incompatible (NotSameNumberOfTyParam (rlen, nlen))) @@ -127,7 +127,7 @@ end = struct let for_ty (env : EcEnv.env) (ue : EcUnify.unienv) (rtyvars, rty) (ntyvars, nty) = for_tparams rtyvars ntyvars; - let subst = CS.Tvar.init rtyvars (List.map tvar ntyvars) in + let subst = CS.Tvar.init rtyvars.tyvars (List.map tvar ntyvars.tyvars) in let rty = CS.Tvar.subst subst rty in try EcUnify.unify env ue rty nty @@ -169,11 +169,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,7 +184,7 @@ end = struct for_tparams params tyd2.tyd_params; - let tparams = List.map tvar params in + let tparams = List.map tvar params.tyvars in let ty_body1 = tyd1.tyd_type in let ty_body2 = EcSubst.open_tydecl tyd2 tparams in @@ -232,7 +232,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 @@ -249,11 +249,11 @@ end = struct check (EcReduction.is_conv ~ri:ri_compatible hyps f1 f2) | OP_Plain { f_node = Fop (p, tys) }, _ -> - let ob1 = get_open_oper (toenv hyps) p tys in + let ob1 = get_open_oper (toenv hyps) p tys.types in for_oper hyps ob1 ob2 | _, OP_Plain { f_node = Fop (p, tys) } -> - let ob2 = get_open_oper (toenv hyps) p tys in + let ob2 = get_open_oper (toenv hyps) p tys.types in for_oper hyps ob1 ob2 | OP_Constr (p1, i1), OP_Constr (p2, i2) -> @@ -281,11 +281,11 @@ end = struct check (EcReduction.is_conv hyps f1 f2) | PR_Plain { f_node = Fop (p, tys) }, _ -> - let pb1 = get_open_pred (toenv hyps) p tys in + let pb1 = get_open_pred (toenv hyps) p tys.types in for_pred hyps pb1 pb2 | _, PR_Plain { f_node = Fop (p, tys) } -> - let pb2 = get_open_pred (toenv hyps) p tys in + let pb2 = get_open_pred (toenv hyps) p tys.types in for_pred hyps pb1 pb2 | PR_Ind pr1, PR_Ind pr2 -> @@ -304,7 +304,7 @@ end = struct for_tparams oper1.op_tparams oper2.op_tparams; let oty1, okind1 = oper1.op_ty, oper1.op_kind in - let tparams = List.map tvar params in + let tparams = List.map tvar params.tyvars in let oty2, okind2 = EcSubst.open_oper oper2 tparams in if not (EcReduction.EqTest.for_type env oty1 oty2) then @@ -454,14 +454,14 @@ let for_op_path subst ~opath ~ops p = 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 (* -------------------------------------------------------------------- *) @@ -478,14 +478,15 @@ 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 decl = - { tyd_params = nargs; + { tyd_params = nargs_p; tyd_type = Concrete ntyd; tyd_loca = otyd.tyd_loca; tyd_clinline = (mode <> `Alias); @@ -502,8 +503,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; @@ -514,9 +515,10 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd end | `Direct ty -> begin - assert (List.is_empty otyd.tyd_params); + assert (List.is_empty otyd.tyd_params.tyvars + && List.is_empty otyd.tyd_params.idxvars); let decl = - { tyd_params = []; + { tyd_params = { idxvars = []; tyvars = [] }; tyd_type = Concrete ty; tyd_loca = otyd.tyd_loca; tyd_clinline = (mode <> `Alias); @@ -533,7 +535,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 = @@ -546,10 +550,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 @@ -559,7 +563,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 @@ -609,13 +613,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)); @@ -669,15 +673,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 @@ -693,7 +698,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 @@ -786,13 +791,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)); @@ -803,9 +808,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; @@ -821,7 +827,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) @@ -1076,7 +1082,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 @@ -1129,7 +1135,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 @@ -1182,7 +1188,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..174c5a1b4 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -38,7 +38,7 @@ let f_op_app 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 cd32c69e5..c7bd80bf7 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 @@ -152,7 +152,11 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol +| IndexMismatch of tindex * tindex | DuplicatedTyVar +| DuplicatedIndexVar of symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | DuplicatedException of qsymbol @@ -227,6 +231,8 @@ let unify_or_fail (env : EcEnv.env) ue loc ~expct:ty1 ty2 = let tyinst = ty_subst (Tuni.subst uidmap) in tyerror loc env (TypeMismatch ((tyinst ty1, tyinst ty2), (tyinst t1, tyinst t2))) + | `IxUni (i1, i2) -> + tyerror loc env (IndexMismatch (i1, i2)) (* -------------------------------------------------------------------- *) let add_glob (m:Sx.t) (x:prog_var) : Sx.t = @@ -354,7 +360,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 +404,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 @@ -501,11 +507,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 +521,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 +561,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 +1116,41 @@ 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 nidx = List.length idxargs in + let expected_ix = List.length tydecl.tyd_params.idxvars in if nargs <> expected then tyerror ty.pl_loc env (InvalidTypeAppl (name, expected, nargs)); + if nidx <> expected_ix then + tyerror ty.pl_loc env (InvalidIndexAppl (name, expected_ix, nidx)); + let tyargs = transtys tp env ue tyargs in - tconstr p tyargs + let indices = List.map (transtindex env ue) idxargs in + tconstr ~indices ~tyargs p end | PTglob gp -> let mo,_ = trans_msymbol env gp in @@ -1107,8 +1159,34 @@ let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = and transtys tp (env : EcEnv.env) ue tys = List.map (transty tp env ue) tys +(* Translate a parsed [pindex] to a [tindex]. Identifiers must be + bound as index variables in [ue]. The grammar guarantees we never + see a non-polynomial shape; the only typing-time check is the + variable lookup. *) +and transtindex (env : EcEnv.env) (ue : EcUnify.unienv) (pi : pindex) : tindex = + match pi.pl_desc with + | PIvar { pl_desc = name; pl_loc = loc } -> + begin match EcUnify.UniEnv.getnamed_idx ue name with + | Some id -> TIVar id + | None -> tyerror loc env (UnboundIndexVariable name) + end + | PIint n -> + (* Lexer only produces non-negative UINTs, but defensively. *) + if EcBigInt.sign n < 0 then + tyerror pi.pl_loc env (UnboundIndexVariable "negative literal"); + TIConst n + | PIadd (a, b) -> + TIAdd (transtindex env ue a, transtindex env ue b) + | PImul (a, b) -> + TIMul (transtindex env ue a, transtindex env ue b) + | 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 +1220,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,7 +1238,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in - let reccty = tconstr recp (List.map tvar recty.tyd_params) in + let reccty = tconstr ~tyargs:(List.map tvar recty.tyd_params.tyvars) recp in let reccty, rectvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in let fields = List.fold_left @@ -1182,7 +1260,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let fty = snd (List.nth rec_ i) in let fty, _ = EcUnify.UniEnv.openty ue recty.tyd_params - (Some (EcUnify.TVIunamed rectvi)) fty + (Some (EcUnify.TVIunamed ([], rectvi))) fty in (try EcUnify.unify env ue pty fty with EcUnify.UnificationFailure _ -> assert false); @@ -1214,8 +1292,10 @@ let transpattern env ue (p : EcParsetree.plpattern) = (* -------------------------------------------------------------------- *) let transtvi env ue tvi = match tvi.pl_desc with - | TVIunamed lt -> - EcUnify.TVIunamed (List.map (transty tp_relax env ue) lt) + | TVIunamed (ix, lt) -> + EcUnify.TVIunamed + ( List.map (transtindex env ue) ix + , List.map (transty tp_relax env ue) lt ) | TVInamed lst -> let add locals (s, t) = @@ -1282,7 +1362,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 +1380,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 = + tconstr recp + ~indices:(List.map (fun id -> EcAst.TIVar id) recty.tyd_params.idxvars) + ~tyargs:(List.map tvar recty.tyd_params.tyvars) in let reccty, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let tysopn = Tvar.init recty.tyd_params rtvi in + let tysopn = Tvar.init recty.tyd_params.tyvars rtvi in let fields = List.fold_left @@ -1376,7 +1459,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 +1482,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 ([], 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 +1573,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 @@ -1753,8 +1851,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 @@ -1781,7 +1879,7 @@ let i_asgn_lv (_loc : EcLocation.t) (_env : EcEnv.env) lv e = match lv with | Lval lv -> i_asgn (lv, e) | LvMap ((op,tys), x, ei, ty) -> - let op = e_op op tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in + let op = e_op op ~tyargs:tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in i_asgn (LvVar (x,ty), e_app op [e_var x ty; ei; e] ty) let i_rnd_lv loc env lv e = @@ -2241,7 +2339,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let eval_supdate env sup si = match sup with | Pups_add (s, after) -> - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let s = transstmt env ue s in let ts = Tuni.subst (UE.close ue) in if after then @@ -2262,7 +2360,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = (* Insert an if with condition `e` with body `tl` *) | Pupc_add (e, after) -> let loc = e.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e, ty = transexp env `InProc ue e in let ts = Tuni.subst (UE.close ue) in let ty = ty_subst ts ty in @@ -2275,7 +2373,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = (* Change the condition expression to `e` for a conditional instr `i` *) | Pupc_mod e -> begin let loc = e.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e, ty = transexp env `InProc ue e in let ts = Tuni.subst (UE.close ue) in let ty = ty_subst ts ty in @@ -2304,7 +2402,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 +2428,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let asgn = EcModules.lv_of_list pvs |> omap (fun lv -> let rty = ttuple (List.snd p) in let proj = EcInductive.datatype_proj_path typ cn in - let proj = e_op proj (List.snd tyinst) (tfun e.e_ty (toption rty)) in + let proj = e_op proj ~tyargs:(List.snd tyinst) (tfun e.e_ty (toption rty)) in let proj = e_app proj [e] (toption rty) in let proj = e_oget proj rty in i_asgn (lv, proj)) @@ -2377,7 +2475,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = let ret = match fd.f_ret, pupdate_res with | Some e, Some e' -> let loc = e'.pl_loc in - let ue = UE.create (Some []) in + let ue = UE.create (Some { EcDecl.idxvars = []; tyvars = [] }) in let e', ty = transexp env `InProc ue e' in unify_or_fail env ue loc ~expct:e.e_ty ty; let ts = Tuni.subst (UE.close ue) in @@ -2550,7 +2648,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 *) @@ -2949,7 +3047,7 @@ and translvalue ue (env : EcEnv.env) lvalue = let esig = Tuni.subst_dom uidmap 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 @@ -3045,7 +3143,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 +3210,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 +3231,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 +3254,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 @@ -3546,12 +3644,12 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = let (ctor, fields, (rtvi, reccty)) = let proj (recp, name, (rtvi, reccty), pty, arg) = let proj = EcPath.pqname recp name in - let proj = f_op proj rtvi (tfun reccty pty) in + let proj = f_op proj ~tyargs:rtvi (tfun reccty pty) in f_app proj [arg] pty in trans_record env ue ((fun f -> let f = transf env f in (f, f.f_ty)), proj) (f.pl_loc, b, fields) in - let ctor = f_op ctor rtvi (toarrow (List.map snd fields) reccty) in + let ctor = f_op ctor ~tyargs:rtvi (toarrow (List.map snd fields) reccty) in f_app ctor (List.map fst fields) reccty | PFproj (subf, x) -> begin @@ -3564,12 +3662,12 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = | _ :: _ :: _ -> tyerror x.pl_loc env (AmbiguousProj (unloc x)) - | [(op, tvi), pty, subue] -> + | [(op, ixs, tvi), pty, subue] -> EcUnify.UniEnv.restore ~src:subue ~dst:ue; let rty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (tfun subf.f_ty rty) pty with EcUnify.UnificationFailure _ -> assert false); - f_app (f_op op tvi pty) [subf] rty + f_app (f_op op ~indices:ixs ~tyargs:tvi pty) [subf] rty end | PFproji (psubf, i) -> begin diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 1080fdb6d..67ec7a22f 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 @@ -145,7 +145,11 @@ type tyerror = | AmbiguousProj of qsymbol | AmbiguousProji of int * ty | InvalidTypeAppl of qsymbol * int * int +| InvalidIndexAppl of qsymbol * int * int +| UnboundIndexVariable of symbol +| IndexMismatch of tindex * tindex | DuplicatedTyVar +| DuplicatedIndexVar of symbol | DuplicatedLocal of symbol | DuplicatedField of symbol | DuplicatedException of qsymbol @@ -212,8 +216,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..e8b26b23f 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -13,7 +13,7 @@ module Sp = EcPath.Sp module TC = EcTypeClass (* -------------------------------------------------------------------- *) -type pb = [ `TyUni of ty * ty ] +type pb = [ `TyUni of ty * ty | `IxUni of tindex * tindex ] exception UnificationFailure of pb exception UninstantiateUni @@ -71,25 +71,71 @@ module UnifyCore = struct end (* -------------------------------------------------------------------- *) -let unify_core (env : EcEnv.env) (uf : UF.t) pb = +type unienv_r = { + ue_uf : UF.t; + ue_named : EcIdent.t Mstr.t; + ue_decl : EcIdent.t list; + ue_closed : bool; + (* Indices live in their own namespace, separate from type variables. + They are always closed (declared up front, no on-demand creation). *) + ue_idxnamed : EcIdent.t Mstr.t; + ue_idxdecl : EcIdent.t list; + (* Index-univar machinery (Phase 3.5). [ue_iuf] holds assignments for + resolved univars; [ue_iuf_alloc] tracks the set of all index uids + ever allocated, so [close] can detect leftover unresolved ones. *) + ue_iuf : tindex Muid.t; + ue_iuf_alloc : Suid.t; +} + +type unienv = unienv_r ref + +(* -------------------------------------------------------------------- *) +(* Index-univar helpers — defined at top level so [unify_core] can use + them. All operate on a [unienv ref]. *) + +let resolve_tindex (ue : unienv) : tindex -> tindex = + let rec doit ti = + match ti with + | TIUnivar u -> begin + match Muid.find_opt u (!ue).ue_iuf with + | None -> ti + | Some ti -> doit ti + end + | TIVar _ | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = doit l in + let r' = doit r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = doit l in + let r' = doit r in + if l == l' && r == r' then ti else TIMul (l', r') + in doit + +(* -------------------------------------------------------------------- *) +let unify_core (env : EcEnv.env) (ue : unienv) (pb : pb) = let failure () = raise (UnificationFailure pb) in - let uf = ref uf in - let pb = let x = Queue.create () in Queue.push pb x; x in + let pb_q = let x = Queue.create () in Queue.push pb x; x in + let push p = Queue.push p pb_q in + + let get_uf () = (!ue).ue_uf in + let set_uf u = ue := { !ue with ue_uf = u } in + let upd_uf f = set_uf (f (get_uf ())) in let ocheck i t = - let i = UF.find i !uf in + let i = UF.find i (get_uf ()) in let map = Hint.create 0 in let rec doit t = match t.ty_node with | Tunivar i' -> begin - let i' = UF.find i' !uf in + let i' = UF.find i' (get_uf ()) in match i' with | _ when i = i' -> true | _ when Hint.mem map i' -> false | _ -> - match UF.data i' !uf with + match UF.data i' (get_uf ()) with | None -> Hint.add map i' (); false | Some t -> match doit t with @@ -103,21 +149,79 @@ 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); + ignore 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 +231,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 +243,42 @@ 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 + doit () (* -------------------------------------------------------------------- *) let close (uf : UF.t) = @@ -199,17 +320,10 @@ 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 tvar_inst = -| TVIunamed of ty list +(* Explicit indices first, then explicit types. Either may be empty; + when both are empty, the slot is "no instantiation provided". *) +| TVIunamed of tindex list * ty list | TVInamed of (EcSymbols.symbol * ty) list type tvi = tvar_inst option @@ -234,41 +348,94 @@ 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 + + (* Look up the assignment of an index univar, if any. *) + let idx_data (ue : unienv) (u : uid) : tindex option = + Muid.find_opt u (!ue).ue_iuf + + (* Recursively replace TIUnivars in [ti] with their assignments + under the current unienv. Walks chains: if [u := TIUnivar v] and + [v := TIConst 5], [resolve_tindex] returns [TIConst 5]. *) + let rec resolve_tindex (ue : unienv) (ti : tindex) : tindex = + match ti with + | TIUnivar u -> begin + match idx_data ue u with + | None -> ti + | Some ti -> resolve_tindex ue ti + end + | TIVar _ | TIConst _ -> ti + | TIAdd (l, r) -> + let l' = resolve_tindex ue l in + let r' = resolve_tindex ue r in + if l == l' && r == r' then ti else TIAdd (l', r') + | TIMul (l, r) -> + let l' = resolve_tindex ue l in + let r' = resolve_tindex ue r in + if l == l' && r == r' then ti else TIMul (l', r') + let opentvi (ue : unienv) (params : ty_params) (tvi : tvar_inst option) = + let params = params.tyvars in match tvi with | 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 (TVIunamed (_ix, lt)) -> + (* _ix is handled by [openidx] separately. Here we only map + tyvars to their explicit-or-fresh univars. *) + if lt = [] then + List.fold_left + (fun s v -> Mid.add v (fresh ue) s) + Mid.empty params + else + List.fold_left2 + (fun s v ty -> Mid.add v (fresh ~ty ue) s) + Mid.empty params lt | Some (TVInamed lt) -> let for1 s v = @@ -280,19 +447,61 @@ module UniEnv = struct in List.fold_left for1 Mid.empty params + (* Build the ident-to-tindex substitution that binds each idxvar + of [params]. When the caller provided explicit indices via + [TVIunamed (ix, _)], use those; otherwise allocate a fresh + TIUnivar so type-directed unification can assign it later. *) + let openidx (ue : unienv) (params : ty_params) (tvi : tvar_inst option) : tindex Mid.t = + let provided = + match tvi with + | Some (TVIunamed (ix, _)) when ix <> [] -> Some ix + | _ -> None + in + match provided with + | None -> + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + | Some ix -> + if List.compare_lengths ix params.idxvars <> 0 then + (* Fall back to inference rather than failing the select + loop: the caller may be trying this op among others. *) + List.fold_left + (fun s v -> Mid.add v (idx_fresh ue) s) + Mid.empty params.idxvars + else + List.fold_left2 + (fun s v ti -> Mid.add v ti s) + Mid.empty params.idxvars ix + let subst_tv (subst : ty -> ty) (params : ty_params) = - List.map (fun tv -> subst (tvar tv)) params + 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 = @@ -302,6 +511,9 @@ module UniEnv = struct let closed (ue : unienv) = UF.closed (!ue).ue_uf + && Suid.subset (!ue).ue_iuf_alloc + (Muid.fold (fun u _ s -> Suid.add u s) + (!ue).ue_iuf Suid.empty) let close (ue : unienv) = if not (closed ue) then raise UninstantiateUni; @@ -310,14 +522,42 @@ 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 + () + 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,7 +568,8 @@ let tfun_expected ue ?retty psig = type sbody = ((EcIdent.t * ty) list * expr) Lazy.t (* -------------------------------------------------------------------- *) -type select_result = (EcPath.path * ty list) * ty * unienv * sbody option +type select_result = + (EcPath.path * tindex list * ty list) * ty * unienv * sbody option (* -------------------------------------------------------------------- *) type op_failure = @@ -419,14 +660,15 @@ let select_op_outcomes 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 (TVIunamed (ix, lt)) -> + (* Each non-empty user list must match the corresponding + arity of the candidate op. Empty means "infer this side". *) + fun op -> + (lt = [] || List.length lt = List.length op.D.op_tparams.tyvars) + && (ix = [] || List.length ix = List.length op.D.op_tparams.idxvars) | Some (TVInamed ls) -> fun op -> - let tparams = List.map EcIdent.name op.D.op_tparams in + let tparams = List.map EcIdent.name op.D.op_tparams.tyvars in let tparams = Ssym.of_list tparams in List.for_all (fun (x, _) -> Msym.mem x tparams) ls @@ -434,7 +676,7 @@ let select_op_outcomes filter oppath op && filter_on_tvi op 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,13 +689,13 @@ 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 @@ -461,7 +703,7 @@ let select_op_outcomes (* [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.combine op.D.op_tparams.tyvars tvs |> List.filter_map (fun (tp, tv) -> match (resolve tv).ty_node with | Tunivar _ -> None @@ -473,13 +715,13 @@ let select_op_outcomes let select (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 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..b3af4054e 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -6,13 +6,15 @@ 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 type tvar_inst = -| TVIunamed of ty list +(* (explicit indices, explicit types). Either may be empty; the + typing layer falls back to inference for empty sides. *) +| TVIunamed of tindex list * ty list | TVInamed of (EcSymbols.symbol * ty) list type tvi = tvar_inst option @@ -23,24 +25,50 @@ 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 + (* Index-univar resolved assignment map (Phase 3.5). *) + val iu_close : unienv -> tindex Muid.t + val iu_assubst : unienv -> tindex Muid.t + (* Build a complete [f_subst] resolving both type-univars and + index-univars. Use this in place of [Tuni.subst (close ue)] + when the substituted form may carry indexed types. *) + val close_subst : unienv -> EcCoreSubst.f_subst val tparams : unienv -> ty_params end val unify : EcEnv.env -> unienv -> ty -> ty -> unit +(* Index unification — same engine as [unify], for index polynomials. + Solves naked-univar assignments and Gap-B "?u + k = poly" cases; + raises [UnificationFailure (`IxUni _)] on failure. *) +val unify_idx : EcEnv.env -> unienv -> tindex -> tindex -> unit + val tfun_expected : unienv -> ?retty:ty -> EcTypes.ty list -> EcTypes.ty type sbody = ((EcIdent.t * ty) list * expr) Lazy.t -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) *) diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index dc8e0947d..23d0e5c10 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -332,9 +332,25 @@ 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 + + | IndexMismatch (i1, i2) -> + msg "cannot unify indices `%s' and `%s' (only naked-univar \ + assignment is supported; full polynomial unification \ + is out of scope)" + (EcTypes.dump_tindex i1) (EcTypes.dump_tindex i2) + | DuplicatedTyVar -> msg "a type variable appear at least twice" + | DuplicatedIndexVar name -> + msg "an index variable appears at least twice: `%s'" name + | DuplicatedLocal name -> msg "duplicated local/parameters name: `%s'" name @@ -523,8 +539,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 @@ -867,6 +883,14 @@ end = struct msg "type argument mismatch for %s `%s'" (string_of_ovkind kd) (string_of_qsymbol x) + | CE_IdxArgMism (kd, x) -> + msg "index argument mismatch for %s `%s'" + (string_of_ovkind kd) (string_of_qsymbol x) + + | CE_IndexedNotYetSupported (kd, x) -> + msg "cloning of indexed %s `%s' is not yet supported" + (string_of_ovkind kd) (string_of_qsymbol x) + | CE_OpIncompatible (x, err) -> msg "operator `%s' body %a" (string_of_qsymbol x) (pp_incompatible env) err 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 dfb9d2203..35e4788f6 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..9b503366d 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -152,7 +152,7 @@ let process_rewrite_equiv info tc = try let proc = EcEnv.Fun.by_xpath new_func env in let subenv = EcEnv.Memory.push_active_ss mem env in - let ue = EcUnify.UniEnv.create (Some []) in + let ue = EcUnify.UniEnv.create (Some { idxvars = []; tyvars = [] }) in let args, ret_ty = EcTyping.trans_args subenv ue (loc pargs) proc.f_sig (unloc pargs) in let res = omap (fun v -> EcTyping.transexpcast subenv `InProc ue ret_ty v) pres in let es = e_subst (Tuni.subst (EcUnify.UniEnv.close ue)) in 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/indexed-types.ec b/tests/indexed-types.ec new file mode 100644 index 000000000..d700ec06f --- /dev/null +++ b/tests/indexed-types.ec @@ -0,0 +1,344 @@ +(* -------------------------------------------------------------------- *) +(* 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. + +(* A trailing `+` on an idxvar name opts in to a [0 <= n =>] + hypothesis in the proof goal (inserted inside the lemma's + [pa_vars] forall). Without `+`, no hypothesis is added. Marks + never leak into the saved [ax_spec] — only the proof goal + sees them. *) +lemma idx_ge0_simple {n+} : 0 <= n. +proof. move=> Hn. trivial. qed. + +lemma idx_ge0_smt {m+ n+} : 0 <= m + n. +proof. move=> Hm Hn. smt(). qed. + +(* [pa_vars] auto-intro still works: the implications are pushed + inside the forall, not at the top. *) +lemma idx_with_args {n+} (xs : int vec<:n>) : 0 <= n. +proof. move=> Hn. trivial. qed. + +(* Without `+`, no hypothesis is injected — the lemma's body must + be provable as-is. *) +lemma idx_no_marker {n} : true. +proof. trivial. qed. + +(* The `+` marker is rejected on non-lemma binders. Kept as a + comment (uncommenting would produce a clear parse error): + type {n+} foo. (* parse error: type *) + op f {n+} : foo -> int. (* parse error: operator *) + pred p {n+} : foo. (* parse error: predicate *) + abbrev a {n+} : int = 5. (* parse error: abbreviation *) *) + +(* 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. admit. qed. diff --git a/tests/op-application-errors.ec b/tests/op-application-errors.ec index a46582d1d..6c3b50f3e 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 =