From 85336058d2946c1c4a982ad25de0edccdcefdd46 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 10:28:59 -0600 Subject: [PATCH 01/24] Add B3 language support with DDM integration This commit adds the B3 language implementation with full DDM integration. Changes: - B3 language AST definitions and conversions - DDM-based parsing and formatting for B3 - Applied @[unwrap] to literal operations (intLit, boolLit, stringLit) and id operation - Fixed mapMetadata functions to handle unwrapped parameters - Comprehensive test suite for B3 DDM formatting --- Strata/Languages/B3/B3.lean | 27 + Strata/Languages/B3/DDMConversion.lean | 1074 +++++++++++++++++ .../B3/DDMTransform/DefinitionAST.lean | 330 +++++ .../Languages/B3/DDMTransform/ParseCST.lean | 235 ++++ Strata/Languages/B3/DDMTransform/README.md | 44 + .../Languages/B3/Examples/DDMTransform.lean | 30 + Strata/Languages/B3/Identifiers.lean | 78 ++ .../B3/DDMFormatDeclarationsTests.lean | 731 +++++++++++ .../B3/DDMFormatExpressionsTests.lean | 505 ++++++++ .../Languages/B3/DDMFormatProgramsTests.lean | 364 ++++++ .../B3/DDMFormatStatementsTests.lean | 633 ++++++++++ StrataTest/Languages/B3/DDMFormatTests.lean | 269 +++++ 12 files changed, 4320 insertions(+) create mode 100644 Strata/Languages/B3/B3.lean create mode 100644 Strata/Languages/B3/DDMConversion.lean create mode 100644 Strata/Languages/B3/DDMTransform/DefinitionAST.lean create mode 100644 Strata/Languages/B3/DDMTransform/ParseCST.lean create mode 100644 Strata/Languages/B3/DDMTransform/README.md create mode 100644 Strata/Languages/B3/Examples/DDMTransform.lean create mode 100644 Strata/Languages/B3/Identifiers.lean create mode 100644 StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean create mode 100644 StrataTest/Languages/B3/DDMFormatExpressionsTests.lean create mode 100644 StrataTest/Languages/B3/DDMFormatProgramsTests.lean create mode 100644 StrataTest/Languages/B3/DDMFormatStatementsTests.lean create mode 100644 StrataTest/Languages/B3/DDMFormatTests.lean diff --git a/Strata/Languages/B3/B3.lean b/Strata/Languages/B3/B3.lean new file mode 100644 index 000000000..78b5ef417 --- /dev/null +++ b/Strata/Languages/B3/B3.lean @@ -0,0 +1,27 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.ParseCST +import Strata.Languages.B3.DDMTransform.DefinitionAST +import Strata.Languages.B3.Identifiers + +--------------------------------------------------------------------- + +namespace B3 + +/-! +## B3 Language + +B3 is a simplified imperative verification language with: +- Basic types (bool, int, string) +- Expressions with binary/unary operators +- Statements including assignments, assertions, loops +- Procedure calls with in/out/inout parameters +- Quantifiers with optional patterns +- Control flow (if, loop, choose, exit) +-/ + +end B3 diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean new file mode 100644 index 000000000..8da494126 --- /dev/null +++ b/Strata/Languages/B3/DDMConversion.lean @@ -0,0 +1,1074 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.ParseCST +import Strata.Languages.B3.DDMTransform.DefinitionAST + +/-! +# B3 ↔ DDM Bidirectional Conversion + +This module provides bidirectional conversion between B3 AST types and DDM AST types. + +## B3AST → B3CST Conversion +Converts abstract syntax (de Bruijn indices) to concrete syntax (named identifiers). +Used for formatting and pretty-printing B3 constructs using DDM's formatting system. + +## B3CST → B3AST Conversion +Converts concrete syntax (named identifiers) to abstract syntax (de Bruijn indices). +Used for parsing B3 syntax via DDM and converting it back to B3 AST. + +## Context Management +A list of variable names is maintained to convert between indices and names. +-/ + +namespace B3 + +open Strata +open Strata.B3CST +open Strata.B3AST + +/-- +Typeclass for creating annotations when converting CST → AST. +Methods are named specifically for where they're used. Each should be used exactly once. +-/ +class B3AnnFromCST (α : Type) where + /-- Used in: literal cases (.natLit, .strLit, .btrue, .bfalse) for .literal wrapper -/ + annForLiteral : α → α + /-- Used in: literal cases for the specific literal type (.intLit, .stringLit, .boolLit) -/ + annForLiteralType : α → α + /-- Used in: literal cases for Ann wrapping the value -/ + annForLiteralValue : α → α + /-- Used in: .id case for .id wrapper -/ + annForId : α → α + /-- Used in: .id case for Ann wrapping the looked-up index -/ + annForIdValue : α → α + /-- Used in: unary op cases (.not, .neg) for .unaryOp wrapper -/ + annForUnaryOp : α → α + /-- Used in: unary op cases for the op type (.not, .neg) -/ + annForUnaryOpType : α → α + /-- Used in: binary op cases for .binaryOp wrapper -/ + annForBinaryOp : α → α + /-- Used in: binary op cases for the op type -/ + annForBinaryOpType : α → α + /-- Used in: .functionCall for wrapper -/ + annForFunctionCall : α → α + /-- Used in: .functionCall for Ann wrapping function name -/ + annForFunctionCallName : α → α + /-- Used in: .functionCall for Ann wrapping args array -/ + annForFunctionCallArgs : α → α + /-- Used in: .labeledExpr for wrapper -/ + annForLabeledExpr : α → α + /-- Used in: .labeledExpr for Ann wrapping label -/ + annForLabeledExprLabel : α → α + /-- Used in: .letExpr for wrapper -/ + annForLetExpr : α → α + /-- Used in: .letExpr for Ann wrapping var name -/ + annForLetExprVar : α → α + /-- Used in: .ite for wrapper -/ + annForIte : α → α + /-- Used in: quantifier cases for .quantifierExpr wrapper -/ + annForQuantifierExpr : α → α + /-- Used in: quantifier cases for quantifier kind (.forall, .exists) -/ + annForQuantifierKind : α → α + /-- Used in: quantifier cases for Ann wrapping var name -/ + annForQuantifierVar : α → α + /-- Used in: quantifier cases for Ann wrapping type -/ + annForQuantifierType : α → α + /-- Used in: quantifier cases for Ann wrapping patterns array -/ + annForQuantifierPatterns : α → α + /-- Used in: pattern case for .pattern wrapper -/ + annForPattern : α → α + /-- Used in: pattern case for Ann wrapping expressions array -/ + annForPatternExprs : α → α + +instance : B3AnnFromCST Unit where + annForLiteral _ := () + annForLiteralType _ := () + annForLiteralValue _ := () + annForId _ := () + annForIdValue _ := () + annForUnaryOp _ := () + annForUnaryOpType _ := () + annForBinaryOp _ := () + annForBinaryOpType _ := () + annForFunctionCall _ := () + annForFunctionCallName _ := () + annForFunctionCallArgs _ := () + annForLabeledExpr _ := () + annForLabeledExprLabel _ := () + annForLetExpr _ := () + annForLetExprVar _ := () + annForIte _ := () + annForQuantifierExpr _ := () + annForQuantifierKind _ := () + annForQuantifierVar _ := () + annForQuantifierType _ := () + annForQuantifierPatterns _ := () + annForPattern _ := () + annForPatternExprs _ := () + +instance : B3AnnFromCST M where + annForLiteral := id + annForLiteralType := id + annForLiteralValue := id + annForId := id + annForIdValue := id + annForUnaryOp := id + annForUnaryOpType := id + annForBinaryOp := id + annForBinaryOpType := id + annForFunctionCall := id + annForFunctionCallName := id + annForFunctionCallArgs := id + annForLabeledExpr := id + annForLabeledExprLabel := id + annForLetExpr := id + annForLetExprVar := id + annForIte := id + annForQuantifierExpr := id + annForQuantifierKind := id + annForQuantifierVar := id + annForQuantifierType := id + annForQuantifierPatterns := id + annForPattern := id + annForPatternExprs := id + +-- Helpers for common Ann operations +private def mkAnn {α M: Type} (m: M) (x : α) : Ann α M := ⟨m, x⟩ +private def mapAnn {α β M : Type} (f : α → β) (a : Ann α M) : Ann β M := mkAnn a.ann (f a.val) + +--------------------------------------------------------------------- +-- B3AST → B3CST Conversion (Abstract to Concrete) +--------------------------------------------------------------------- + +section ToCST + +structure ToCSTContext where + vars : List String + inProcedure : Bool := false + +namespace ToCSTContext + +def lookup (ctx : ToCSTContext) (idx : Nat): String := + match ctx.vars[idx]? with + | .some name => + if name == "" then s!"@{idx}" else + -- We need to resolve ambiguities + let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := + let default := fun _: Unit => if pastIndex == 0 then + name -- No ambiguity + else + s!"name@{pastIndex}" + if idx == 0 then + default () + else + match vars with + | [] => default () + | otherName :: tail => + if name == otherName then + go tail (pastIndex + 1) (idx - 1) + else + go tail pastIndex (idx - 1) + + go ctx.vars 0 idx + | .none => + s!"@{idx}" + +-- Check if a variable at index idx is shadowed (has a later occurrence with same name) +def isShadowed (ctx : ToCSTContext) (idx : Nat) : Bool := + match ctx.vars[idx]? with + | .some name => + -- Check if there's another occurrence of this name at a lower index (later in the list) + ctx.vars.take idx |>.any (· == name) + | .none => false + +def push (ctx : ToCSTContext) (name : String) : ToCSTContext := + { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } + +def enterProcedure (ctx : ToCSTContext) : ToCSTContext := + { ctx with inProcedure := true } + +def empty : ToCSTContext := { vars := [], inProcedure := false } + +end ToCSTContext + +mutual + +partial def binaryOpToCST [Inhabited (B3CST.Expression M)] : B3AST.BinaryOp M → + (M → B3CST.Expression M → B3CST.Expression M → B3CST.Expression M) + | .iff _ => B3CST.Expression.iff + | .implies _ => B3CST.Expression.implies + | .impliedBy _ => B3CST.Expression.impliedBy + | .and _ => B3CST.Expression.and + | .or _ => B3CST.Expression.or + | .eq _ => B3CST.Expression.equal + | .neq _ => B3CST.Expression.not_equal + | .lt _ => B3CST.Expression.lt + | .le _ => B3CST.Expression.le + | .ge _ => B3CST.Expression.ge + | .gt _ => B3CST.Expression.gt + | .add _ => B3CST.Expression.add + | .sub _ => B3CST.Expression.sub + | .mul _ => B3CST.Expression.mul + | .div _ => B3CST.Expression.div + | .mod _ => B3CST.Expression.mod + +partial def unaryOpToCST [Inhabited (B3CST.Expression M)] : B3AST.UnaryOp M → + (M → B3CST.Expression M → B3CST.Expression M) + | .not _ => B3CST.Expression.not + | .neg _ => B3CST.Expression.neg + +partial def literalToCST [Inhabited (B3CST.Expression M)] : B3AST.Literal M → B3CST.Expression M + | .intLit m n => B3CST.Expression.natLit m n + | .boolLit m b => match b with | ⟨_, true⟩ => B3CST.Expression.btrue m | ⟨_, false⟩ => B3CST.Expression.bfalse m + | .stringLit m s => B3CST.Expression.strLit m s + +partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : B3AST.Expression M → B3CST.Expression M + | .literal _m lit => + literalToCST lit + | .id m idx => + if ctx.inProcedure && ctx.isShadowed idx.val then + B3CST.Expression.old_id m (mkAnn m (ctx.lookup idx.val)) + else + B3CST.Expression.id m (mkAnn m (ctx.lookup idx.val)) + | .ite m cond thn els => + B3CST.Expression.ite m (expressionToCST ctx cond) (expressionToCST ctx thn) (expressionToCST ctx els) + | .binaryOp m op lhs rhs => + (binaryOpToCST op) m (expressionToCST ctx lhs) (expressionToCST ctx rhs) + | .unaryOp m op arg => + (unaryOpToCST op) m (expressionToCST ctx arg) + | .functionCall m fnName args => + B3CST.Expression.functionCall m (mapAnn (fun x => x) fnName) (mapAnn (fun arr => arr.map (expressionToCST ctx)) args) + | .labeledExpr m label expr => + B3CST.Expression.labeledExpr m (mapAnn (fun x => x) label) (expressionToCST ctx expr) + | .letExpr m var value body => + let ctx' := ctx.push var.val + B3CST.Expression.letExpr m (mapAnn (fun x => x) var) (expressionToCST ctx value) (expressionToCST ctx' body) + | .quantifierExpr m qkind var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : Strata.B3AST.Pattern M) : B3CST.Pattern M := + match p with + | .pattern pm exprs => + let exprsCST := exprs.val.map (expressionToCST ctx') + B3CST.Pattern.pattern pm (mkAnn pm exprsCST) + let patternsDDM := match patterns.val.toList with + | [] => none + | [p] => some (Patterns.patterns_single m (convertPattern p)) + | p :: ps => + some (ps.foldl (init := Patterns.patterns_single m (convertPattern p)) fun acc p => + Patterns.patterns_cons m (convertPattern p) acc) + match qkind with + | .forall _qm => + match patternsDDM with + | none => B3CST.Expression.forall_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (expressionToCST ctx' body) + | some pats => B3CST.Expression.forall_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats (expressionToCST ctx' body) + | .exists _qm => + match patternsDDM with + | none => B3CST.Expression.exists_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (expressionToCST ctx' body) + | some pats => B3CST.Expression.exists_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats (expressionToCST ctx' body) + +partial def callArgToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M + | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCST ctx e) + | .callArgOut m id => B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id) + | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id) + +partial def buildChoiceBranches [Inhabited M] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M + | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) + | m, [b] => ChoiceBranches.choiceAtom m b + | m, b :: bs => ChoiceBranches.choicePush m (buildChoiceBranches m bs) b + +partial def stmtToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.Statement M → B3CST.Statement M + | .varDecl m name ty autoinv init => + let ctx' := ctx.push name.val + match ty.val, autoinv.val, init.val with + | some t, some ai, some i => B3CST.Statement.var_decl_full m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx ai) (expressionToCST ctx' i) + | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx ai) + | some t, none, some i => B3CST.Statement.var_decl_with_init m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' i) + | some t, none, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val) + | none, _, some i => B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) (expressionToCST ctx' i) + | none, _, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown") + | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val)) (expressionToCST ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val)) + | .blockStmt m stmts => + let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => + let stmt' := stmtToCST ctx stmt + let ctx' := match stmt with + | .varDecl _ name _ _ _ => ctx.push name.val + | _ => ctx + (acc ++ [stmt'], ctx') + ) ([], ctx) + B3CST.Statement.block m (mkAnn m stmts'.toArray) + | .call m procName args => B3CST.Statement.call_statement m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgToCST ctx) |>.toArray) args) + | .check m expr => B3CST.Statement.check m (expressionToCST ctx expr) + | .assume m expr => B3CST.Statement.assume m (expressionToCST ctx expr) + | .reach m expr => B3CST.Statement.reach m (expressionToCST ctx expr) + | .assert m expr => B3CST.Statement.assert m (expressionToCST ctx expr) + | .aForall m var ty body => + let ctx' := ctx.push var.val + B3CST.Statement.aForall_statement m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtToCST ctx' body) + | .choose m branches => + let choiceBranches := branches.val.toList.map (fun s => ChoiceBranch.choice_branch m (stmtToCST ctx s)) + B3CST.Statement.choose_statement m (buildChoiceBranches m choiceBranches) + | .ifStmt m cond thenB elseB => + let elseCST := mapAnn (fun opt => opt.map (fun e => Else.else_some m (stmtToCST ctx e))) elseB + B3CST.Statement.if_statement m (expressionToCST ctx cond) (stmtToCST ctx thenB) elseCST + | .ifCase m cases => + B3CST.Statement.if_case_statement m (mapAnn (fun arr => arr.toList.map (fun c => + match c with + | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCST ctx cond) (stmtToCST ctx body)) |>.toArray) cases) + | .loop m invariants body => + B3CST.Statement.loop_statement m (mapAnn (fun arr => arr.toList.map (fun e => Invariant.invariant m (expressionToCST ctx e)) |>.toArray) invariants) (stmtToCST ctx body) + | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mapAnn (fun x => x) label) (stmtToCST ctx stmt) + | .exit m label => + B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + | .returnStmt m => B3CST.Statement.return_statement m + | .probe m label => B3CST.Statement.probe m (mapAnn (fun x => x) label) + +end + +end ToCST + +--------------------------------------------------------------------- +-- B3CST → B3AST Conversion (Concrete to Abstract) +--------------------------------------------------------------------- + +section FromDDM + +structure FromDDMContext where + vars : List String + +namespace FromDDMContext + +def lookup (ctx : FromDDMContext) (name : String) : Nat := + ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length + +def lookupLast (ctx : FromDDMContext) (name : String) : Nat := + -- Find the last occurrence by searching from the end + let rec findLast (vars : List String) (idx : Nat) : Option Nat := + match vars with + | [] => none + | v :: vs => + match findLast vs (idx + 1) with + | some found => some found + | none => if v == name then some idx else none + findLast ctx.vars 0 |>.getD ctx.vars.length + +def push (ctx : FromDDMContext) (name : String) : FromDDMContext := + { vars := name :: ctx.vars } + +def empty : FromDDMContext := { vars := [] } + +end FromDDMContext + +partial def patternsToArray [Inhabited M] : B3CST.Patterns M → Array (B3CST.Pattern M) + | .patterns_single _ p => #[p] + | .patterns_cons _ p ps => patternsToArray ps |>.push p + +partial def expressionFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Expression M → Strata.B3AST.Expression M + | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, n.val⟩) + | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, s.val⟩) + | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, true⟩) + | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, false⟩) + | .id ann name => .id (B3AnnFromCST.annForId ann) ⟨B3AnnFromCST.annForIdValue ann, ctx.lookup name.val⟩ + | .old_id ann name => .id (B3AnnFromCST.annForId ann) ⟨B3AnnFromCST.annForIdValue ann, ctx.lookupLast name.val⟩ + | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) + | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) + | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .implies ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.implies (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .impliedBy ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.impliedBy (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .and ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.and (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .or ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.or (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.eq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .not_equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.neq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .lt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.lt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .le ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.le (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .ge ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.ge (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .gt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.gt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .add ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.add (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .sub ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.sub (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .mul ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mul (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .div ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.div (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .mod ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mod (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) + | .functionCall ann fn args => .functionCall (B3AnnFromCST.annForFunctionCall ann) ⟨B3AnnFromCST.annForFunctionCallName ann, fn.val⟩ ⟨B3AnnFromCST.annForFunctionCallArgs ann, args.val.map (expressionFromDDM ctx)⟩ + | .labeledExpr ann label expr => .labeledExpr (B3AnnFromCST.annForLabeledExpr ann) ⟨B3AnnFromCST.annForLabeledExprLabel ann, label.val⟩ (expressionFromDDM ctx expr) + | .letExpr ann var value body => + let ctx' := ctx.push var.val + .letExpr (B3AnnFromCST.annForLetExpr ann) ⟨B3AnnFromCST.annForLetExprVar ann, var.val⟩ (expressionFromDDM ctx value) (expressionFromDDM ctx' body) + | .ite ann cond thenExpr elseExpr => .ite (B3AnnFromCST.annForIte ann) (expressionFromDDM ctx cond) (expressionFromDDM ctx thenExpr) (expressionFromDDM ctx elseExpr) + | .forall_expr_no_patterns ann var ty body => + let ctx' := ctx.push var.val + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromDDM ctx' body) + | .forall_expr ann var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + match p with + | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromDDM ctx')⟩ + let patternsArray := patternsToArray patterns |>.map convertPattern + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromDDM ctx' body) + | .exists_expr_no_patterns ann var ty body => + let ctx' := ctx.push var.val + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromDDM ctx' body) + | .exists_expr ann var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + match p with + | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromDDM ctx')⟩ + let patternsArray := patternsToArray patterns |>.map convertPattern + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromDDM ctx' body) + | .paren _ expr => expressionFromDDM ctx expr + +partial def callArgFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.CallArg M → Strata.B3AST.CallArg M + | .call_arg_expr m expr => .callArgExpr m (expressionFromDDM ctx expr) + | .call_arg_out m id => .callArgOut m (mapAnn (fun x => x) id) + | .call_arg_inout m id => .callArgInout m (mapAnn (fun x => x) id) + +partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List (B3CST.Statement M) + | .choiceAtom _ branch => + match branch with + | .choice_branch _ stmt => [stmt] + | .choicePush _ branches branch => + match branch with + | .choice_branch _ stmt => stmt :: choiceBranchesToList branches + +partial def stmtFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Statement M → Strata.B3AST.Statement M + | .var_decl_full m name ty autoinv init => + let ctx' := ctx.push name.val + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) (mkAnn m (some (expressionFromDDM ctx' init))) + | .var_decl_with_autoinv m name ty autoinv => + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) (mkAnn m none) + | .var_decl_with_init m name ty init => + let ctx' := ctx.push name.val + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + | .var_decl_typed m name ty => + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m none) + | .var_decl_inferred m name init => + let ctx' := ctx.push name.val + .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + | .val_decl m name ty init => + let ctx' := ctx.push name.val + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + | .val_decl_inferred m name init => + let ctx' := ctx.push name.val + .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + | .assign m lhs rhs => + .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromDDM ctx rhs) + | .reinit_statement m v => + .reinit m (mkAnn m (ctx.lookup v.val)) + | .check m expr => + .check m (expressionFromDDM ctx expr) + | .assume m expr => + .assume m (expressionFromDDM ctx expr) + | .reach m expr => + .reach m (expressionFromDDM ctx expr) + | .assert m expr => + .assert m (expressionFromDDM ctx expr) + | .return_statement m => + .returnStmt m + | .block m stmts => + let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => + let stmt' := stmtFromDDM ctx stmt + let ctx' := match stmt with + | .var_decl_full _ name _ _ _ => ctx.push name.val + | .var_decl_with_autoinv _ name _ _ => ctx.push name.val + | .var_decl_with_init _ name _ _ => ctx.push name.val + | .var_decl_typed _ name _ => ctx.push name.val + | .var_decl_inferred _ name _ => ctx.push name.val + | .val_decl _ name _ _ => ctx.push name.val + | .val_decl_inferred _ name _ => ctx.push name.val + | _ => ctx + (acc ++ [stmt'], ctx') + ) ([], ctx) + .blockStmt m (mkAnn m stmts'.toArray) + | .if_statement m cond thenB elseB => + let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromDDM ctx stmt)) elseB + .ifStmt m (expressionFromDDM ctx cond) (stmtFromDDM ctx thenB) elseBranch + | .loop_statement m invs body => + let invariants := invs.val.toList.map fun inv => + match inv with + | .invariant _ expr => expressionFromDDM ctx expr + .loop m (mkAnn m invariants.toArray) (stmtFromDDM ctx body) + | .exit_statement m label => + .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + | .labeled_statement m label stmt => + .labeledStmt m (mapAnn (fun x => x) label) (stmtFromDDM ctx stmt) + | .probe m label => + .probe m (mapAnn (fun x => x) label) + | .aForall_statement m var ty body => + let ctx' := ctx.push var.val + .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromDDM ctx' body) + | .choose_statement m branches => + .choose m (mkAnn m (choiceBranchesToList branches |>.map (stmtFromDDM ctx)).toArray) + | .if_case_statement m cases => + .ifCase m (mapAnn (fun arr => arr.toList.map (fun case => + match case with + | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromDDM ctx cond) (stmtFromDDM ctx stmt)) |>.toArray) cases) + | .call_statement m procName args => + .call m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgFromDDM ctx) |>.toArray) args) + +def paramModeFromCST [Inhabited M] : Ann (Option (B3CST.PParamMode M)) M → Strata.B3AST.ParamMode M + | ⟨m, none⟩ => .paramModeIn m + | ⟨m, some (.pmode_out _)⟩ => .paramModeOut m + | ⟨m, some (.pmode_inout _)⟩ => .paramModeInout m + +def fParameterFromCST [Inhabited M] : B3CST.FParam M → Strata.B3AST.FParameter M + | .fparam m injective name ty => + let inj := match injective.val with + | some (.injective_some _) => true + | none => false + .fParameter m (mkAnn m inj) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) + +def pParameterFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.PParam M → Strata.B3AST.PParameter M + | .pparam m mode name ty => + .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m none) + | .pparam_with_autoinv m mode name ty autoinv => + .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) + +def specFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Spec M → Strata.B3AST.Spec M + | .spec_requires m expr => .specRequires m (expressionFromDDM ctx expr) + | .spec_ensures m expr => .specEnsures m (expressionFromDDM ctx expr) + +def fparamsToList : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) + | ⟨_, arr⟩ => arr.toList + +def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Decl M → Strata.B3AST.Decl M + | .type_decl m name => + .typeDecl m (mapAnn (fun x => x) name) + | .tagger_decl m name forType => + .tagger m (mapAnn (fun x => x) name) (mapAnn (fun x => x) forType) + | .function_decl m name params resultType tag body => + let paramsAST := fparamsToList params |>.map fParameterFromCST + let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with + | .function_body_some bm whens expr => + let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromDDM ctx' e)) + B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromDDM ctx' expr))) body + .function m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mapAnn (fun x => x) resultType) (mkAnn m tagAST) bodyAST + | .axiom_decl m axiomBody => + match axiomBody with + | .axiom _ expr => + .axiom m (mkAnn m #[]) (expressionFromDDM ctx expr) + | .explain_axiom _ names expr => + let namesAST := names.val.toList.map (fun n => mkAnn m n.val) + .axiom m (mkAnn m namesAST.toArray) (expressionFromDDM ctx expr) + | .procedure_decl m name params specs body => + -- First, collect all parameter names to build context for autoinv expressions + let paramNames := params.val.toList.map (fun p => match p with + | .pparam _ _ n _ => n.val + | .pparam_with_autoinv _ _ n _ _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + -- Now convert all parameters with the full context (so autoinv can reference all params) + let paramsAST := params.val.toList.map (pParameterFromCST ctx') + let specsAST := specs.val.toList.map (specFromCST ctx') + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => stmtFromDDM ctx' s)) body + .procedure m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST + +end FromDDM + +--------------------------------------------------------------------- +-- Annotation-Preserving Conversions (B3CST M ↔ B3AST M) +--------------------------------------------------------------------- + +section AnnotationPreserving + +structure ToCSTContextSR where + vars : List String + +namespace ToCSTContextSR + +def lookup (ctx : ToCSTContextSR) (idx : Nat): String := + match ctx.vars[idx]? with + | .some name => + if name == "" then s!"@{idx}" else + let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := + let default := fun _: Unit => if pastIndex == 0 then name else s!"name@{pastIndex}" + if idx == 0 then default () + else + match vars with + | [] => default () + | otherName :: tail => + if name == otherName then go tail (pastIndex + 1) (idx - 1) + else go tail pastIndex (idx - 1) + go ctx.vars 0 idx + | .none => s!"@{idx}" + +def push (ctx : ToCSTContextSR) (name : String) : ToCSTContextSR := + { vars := name :: ctx.vars } + +def empty : ToCSTContextSR := { vars := [] } + +end ToCSTContextSR + +structure FromDDMContextSR where + vars : List String + +namespace FromDDMContextSR + +def lookup (ctx : FromDDMContextSR) (name : String) : Nat := + ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length + +def lookupLast (ctx : FromDDMContextSR) (name : String) : Nat := + -- Find the last occurrence by searching from the end + let rec findLast (vars : List String) (idx : Nat) : Option Nat := + match vars with + | [] => none + | v :: vs => + match findLast vs (idx + 1) with + | some found => some found + | none => if v == name then some idx else none + findLast ctx.vars 0 |>.getD ctx.vars.length + +def push (ctx : FromDDMContextSR) (name : String) : FromDDMContextSR := + { vars := name :: ctx.vars } + +def empty : FromDDMContextSR := { vars := [] } + +end FromDDMContextSR + +/-! +## Annotation-Preserving Conversions + +These functions preserve M annotations when converting between B3CST and B3AST. +They duplicate the Unit-based conversions but thread M through all recursive calls. +-/ + +mutual + +partial def literalToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ann : M) : B3AST.Literal M → B3CST.Expression M + | .intLit _ n => B3CST.Expression.natLit ann (mkAnn ann n.val) + | .boolLit _ b => match b with + | ⟨_, true⟩ => B3CST.Expression.btrue ann + | ⟨_, false⟩ => B3CST.Expression.bfalse ann + | .stringLit _ s => B3CST.Expression.strLit ann (mkAnn ann s.val) + +partial def expressionToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Expression M → B3CST.Expression M + | .literal ann lit => literalToCSTSR ann lit + | .id ann idx => B3CST.Expression.id ann (mkAnn ann (ctx.lookup idx.val)) + | .ite ann cond thn els => B3CST.Expression.ite ann (expressionToCSTSR ctx cond) (expressionToCSTSR ctx thn) (expressionToCSTSR ctx els) + | .binaryOp ann op lhs rhs => + let ctor := match op with + | .iff _ => B3CST.Expression.iff + | .implies _ => B3CST.Expression.implies + | .impliedBy _ => B3CST.Expression.impliedBy + | .and _ => B3CST.Expression.and + | .or _ => B3CST.Expression.or + | .eq _ => B3CST.Expression.equal + | .neq _ => B3CST.Expression.not_equal + | .lt _ => B3CST.Expression.lt + | .le _ => B3CST.Expression.le + | .ge _ => B3CST.Expression.ge + | .gt _ => B3CST.Expression.gt + | .add _ => B3CST.Expression.add + | .sub _ => B3CST.Expression.sub + | .mul _ => B3CST.Expression.mul + | .div _ => B3CST.Expression.div + | .mod _ => B3CST.Expression.mod + ctor ann (expressionToCSTSR ctx lhs) (expressionToCSTSR ctx rhs) + | .unaryOp ann op arg => + let ctor := match op with + | .not _ => B3CST.Expression.not + | .neg _ => B3CST.Expression.neg + ctor ann (expressionToCSTSR ctx arg) + | .functionCall ann fnName args => B3CST.Expression.functionCall ann (mkAnn ann fnName.val) (mkAnn ann (args.val.map (expressionToCSTSR ctx))) + | .labeledExpr ann label expr => B3CST.Expression.labeledExpr ann (mkAnn ann label.val) (expressionToCSTSR ctx expr) + | .letExpr ann var value body => + let ctx' := ctx.push var.val + B3CST.Expression.letExpr ann (mkAnn ann var.val) (expressionToCSTSR ctx value) (expressionToCSTSR ctx' body) + | .quantifierExpr ann qkind var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : Strata.B3AST.Pattern M) : B3CST.Pattern M := + match p with + | .pattern pann exprs => + let exprsCST := exprs.val.map (expressionToCSTSR ctx') + B3CST.Pattern.pattern pann (mkAnn pann exprsCST) + let patternsDDM := match patterns.val.toList with + | [] => none + | [p] => some (Patterns.patterns_single ann (convertPattern p)) + | p :: ps => + some (ps.foldl (init := Patterns.patterns_single ann (convertPattern p)) fun acc p => + Patterns.patterns_cons ann (convertPattern p) acc) + match qkind with + | .forall _ => + match patternsDDM with + | none => B3CST.Expression.forall_expr_no_patterns ann (mkAnn ann var.val) (mkAnn ann ty.val) (expressionToCSTSR ctx' body) + | some pats => B3CST.Expression.forall_expr ann (mkAnn ann var.val) (mkAnn ann ty.val) pats (expressionToCSTSR ctx' body) + | .exists _ => + match patternsDDM with + | none => B3CST.Expression.exists_expr_no_patterns ann (mkAnn ann var.val) (mkAnn ann ty.val) (expressionToCSTSR ctx' body) + | some pats => B3CST.Expression.exists_expr ann (mkAnn ann var.val) (mkAnn ann ty.val) pats (expressionToCSTSR ctx' body) + +partial def patternsToArraySR [Inhabited $ Strata.B3AST.Expression M] : B3CST.Patterns M → Array (B3CST.Pattern M) + | .patterns_single _ p => #[p] + | .patterns_cons _ p ps => patternsToArraySR ps |>.push p + +partial def expressionFromDDMSR [Inhabited $ Strata.B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.Expression M → Strata.B3AST.Expression M + | .natLit ann n => .literal ann (.intLit ann (mkAnn ann n.val)) + | .strLit ann s => .literal ann (.stringLit ann (mkAnn ann s.val)) + | .btrue ann => .literal ann (.boolLit ann (mkAnn ann true)) + | .bfalse ann => .literal ann (.boolLit ann (mkAnn ann false)) + | .id ann name => .id ann (mkAnn ann (ctx.lookup name.val)) + | .old_id ann name => .id ann (mkAnn ann (ctx.lookupLast name.val)) + | .not ann arg => .unaryOp ann (.not ann) (expressionFromDDMSR ctx arg) + | .neg ann arg => .unaryOp ann (.neg ann) (expressionFromDDMSR ctx arg) + | .iff ann lhs rhs => .binaryOp ann (.iff ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .implies ann lhs rhs => .binaryOp ann (.implies ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .impliedBy ann lhs rhs => .binaryOp ann (.impliedBy ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .and ann lhs rhs => .binaryOp ann (.and ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .or ann lhs rhs => .binaryOp ann (.or ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .equal ann lhs rhs => .binaryOp ann (.eq ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .not_equal ann lhs rhs => .binaryOp ann (.neq ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .lt ann lhs rhs => .binaryOp ann (.lt ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .le ann lhs rhs => .binaryOp ann (.le ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .ge ann lhs rhs => .binaryOp ann (.ge ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .gt ann lhs rhs => .binaryOp ann (.gt ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .add ann lhs rhs => .binaryOp ann (.add ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .sub ann lhs rhs => .binaryOp ann (.sub ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .mul ann lhs rhs => .binaryOp ann (.mul ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .div ann lhs rhs => .binaryOp ann (.div ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .mod ann lhs rhs => .binaryOp ann (.mod ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) + | .functionCall ann fn args => .functionCall ann (mkAnn ann fn.val) (mkAnn ann (args.val.map (expressionFromDDMSR ctx))) + | .labeledExpr ann label expr => .labeledExpr ann (mkAnn ann label.val) (expressionFromDDMSR ctx expr) + | .letExpr ann var value body => + let ctx' := ctx.push var.val + .letExpr ann (mkAnn ann var.val) (expressionFromDDMSR ctx value) (expressionFromDDMSR ctx' body) + | .ite ann cond thenExpr elseExpr => .ite ann (expressionFromDDMSR ctx cond) (expressionFromDDMSR ctx thenExpr) (expressionFromDDMSR ctx elseExpr) + | .forall_expr_no_patterns ann var ty body => + let ctx' := ctx.push var.val + .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromDDMSR ctx' body) + | .forall_expr ann var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + match p with + | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromDDMSR ctx'))) + let patternsArray := patternsToArraySR patterns |>.map convertPattern + .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromDDMSR ctx' body) + | .exists_expr_no_patterns ann var ty body => + let ctx' := ctx.push var.val + .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromDDMSR ctx' body) + | .exists_expr ann var ty patterns body => + let ctx' := ctx.push var.val + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + match p with + | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromDDMSR ctx'))) + let patternsArray := patternsToArraySR patterns |>.map convertPattern + .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromDDMSR ctx' body) + | .paren _ expr => expressionFromDDMSR ctx expr + +end + +namespace Expression + +def toAST [Inhabited $ Strata.B3AST.Expression M] (e : B3CST.Expression M) : Strata.B3AST.Expression M := + expressionFromDDMSR FromDDMContextSR.empty e + +def toCST [Inhabited $ Strata.B3CST.Expression M] (e : Strata.B3AST.Expression M) : B3CST.Expression M := + expressionToCSTSR ToCSTContextSR.empty e + +end Expression + +namespace Stmt + +mutual + +partial def callArgToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.CallArg M → B3CST.CallArg M + | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCSTSR ctx e) + | .callArgOut m id => B3CST.CallArg.call_arg_out m (mkAnn m id.val) + | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mkAnn m id.val) + +partial def buildChoiceBranchesSR : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M + | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) + | m, [b] => ChoiceBranches.choiceAtom m b + | m, b :: bs => ChoiceBranches.choicePush m (buildChoiceBranchesSR m bs) b + +partial def stmtToCSTSR [Inhabited (B3CST.Expression M)] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Statement M → B3CST.Statement M + | .varDecl m name ty autoinv init => + let ctx' := ctx.push name.val + match ty.val, autoinv.val, init.val with + | some t, some ai, some i => B3CST.Statement.var_decl_full m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx ai) (expressionToCSTSR ctx' i) + | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx ai) + | some t, none, some i => B3CST.Statement.var_decl_with_init m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx' i) + | some t, none, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m t.val) + | none, _, some i => B3CST.Statement.var_decl_inferred m (mkAnn m name.val) (expressionToCSTSR ctx' i) + | none, _, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m "unknown") + | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val)) (expressionToCSTSR ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val)) + | .blockStmt m stmts => + let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => + let stmt' := stmtToCSTSR ctx stmt + let ctx' := match stmt with + | .varDecl _ name _ _ _ => ctx.push name.val + | _ => ctx + (acc ++ [stmt'], ctx') + ) ([], ctx) + B3CST.Statement.block m (mkAnn m stmts'.toArray) + | .call m procName args => B3CST.Statement.call_statement m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgToCSTSR ctx) |>.toArray)) + | .check m expr => B3CST.Statement.check m (expressionToCSTSR ctx expr) + | .assume m expr => B3CST.Statement.assume m (expressionToCSTSR ctx expr) + | .reach m expr => B3CST.Statement.reach m (expressionToCSTSR ctx expr) + | .assert m expr => B3CST.Statement.assert m (expressionToCSTSR ctx expr) + | .aForall m var ty body => + let ctx' := ctx.push var.val + B3CST.Statement.aForall_statement m (mkAnn m var.val) (mkAnn m ty.val) (stmtToCSTSR ctx' body) + | .choose m branches => + let choiceBranches := branches.val.toList.map (fun s => ChoiceBranch.choice_branch m (stmtToCSTSR ctx s)) + B3CST.Statement.choose_statement m (buildChoiceBranchesSR m choiceBranches) + | .ifStmt m cond thenB elseB => + let elseCST := mapAnn (fun opt => opt.map (fun e => Else.else_some m (stmtToCSTSR ctx e))) elseB + B3CST.Statement.if_statement m (expressionToCSTSR ctx cond) (stmtToCSTSR ctx thenB) elseCST + | .ifCase m cases => + B3CST.Statement.if_case_statement m (mkAnn m (cases.val.toList.map (fun c => + match c with + | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCSTSR ctx cond) (stmtToCSTSR ctx body)) |>.toArray)) + | .loop m invariants body => + B3CST.Statement.loop_statement m (mkAnn m (invariants.val.toList.map (fun e => Invariant.invariant m (expressionToCSTSR ctx e)) |>.toArray)) (stmtToCSTSR ctx body) + | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mkAnn m label.val) (stmtToCSTSR ctx stmt) + | .exit m label => + B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + | .returnStmt m => B3CST.Statement.return_statement m + | .probe m label => B3CST.Statement.probe m (mkAnn m label.val) + +partial def callArgFromDDMSR [Inhabited (B3AST.Expression M)] (ctx : FromDDMContextSR) : B3CST.CallArg M → Strata.B3AST.CallArg M + | .call_arg_expr m expr => .callArgExpr m (expressionFromDDMSR ctx expr) + | .call_arg_out m id => .callArgOut m (mkAnn m id.val) + | .call_arg_inout m id => .callArgInout m (mkAnn m id.val) + +partial def choiceBranchesToListSR : B3CST.ChoiceBranches M → List (B3CST.Statement M) + | .choiceAtom _ branch => + match branch with + | .choice_branch _ stmt => [stmt] + | .choicePush _ branches branch => + match branch with + | .choice_branch _ stmt => stmt :: choiceBranchesToListSR branches + +partial def stmtFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Statement M → Strata.B3AST.Statement M + | .var_decl_full m name ty autoinv init => + let ctx' := ctx.push name.val + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) (mkAnn m (some (expressionFromDDMSR ctx' init))) + | .var_decl_with_autoinv m name ty autoinv => + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) (mkAnn m none) + | .var_decl_with_init m name ty init => + let ctx' := ctx.push name.val + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + | .var_decl_typed m name ty => + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m none) + | .var_decl_inferred m name init => + let ctx' := ctx.push name.val + .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + | .val_decl m name ty init => + let ctx' := ctx.push name.val + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + | .val_decl_inferred m name init => + let ctx' := ctx.push name.val + .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + | .assign m lhs rhs => + .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromDDMSR ctx rhs) + | .reinit_statement m v => + .reinit m (mkAnn m (ctx.lookup v.val)) + | .check m expr => + .check m (expressionFromDDMSR ctx expr) + | .assume m expr => + .assume m (expressionFromDDMSR ctx expr) + | .reach m expr => + .reach m (expressionFromDDMSR ctx expr) + | .assert m expr => + .assert m (expressionFromDDMSR ctx expr) + | .return_statement m => + .returnStmt m + | .block m stmts => + let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => + let stmt' := stmtFromDDMSR ctx stmt + let ctx' := match stmt with + | .var_decl_full _ name _ _ _ => ctx.push name.val + | .var_decl_with_autoinv _ name _ _ => ctx.push name.val + | .var_decl_with_init _ name _ _ => ctx.push name.val + | .var_decl_typed _ name _ => ctx.push name.val + | .var_decl_inferred _ name _ => ctx.push name.val + | .val_decl _ name _ _ => ctx.push name.val + | .val_decl_inferred _ name _ => ctx.push name.val + | _ => ctx + (acc ++ [stmt'], ctx') + ) ([], ctx) + .blockStmt m (mkAnn m stmts'.toArray) + | .if_statement m cond thenB elseB => + let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromDDMSR ctx stmt)) elseB + .ifStmt m (expressionFromDDMSR ctx cond) (stmtFromDDMSR ctx thenB) elseBranch + | .loop_statement m invs body => + let invariants := invs.val.toList.map fun inv => + match inv with + | .invariant _ expr => expressionFromDDMSR ctx expr + .loop m (mkAnn m invariants.toArray) (stmtFromDDMSR ctx body) + | .exit_statement m label => + .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + | .labeled_statement m label stmt => + .labeledStmt m (mkAnn m label.val) (stmtFromDDMSR ctx stmt) + | .probe m label => + .probe m (mkAnn m label.val) + | .aForall_statement m var ty body => + let ctx' := ctx.push var.val + .aForall m (mkAnn m var.val) (mkAnn m ty.val) (stmtFromDDMSR ctx' body) + | .choose_statement m branches => + .choose m (mkAnn m (choiceBranchesToListSR branches |>.map (stmtFromDDMSR ctx)).toArray) + | .if_case_statement m cases => + .ifCase m (mkAnn m (cases.val.toList.map (fun case => + match case with + | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromDDMSR ctx cond) (stmtFromDDMSR ctx stmt)) |>.toArray)) + | .call_statement m procName args => + .call m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgFromDDMSR ctx) |>.toArray)) + +end + +def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (s : B3CST.Statement M) : Strata.B3AST.Statement M := + stmtFromDDMSR FromDDMContextSR.empty s + +def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (s : Strata.B3AST.Statement M) : B3CST.Statement M := + stmtToCSTSR ToCSTContextSR.empty s + +end Stmt + +namespace Decl + +mutual + +partial def fParameterToCSTSR (_ctx : ToCSTContextSR) : Strata.B3AST.FParameter M → B3CST.FParam M + | .fParameter m injective name ty => + let inj := mapAnn (fun b => if b then some (B3CST.Injective.injective_some m) else none) injective + B3CST.FParam.fparam m inj (mkAnn m name.val) (mkAnn m ty.val) + +partial def pParameterToCSTSR [Inhabited $ B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.PParameter M → B3CST.PParam M + | .pParameter m mode name ty autoinv => + let modeCST := match mode with + | .paramModeIn _ => mkAnn m none + | .paramModeOut _ => mkAnn m (some (B3CST.PParamMode.pmode_out m)) + | .paramModeInout _ => mkAnn m (some (B3CST.PParamMode.pmode_inout m)) + match autoinv.val with + | some ai => B3CST.PParam.pparam_with_autoinv m modeCST (mkAnn m name.val) (mkAnn m ty.val) (expressionToCSTSR ctx ai) + | none => B3CST.PParam.pparam m modeCST (mkAnn m name.val) (mkAnn m ty.val) + +partial def specToCSTSR [Inhabited $ B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Spec M → B3CST.Spec M + | .specRequires m expr => B3CST.Spec.spec_requires m (expressionToCSTSR ctx expr) + | .specEnsures m expr => B3CST.Spec.spec_ensures m (expressionToCSTSR ctx expr) + +partial def declToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Decl M → B3CST.Decl M + | .typeDecl m name => + B3CST.Decl.type_decl m (mkAnn m name.val) + | .tagger m name forType => + B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) + | .function m name params resultType tag body => + let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + let paramsCST := mkAnn m (params.val.toList.map (fParameterToCSTSR ctx) |>.toArray) + let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag + let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with + | .functionBody bm whens expr => + let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCSTSR ctx' e)) + B3CST.FunctionBody.function_body_some bm (mkAnn bm whensCST.toArray) (expressionToCSTSR ctx' expr))) body + B3CST.Decl.function_decl m (mkAnn m name.val) paramsCST (mkAnn m resultType.val) tagClause bodyCST + | .axiom m explains expr => + let explainsCST := mkAnn m (explains.val.toList.map (fun id => mkAnn m id.val) |>.toArray) + if explains.val.isEmpty then + B3CST.Decl.axiom_decl m (B3CST.AxiomBody.axiom m (expressionToCSTSR ctx expr)) + else + B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST (expressionToCSTSR ctx expr)) + | .procedure m name params specs body => + let paramNames := params.val.toList.map (fun p => match p with | .pParameter _ _ n _ _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + let paramsCST := mkAnn m (params.val.toList.map (pParameterToCSTSR ctx') |>.toArray) + let specsCST := specs.val.toList.map (specToCSTSR ctx') + let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (Stmt.stmtToCSTSR ctx' s))) body + B3CST.Decl.procedure_decl m (mkAnn m name.val) paramsCST (mkAnn m specsCST.toArray) bodyCST + +partial def fParameterFromDDMSR : B3CST.FParam M → Strata.B3AST.FParameter M + | .fparam m injective name ty => + let inj := match injective.val with + | some (.injective_some _) => true + | none => false + .fParameter m (mkAnn m inj) (mkAnn m name.val) (mkAnn m ty.val) + +partial def pParameterFromDDMSR [Inhabited $ B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.PParam M → Strata.B3AST.PParameter M + | .pparam m mode name ty => + let modeAST := match mode.val with + | none => Strata.B3AST.ParamMode.paramModeIn m + | some (.pmode_out _) => Strata.B3AST.ParamMode.paramModeOut m + | some (.pmode_inout _) => Strata.B3AST.ParamMode.paramModeInout m + .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m none) + | .pparam_with_autoinv m mode name ty autoinv => + let modeAST := match mode.val with + | none => Strata.B3AST.ParamMode.paramModeIn m + | some (.pmode_out _) => Strata.B3AST.ParamMode.paramModeOut m + | some (.pmode_inout _) => Strata.B3AST.ParamMode.paramModeInout m + .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) + +partial def specFromDDMSR [Inhabited $ B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.Spec M → Strata.B3AST.Spec M + | .spec_requires m expr => .specRequires m (expressionFromDDMSR ctx expr) + | .spec_ensures m expr => .specEnsures m (expressionFromDDMSR ctx expr) + +partial def fparamsToListSR : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) + | ⟨_, arr⟩ => arr.toList + +partial def declFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Decl M → Strata.B3AST.Decl M + | .type_decl m name => + .typeDecl m (mkAnn m name.val) + | .tagger_decl m name forType => + .tagger m (mkAnn m name.val) (mkAnn m forType.val) + | .function_decl m name params resultType tag body => + let paramsAST := fparamsToListSR params |>.map fParameterFromDDMSR + let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with + | .function_body_some bm whens expr => + let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromDDMSR ctx' e)) + B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromDDMSR ctx' expr))) body + .function m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m resultType.val) (mkAnn m tagAST) bodyAST + | .axiom_decl m axiomBody => + match axiomBody with + | .axiom _ expr => + .axiom m (mkAnn m #[]) (expressionFromDDMSR ctx expr) + | .explain_axiom _ names expr => + let namesAST := names.val.toList.map (fun n => mkAnn m n.val) + .axiom m (mkAnn m namesAST.toArray) (expressionFromDDMSR ctx expr) + | .procedure_decl m name params specs body => + -- First, collect all parameter names to build context for autoinv expressions + let paramNames := params.val.toList.map (fun p => match p with + | .pparam _ _ n _ => n.val + | .pparam_with_autoinv _ _ n _ _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + -- Now convert all parameters with the full context (so autoinv can reference all params) + let paramsAST := params.val.toList.map (pParameterFromDDMSR ctx') + let specsAST := specs.val.toList.map (specFromDDMSR ctx') + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => Stmt.stmtFromDDMSR ctx' s)) body + .procedure m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST + +end + +def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (d : B3CST.Decl M) : Strata.B3AST.Decl M := + declFromDDMSR FromDDMContextSR.empty d + +def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (d : Strata.B3AST.Decl M) : B3CST.Decl M := + declToCSTSR ToCSTContextSR.empty d + +end Decl + +namespace Program + +partial def programFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Program M → Strata.B3AST.Program M + | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declFromDDMSR ctx) |>.toArray)) + +partial def programToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Program M → B3CST.Program M + | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declToCSTSR ctx) |>.toArray)) + +def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (p : B3CST.Program M) : Strata.B3AST.Program M := + programFromDDMSR FromDDMContextSR.empty p + +def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (p : Strata.B3AST.Program M) : B3CST.Program M := + programToCSTSR ToCSTContextSR.empty p + +end Program + +end AnnotationPreserving + +end B3 diff --git a/Strata/Languages/B3/DDMTransform/DefinitionAST.lean b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean new file mode 100644 index 000000000..47e7da1b1 --- /dev/null +++ b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean @@ -0,0 +1,330 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DDM.Integration.Lean +import Strata.DDM.Util.Format + +--------------------------------------------------------------------- + +namespace Strata + +--------------------------------------------------------------------- +-- B3AST DDM Dialect for Abstract Syntax Tree +--------------------------------------------------------------------- + +#dialect +dialect B3AST; + +category Literal; +category Expression; +category Pattern; +category BinaryOp; +category UnaryOp; +category QuantifierKind; + +op intLit (@[unwrap] n : Num) : Literal => n; +op boolLit (@[unwrap] b : Bool) : Literal => b; +op stringLit (@[unwrap] s : Str) : Literal => s; + +op iff : BinaryOp => "iff"; +op implies : BinaryOp => "implies"; +op impliedBy : BinaryOp => "impliedBy"; +op and : BinaryOp => "and"; +op or : BinaryOp => "or"; +op eq : BinaryOp => "eq"; +op neq : BinaryOp => "neq"; +op lt : BinaryOp => "lt"; +op le : BinaryOp => "le"; +op ge : BinaryOp => "ge"; +op gt : BinaryOp => "gt"; +op add : BinaryOp => "add"; +op sub : BinaryOp => "sub"; +op mul : BinaryOp => "mul"; +op div : BinaryOp => "div"; +op mod : BinaryOp => "mod"; + +op not : UnaryOp => "not"; +op neg : UnaryOp => "neg"; + +op forall : QuantifierKind => "forall"; +op exists : QuantifierKind => "exists"; + +op literal (val : Literal) : Expression => "#" val; +op id (@[unwrap] index : Num) : Expression => index; +op ite (cond : Expression, thn : Expression, els : Expression) : Expression => + "ite " cond " " thn " " els; +op binaryOp (binOp : BinaryOp, lhs : Expression, rhs : Expression) : Expression => + "binop " binOp " " lhs " " rhs; +op unaryOp (unOp : UnaryOp, arg : Expression) : Expression => + "unop " unOp " " arg; +op functionCall (fnName : Ident, args : CommaSepBy Expression) : Expression => + "call " fnName " (" args ")"; +op labeledExpr (label : Ident, expr : Expression) : Expression => + "labeled " label " " expr; +op letExpr (var : Ident, value : Expression, body : Expression) : Expression => + "let " var " = " value " in " body; +op quantifierExpr (quantifier : QuantifierKind, var : Ident, ty : Ident, patterns : Seq Pattern, body : Expression) : Expression => + "quant " quantifier " " var " : " ty " [" patterns "] " body; + +op pattern (exprs : CommaSepBy Expression) : Pattern => + "pattern (" exprs ")"; + +category Statement; +category CallArg; +category OneIfCase; + +op varDecl (name : Ident, ty : Option Ident, autoinv : Option Expression, init : Option Expression) : Statement => + "varDecl " name " : " ty " autoinv " autoinv " := " init; +op assign (lhs : Num, rhs : Expression) : Statement => + "assign @" lhs " := " rhs; +op reinit (name : Num) : Statement => + "reinit @" name; +op blockStmt (stmts : Seq Statement) : Statement => + "block {" stmts "}"; +op call (procName : Ident, args : Seq CallArg) : Statement => + "call " procName "(" args ")"; +op check (expr : Expression) : Statement => + "check " expr; +op assume (expr : Expression) : Statement => + "assume " expr; +op reach (expr : Expression) : Statement => + "reach " expr; +op assert (expr : Expression) : Statement => + "assert " expr; +op aForall (var : Ident, ty : Ident, body : Statement) : Statement => + "forall " var " : " ty " " body; +op choose (branches : Seq Statement) : Statement => + "choose " branches; +op ifStmt (cond : Expression, thenBranch : Statement, elseBranch : Option Statement) : Statement => + "if " cond " then " thenBranch " else " elseBranch; +op oneIfCase (cond : Expression, body : Statement): OneIfCase => + "oneIfCase " cond body; +op ifCase (cases : Seq OneIfCase) : Statement => + "ifcase " cases; +op loop (invariants : Seq Expression, body : Statement) : Statement => + "loop invariants " invariants " {" body "}"; +op labeledStmt (label : Ident, stmt : Statement) : Statement => + "labelStmt " label " " stmt; +op exit (label : Option Ident) : Statement => + "exit " label; +op returnStmt : Statement => + "return"; +op probe (label : Ident) : Statement => + "probe " label; + +op callArgExpr (e : Expression) : CallArg => + "expr " e; +op callArgOut (id : Ident) : CallArg => + "out " id; +op callArgInout (id : Ident) : CallArg => + "inout " id; + +category ParamMode; +category FParameter; +category PParameter; +category Spec; +category Decl; + +op paramModeIn : ParamMode => "in"; +op paramModeOut : ParamMode => "out"; +op paramModeInout : ParamMode => "inout"; + +op fParameter (injective : Bool, name : Ident, ty : Ident) : FParameter => + "fparam " injective " " name " : " ty; + +op pParameter (mode : ParamMode, name : Ident, ty : Ident, autoinv : Option Expression) : PParameter => + "pparam " mode " " name " : " ty " autoinv " autoinv; + +op specRequires (expr : Expression) : Spec => + "requires " expr; +op specEnsures (expr : Expression) : Spec => + "ensures " expr; + +op typeDecl (name : Ident) : Decl => + "type " name; +op tagger (name : Ident, forType : Ident) : Decl => + "tagger " name " for " forType; + +category When; +op when (cond: Expression): When => + "when " cond; + +category FunctionBody; +op functionBody (whens: Seq When, body: Expression): FunctionBody => + whens "{" body "}"; + +op function (name : Ident, params : Seq FParameter, resultType : Ident, tag : Option Ident, body : Option FunctionBody) : Decl => + "\nfunction " name " (" params ") : " resultType " tag " tag " body " body; + +op axiom (explains : Seq Ident, expr : Expression) : Decl => + "\naxiom explains " explains "," expr; + +op procedure (name : Ident, params : Seq PParameter, specs : Seq Spec, body : Option Statement) : Decl => + "\nprocedure " name " (" params ") specs " specs " body " body; + +category Program; +op program (decls : Seq Decl) : Program => + decls; + +#end + +namespace B3AST + +#strata_gen B3AST + +end B3AST + +--------------------------------------------------------------------- +-- Metadata Transformation +--------------------------------------------------------------------- + +namespace B3AST + +open Strata.B3AST + +private def mapAnn {α M N : Type} (f : M → N) (a : Ann α M) : Ann α N := + ⟨f a.ann, a.val⟩ + +mutual + +partial def Literal.mapMetadata [Inhabited N] (f : M → N) : Literal M → Literal N + | .intLit m n => .intLit (f m) n + | .boolLit m b => .boolLit (f m) b + | .stringLit m s => .stringLit (f m) s + +partial def BinaryOp.mapMetadata [Inhabited N] (f : M → N) : BinaryOp M → BinaryOp N + | .iff m => .iff (f m) + | .implies m => .implies (f m) + | .impliedBy m => .impliedBy (f m) + | .and m => .and (f m) + | .or m => .or (f m) + | .eq m => .eq (f m) + | .neq m => .neq (f m) + | .lt m => .lt (f m) + | .le m => .le (f m) + | .ge m => .ge (f m) + | .gt m => .gt (f m) + | .add m => .add (f m) + | .sub m => .sub (f m) + | .mul m => .mul (f m) + | .div m => .div (f m) + | .mod m => .mod (f m) + +partial def UnaryOp.mapMetadata [Inhabited N] (f : M → N) : UnaryOp M → UnaryOp N + | .not m => .not (f m) + | .neg m => .neg (f m) + +partial def QuantifierKind.mapMetadata [Inhabited N] (f : M → N) : QuantifierKind M → QuantifierKind N + | .forall m => .forall (f m) + | .exists m => .exists (f m) + +partial def Expression.mapMetadata [Inhabited N] (f : M → N) : Expression M → Expression N + | .literal m lit => .literal (f m) (Literal.mapMetadata f lit) + | .id m idx => .id (f m) idx + | .ite m cond thn els => .ite (f m) (Expression.mapMetadata f cond) (Expression.mapMetadata f thn) (Expression.mapMetadata f els) + | .binaryOp m op lhs rhs => .binaryOp (f m) (BinaryOp.mapMetadata f op) (Expression.mapMetadata f lhs) (Expression.mapMetadata f rhs) + | .unaryOp m op arg => .unaryOp (f m) (UnaryOp.mapMetadata f op) (Expression.mapMetadata f arg) + | .functionCall m fnName args => .functionCall (f m) (mapAnn f fnName) ⟨f args.ann, args.val.map (Expression.mapMetadata f)⟩ + | .labeledExpr m label expr => .labeledExpr (f m) (mapAnn f label) (Expression.mapMetadata f expr) + | .letExpr m var value body => .letExpr (f m) (mapAnn f var) (Expression.mapMetadata f value) (Expression.mapMetadata f body) + | .quantifierExpr m qkind var ty patterns body => + .quantifierExpr (f m) (QuantifierKind.mapMetadata f qkind) (mapAnn f var) (mapAnn f ty) + ⟨f patterns.ann, patterns.val.map (Pattern.mapMetadata f)⟩ (Expression.mapMetadata f body) + +partial def Pattern.mapMetadata [Inhabited N] (f : M → N) : Pattern M → Pattern N + | .pattern m exprs => .pattern (f m) ⟨f exprs.ann, exprs.val.map (Expression.mapMetadata f)⟩ + +partial def CallArg.mapMetadata [Inhabited N] (f : M → N) : CallArg M → CallArg N + | .callArgExpr m e => .callArgExpr (f m) (Expression.mapMetadata f e) + | .callArgOut m id => .callArgOut (f m) (mapAnn f id) + | .callArgInout m id => .callArgInout (f m) (mapAnn f id) + +partial def OneIfCase.mapMetadata [Inhabited N] (f : M → N) : OneIfCase M → OneIfCase N + | .oneIfCase m cond body => .oneIfCase (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f body) + +partial def Statement.mapMetadata [Inhabited N] (f : M → N) : Statement M → Statement N + | .varDecl m name ty autoinv init => + .varDecl (f m) (mapAnn f name) + ⟨f ty.ann, ty.val.map (mapAnn f)⟩ + ⟨f autoinv.ann, autoinv.val.map (Expression.mapMetadata f)⟩ + ⟨f init.ann, init.val.map (Expression.mapMetadata f)⟩ + | .assign m lhs rhs => .assign (f m) (mapAnn f lhs) (Expression.mapMetadata f rhs) + | .reinit m idx => .reinit (f m) (mapAnn f idx) + | .blockStmt m stmts => .blockStmt (f m) ⟨f stmts.ann, stmts.val.map (Statement.mapMetadata f)⟩ + | .call m procName args => .call (f m) (mapAnn f procName) ⟨f args.ann, args.val.map (CallArg.mapMetadata f)⟩ + | .check m expr => .check (f m) (Expression.mapMetadata f expr) + | .assume m expr => .assume (f m) (Expression.mapMetadata f expr) + | .reach m expr => .reach (f m) (Expression.mapMetadata f expr) + | .assert m expr => .assert (f m) (Expression.mapMetadata f expr) + | .aForall m var ty body => .aForall (f m) (mapAnn f var) (mapAnn f ty) (Statement.mapMetadata f body) + | .choose m branches => .choose (f m) ⟨f branches.ann, branches.val.map (Statement.mapMetadata f)⟩ + | .ifStmt m cond thenB elseB => + .ifStmt (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f thenB) + ⟨f elseB.ann, elseB.val.map (Statement.mapMetadata f)⟩ + | .ifCase m cases => .ifCase (f m) ⟨f cases.ann, cases.val.map (OneIfCase.mapMetadata f)⟩ + | .loop m invariants body => + .loop (f m) ⟨f invariants.ann, invariants.val.map (Expression.mapMetadata f)⟩ (Statement.mapMetadata f body) + | .labeledStmt m label stmt => .labeledStmt (f m) (mapAnn f label) (Statement.mapMetadata f stmt) + | .exit m label => .exit (f m) ⟨f label.ann, label.val.map (mapAnn f)⟩ + | .returnStmt m => .returnStmt (f m) + | .probe m label => .probe (f m) (mapAnn f label) + +partial def ParamMode.mapMetadata [Inhabited N] (f : M → N) : ParamMode M → ParamMode N + | .paramModeIn m => .paramModeIn (f m) + | .paramModeOut m => .paramModeOut (f m) + | .paramModeInout m => .paramModeInout (f m) + +partial def FParameter.mapMetadata [Inhabited N] (f : M → N) : FParameter M → FParameter N + | .fParameter m injective name ty => .fParameter (f m) (mapAnn f injective) (mapAnn f name) (mapAnn f ty) + +partial def PParameter.mapMetadata [Inhabited N] (f : M → N) : PParameter M → PParameter N + | .pParameter m mode name ty autoinv => + .pParameter (f m) (ParamMode.mapMetadata f mode) (mapAnn f name) (mapAnn f ty) + ⟨f autoinv.ann, autoinv.val.map (Expression.mapMetadata f)⟩ + +partial def Spec.mapMetadata [Inhabited N] (f : M → N) : Spec M → Spec N + | .specRequires m expr => .specRequires (f m) (Expression.mapMetadata f expr) + | .specEnsures m expr => .specEnsures (f m) (Expression.mapMetadata f expr) + +partial def When.mapMetadata [Inhabited N] (f : M → N) : When M → When N + | .when m cond => .when (f m) (Expression.mapMetadata f cond) + +partial def FunctionBody.mapMetadata [Inhabited N] (f : M → N) : FunctionBody M → FunctionBody N + | .functionBody m whens body => + .functionBody (f m) ⟨f whens.ann, whens.val.map (When.mapMetadata f)⟩ (Expression.mapMetadata f body) + +partial def Decl.mapMetadata [Inhabited N] (f : M → N) : Decl M → Decl N + | .typeDecl m name => .typeDecl (f m) (mapAnn f name) + | .tagger m name forType => .tagger (f m) (mapAnn f name) (mapAnn f forType) + | .function m name params resultType tag body => + .function (f m) (mapAnn f name) ⟨f params.ann, params.val.map (FParameter.mapMetadata f)⟩ + (mapAnn f resultType) ⟨f tag.ann, tag.val.map (mapAnn f)⟩ + ⟨f body.ann, body.val.map (FunctionBody.mapMetadata f)⟩ + | .axiom m explains expr => + .axiom (f m) ⟨f explains.ann, explains.val.map (mapAnn f)⟩ (Expression.mapMetadata f expr) + | .procedure m name params specs body => + .procedure (f m) (mapAnn f name) ⟨f params.ann, params.val.map (PParameter.mapMetadata f)⟩ + ⟨f specs.ann, specs.val.map (Spec.mapMetadata f)⟩ + ⟨f body.ann, body.val.map (Statement.mapMetadata f)⟩ + +partial def Program.mapMetadata [Inhabited N] (f : M → N) : Program M → Program N + | .program m decls => .program (f m) ⟨f decls.ann, decls.val.map (Decl.mapMetadata f)⟩ + +end + +partial def Expression.toUnit [Inhabited (Expression Unit)] (e : Expression M) : Expression Unit := + e.mapMetadata (fun _ => ()) + +partial def Statement.toUnit [Inhabited (Expression Unit)] (s : Statement M) : Statement Unit := + s.mapMetadata (fun _ => ()) + +partial def Decl.toUnit [Inhabited (Expression Unit)] (d : Decl M) : Decl Unit := + d.mapMetadata (fun _ => ()) + +partial def Program.toUnit [Inhabited (Expression Unit)] (p : Program M) : Program Unit := + p.mapMetadata (fun _ => ()) + +end B3AST diff --git a/Strata/Languages/B3/DDMTransform/ParseCST.lean b/Strata/Languages/B3/DDMTransform/ParseCST.lean new file mode 100644 index 000000000..215a40470 --- /dev/null +++ b/Strata/Languages/B3/DDMTransform/ParseCST.lean @@ -0,0 +1,235 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DDM.Integration.Lean +import Strata.DDM.Util.Format + +--------------------------------------------------------------------- + +namespace Strata + +--------------------------------------------------------------------- +-- B3AST DDM Dialect for Abstract Syntax Tree +--------------------------------------------------------------------- + +#dialect +dialect B3CST; + +category Expression; + +op not (e : Expression) : Expression => @[prec(35)] "!" e; + +op natLit (n : Num) : Expression => n; +op strLit (s : Str) : Expression => s; + +op btrue : Expression => "true"; +op bfalse : Expression => "false"; + +op old_id (name : Ident) : Expression => "old " name; +op id (name : Ident) : Expression => name; + +op letExpr (name : Ident, value : Expression, body : Expression) : Expression => + @[prec(2)] "val " name " := " value:0 " " body:2; + +op labeledExpr (label : Ident, e : Expression) : Expression => @[prec(1)] label ": " e:1; + +op ite (c : Expression, t : Expression, f : Expression) : Expression => @[prec(3)] "if " c:0 " then " indent(2, t:3) " else " indent(2, f:3); +op iff (a : Expression, b : Expression) : Expression => @[prec(4)] a " <==> " b; +op implies (a : Expression, b : Expression) : Expression => @[prec(5), rightassoc] a " ==> " b; +op impliedBy (a : Expression, b : Expression) : Expression => @[prec(5), rightassoc] a " <== " b; +op and (a : Expression, b : Expression) : Expression => @[prec(10), leftassoc] a " && " b; +op or (a : Expression, b : Expression) : Expression => @[prec(8), leftassoc] a " || " b; + +op equal (a : Expression, b : Expression) : Expression => @[prec(15)] a " == " b; +op not_equal (a : Expression, b : Expression) : Expression => @[prec(15)] a " != " b; +op le (a : Expression, b : Expression) : Expression => @[prec(15)] a " <= " b; +op lt (a : Expression, b : Expression) : Expression => @[prec(15)] a " < " b; +op ge (a : Expression, b : Expression) : Expression => @[prec(15)] a " >= " b; +op gt (a : Expression, b : Expression) : Expression => @[prec(15)] a " > " b; + +op neg (e : Expression) : Expression => "-" e; +op add (a : Expression, b : Expression) : Expression => @[prec(25), leftassoc] a " + " b; +op sub (a : Expression, b : Expression) : Expression => @[prec(25), leftassoc] a " - " b; +op mul (a : Expression, b : Expression) : Expression => @[prec(30), leftassoc] a " * " b; +op div (a : Expression, b : Expression) : Expression => @[prec(30), leftassoc] a " div " b; +op mod (a : Expression, b : Expression) : Expression => @[prec(30), leftassoc] a " mod " b; +op paren (a : Expression) : Expression => @[prec(30)] "(" a ")"; + +op functionCall (name : Ident, args : CommaSepBy Expression) : Expression => @[prec(40)] name "(" args ")"; + +category Pattern; +op pattern (e : CommaSepBy Expression) : Pattern => " pattern " e:0; + +category Patterns; +op patterns_cons (p : Pattern, ps : Patterns) : Patterns => @[prec(0)] p:0 ps:0; +op patterns_single (p : Pattern) : Patterns => @[prec(0)] p:0; + +op forall_expr_no_patterns (var : Ident, ty : Ident, body : Expression) : Expression => + @[prec(1)] "forall " var " : " ty " " body:1; + +op forall_expr (var : Ident, ty : Ident, patterns : Patterns, body : Expression) : Expression => + @[prec(1)] "forall " var " : " ty patterns " " body:1; + +op exists_expr_no_patterns (var : Ident, ty : Ident, body : Expression) : Expression => + @[prec(1)] "exists " var " : " ty " " body:1; + +op exists_expr (var : Ident, ty : Ident, patterns : Patterns, body : Expression) : Expression => + @[prec(1)] "exists " var " : " ty patterns " " body:1; + +category Statement; + +op assign (v : Ident, e : Expression) : Statement => "\n" v:0 " := " e:0; +op reinit_statement (v : Ident) : Statement => "\nreinit " v:0; + +category CallArg; +op call_arg_expr (e : Expression) : CallArg => e:0; +op call_arg_out (id : Ident) : CallArg => "out " id:0; +op call_arg_inout (id : Ident) : CallArg => "inout " id:0; + +op call_statement (proc : Ident, args : CommaSepBy CallArg) : Statement => + "\n" proc "(" args ")"; + +op check (c : Expression) : Statement => "\ncheck " c:0; +op assume (c : Expression) : Statement => "\nassume " c:0; +op reach (c : Expression) : Statement => "\nreach " c:0; +op assert (c : Expression) : Statement => "\nassert " c:0; + +category Else; +op else_some (s : Statement) : Else => @[prec(0)] "\nelse " indent(2, s:0); + +op if_statement (c : Expression, t : Statement, f : Option Else) : Statement => + "\nif " c:0 " " indent(2, t:0) f:0; + +category Invariant; +op invariant (e : Expression) : Invariant => "\n invariant " e:0; + +op loop_statement (invs : Seq Invariant, body : Statement) : Statement => + "\nloop" invs " " body:40; + +op exit_statement (label : Option Ident) : Statement => "\nexit " label:0 ; +op return_statement () : Statement => "\nreturn"; + +op labeled_statement (label : Ident, s : Statement) : Statement => label:0 ": " s:0; + +op probe (name : Ident) : Statement => "\nprobe " name:0 ; + +op var_decl_full (name : Ident, ty : Ident, autoinv : Expression, init : Expression) : Statement => + "\nvar " name:0 " : " ty:0 " autoinv " autoinv:0 " := " init:0 ; + +op var_decl_with_autoinv (name : Ident, ty : Ident, autoinv : Expression) : Statement => + "\nvar " name:0 " : " ty:0 " autoinv " autoinv:0 ; + +op var_decl_with_init (name : Ident, ty : Ident, init : Expression) : Statement => + "\nvar " name:0 " : " ty:0 " := " init:0 ; + +op var_decl_typed (name : Ident, ty : Ident) : Statement => + "\nvar " name:0 " : " ty:0 ; + +op var_decl_inferred (name : Ident, init : Expression) : Statement => + "\nvar " name:0 " := " init:0 ; + +op val_decl (name : Ident, ty : Ident, init : Expression) : Statement => + "\nval " name:0 " : " ty:0 " := " init:0 ; + +op val_decl_inferred (name : Ident, init : Expression) : Statement => + "\nval " name:0 " := " init:0 ; + +category ChoiceBranch; +op choice_branch (s : Statement) : ChoiceBranch => s:40; + +category ChoiceBranches; +op choiceAtom (b : ChoiceBranch) : ChoiceBranches => b:0; +op choicePush (bs : ChoiceBranches, b : ChoiceBranch) : ChoiceBranches => bs:0 " or " b:0; + +op choose_statement (branches : ChoiceBranches) : Statement => + "\nchoose " branches:0; + +category IfCaseBranch; +op if_case_branch (cond : Expression, body : Statement) : IfCaseBranch => + "\ncase " cond:0 " " body:40; + +op if_case_statement (branches : Seq IfCaseBranch) : Statement => + "\nif" branches:0; + +op aForall_statement (var : Ident, ty : Ident, body : Statement) : Statement => + "\nforall " var:0 " : " ty:0 " " body:40; + +op block (c : Seq Statement) : Statement => "\n{" indent(2, c:0) "\n}"; + +category Decl; + +op type_decl (name : Ident) : Decl => "\ntype " name:0; + +op tagger_decl (name : Ident, forType : Ident) : Decl => "\ntagger " name:0 " for " forType:0; + +category Injective; +op injective_some () : Injective => "injective "; + +category FParam; +op fparam (injective : Option Injective, name : Ident, ty : Ident) : FParam => + injective:0 name:0 " : " ty:0; + +category TagClause; +op tag_some (t : Ident) : TagClause => " tag " t:0; + +category WhenClause; +op when_clause (e : Expression) : WhenClause => "\n when " e:0; + +category FunctionBody; +op function_body_some (whens : Seq WhenClause, e : Expression) : FunctionBody => whens:0 " {" indent(2, "\n" e:0) "\n}"; + +op function_decl (name : Ident, params : CommaSepBy FParam, resultType : Ident, tag : Option TagClause, body : Option FunctionBody) : Decl => + "\nfunction " name:0 "(" params:0 ")" " : " resultType:0 tag:0 body:0; + +category AxiomBody; + +op explain_axiom (names: CommaSepBy Ident, expr : Expression) : AxiomBody => + "explains " names:0 indent(2, "\n" expr:0); + +op axiom (expr : Expression) : AxiomBody => + expr; + +op axiom_decl (expr : AxiomBody) : Decl => + "\naxiom " expr:0; + +category PParamMode; +op pmode_out () : PParamMode => "out "; +op pmode_inout () : PParamMode => "inout "; + +category PParam; +op pparam (mode : Option PParamMode, name : Ident, ty : Ident) : PParam => + mode:0 name:0 " : " ty:0; + +op pparam_with_autoinv (mode : Option PParamMode, name : Ident, ty : Ident, autoinv : Expression) : PParam => + mode:0 name:0 " : " ty:0 " autoinv " autoinv:0; + +category Spec; +op spec_requires (e : Expression) : Spec => "\n requires " e:0; +op spec_ensures (e : Expression) : Spec => "\n ensures " e:0; + +category ProcBody; +op proc_body_some (s : Statement) : ProcBody => s:40; + +op procedure_decl (name : Ident, params : CommaSepBy PParam, specs : Seq Spec, body : Option ProcBody) : Decl => + "\nprocedure " name "(" params ")" specs body:0; + +category Program; +op program (decls : Seq Decl) : Program => + decls; + +op command_stmt (s : Statement) : Command => s; +op command_program (p : Program) : Command => p; +#end + +namespace B3CST + +#strata_gen B3CST + +end B3CST + +--------------------------------------------------------------------- + +end Strata diff --git a/Strata/Languages/B3/DDMTransform/README.md b/Strata/Languages/B3/DDMTransform/README.md new file mode 100644 index 000000000..43de350ef --- /dev/null +++ b/Strata/Languages/B3/DDMTransform/README.md @@ -0,0 +1,44 @@ +# B3 DDM Transform + +This directory contains the DDM (Dialect Definition Mechanism) support for the B3 language, providing parser and pretty-printer functionality. + +## Files + +### Parse.lean +Defines the B3 dialect using DDM syntax. This includes: +- Type declarations (bool, int, string) +- Expression operators (binary, unary, logical) +- Statement operators (assign, check, assume, assert, etc.) +- Control flow constructs (if, loop, exit, return) + +The dialect definition uses DDM's declarative syntax to specify: +- Operator precedence and associativity +- Pretty-printing format +- Parsing rules + +### Translate.lean +Provides translation from DDM's concrete syntax tree to B3's abstract syntax tree. This includes: +- Expression translation (literals, operators, variables) +- Statement translation (assignments, assertions, control flow) +- Type translation +- Binding management for scoped variables + +## Usage + +The DDM dialect can be used with `#strata` blocks (similar to Boogie) to parse B3 programs directly in Lean files. + +## Comparison with Boogie + +This implementation follows the same pattern as `Strata/Languages/Boogie/DDMTransform/`: +- `Parse.lean` defines the dialect syntax +- `Translate.lean` converts DDM AST to language-specific AST +- The structure is simplified for B3's smaller feature set + +## Current Limitations + +The current implementation provides a minimal working dialect with: +- Basic expression operators +- Core statement types +- Simple control flow + +Additional features from B3 (quantifiers, patterns, procedure calls, etc.) can be added incrementally by extending both Parse.lean and Translate.lean. diff --git a/Strata/Languages/B3/Examples/DDMTransform.lean b/Strata/Languages/B3/Examples/DDMTransform.lean new file mode 100644 index 000000000..f2e5c67a5 --- /dev/null +++ b/Strata/Languages/B3/Examples/DDMTransform.lean @@ -0,0 +1,30 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.ParseCST +import Strata.Languages.B3.DDMTransform.DefinitionAST + +--------------------------------------------------------------------- +namespace Strata +set_option maxRecDepth 10000 + +/-! +## B3 DDM Dialect Example + +This file demonstrates the DDM dialect definition for B3. +The dialect is defined in `Strata/Languages/B3/DDMTransform/Parse.lean` +and the translation from DDM AST to B3 AST is in `Strata/Languages/B3/DDMTransform/Translate.lean`. + +The DDM dialect provides: +- Parser for B3 syntax +- Pretty-printer for B3 programs +- Translation to B3 abstract syntax tree + +Example usage would be with `#strata` blocks, similar to Boogie. +-/ + +end Strata +--------------------------------------------------------------------- diff --git a/Strata/Languages/B3/Identifiers.lean b/Strata/Languages/B3/Identifiers.lean new file mode 100644 index 000000000..8cbf3d9bf --- /dev/null +++ b/Strata/Languages/B3/Identifiers.lean @@ -0,0 +1,78 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.Lambda.LExprTypeEnv + +namespace B3 + +open Std + +/-- + Metadata for B3 identifiers. + For now, we use a simple unit type since B3 doesn't have scoping. +-/ +inductive B3IdentifierMetadata where + | none +deriving DecidableEq, Repr + +instance : ToFormat B3IdentifierMetadata where + format + | .none => "" + +instance : ToString B3IdentifierMetadata where + toString v := toString $ ToFormat.format v + +abbrev B3Ident := Lambda.Identifier B3IdentifierMetadata +abbrev B3Label := String + +def B3IdentDec : DecidableEq B3Ident := inferInstanceAs (DecidableEq (Lambda.Identifier B3IdentifierMetadata)) + +@[match_pattern] +def B3Ident.mk (s : String) : B3Ident := ⟨s, B3IdentifierMetadata.none⟩ + +instance : Coe String B3Ident where + coe | s => .mk s + +def B3Ident.toPretty (x : B3Ident) : String := + match x with | ⟨s, _⟩ => s + +instance : ToFormat B3Ident where + format i := B3Ident.toPretty i + +instance : ToString B3Ident where + toString | ⟨s, v⟩ => (toString $ ToFormat.format v) ++ (toString $ ToFormat.format s) + +instance : Repr B3Ident where + reprPrec | ⟨s, v⟩, _ => (ToFormat.format v) ++ (ToFormat.format s) + +instance : Inhabited B3Ident where + default := ⟨"_", .none⟩ + +instance : Lambda.HasGen B3IdentifierMetadata where + genVar T := let (sym, state') := (Lambda.TState.genExprSym T.genState) + (B3Ident.mk sym, { T with genState := state' }) + +namespace Syntax + +open Lean Elab Meta Lambda.LExpr.SyntaxMono + +scoped syntax ident : lidentmono + +def elabB3Ident : Syntax → MetaM Expr + | `(lidentmono| $s:ident) => do + let s := toString s.getId + return ← mkAppM ``B3Ident.mk #[mkStrLit s] + | _ => throwUnsupportedSyntax + +instance : MkIdent B3IdentifierMetadata where + elabIdent := elabB3Ident + toExpr := .const ``B3IdentifierMetadata [] + +elab "b3[" e:lexprmono "]" : term => elabLExprMono (IDMeta:=B3IdentifierMetadata) e + +end Syntax + +end B3 diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean new file mode 100644 index 000000000..5d86d9def --- /dev/null +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -0,0 +1,731 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import StrataTest.Languages.B3.DDMFormatTests +import Strata.Languages.B3.DDMConversion + +namespace B3 + +open Std (Format) +open Strata +open Strata.B3CST + +partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := + match B3CST.Decl.ofAst decl with + | .ok cstDecl => + let b3Decl := Decl.toAST cstDecl + let b3DeclUnit := b3Decl.toUnit + let reprStr := (repr b3DeclUnit).pretty + let reprStr := cleanupDeclRepr reprStr + let reprStr := cleanupUnitRepr reprStr + dbg_trace f!"B3: {reprStr}" + let cstDecl' := Decl.toCST b3Decl + let cstAst := cstDecl'.toAst + cformat (ArgF.op cstAst) ctx state + | .error msg => s!"Parse error: {msg}" + +partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) (printIntermediate: Bool := true) : Format := + match B3CST.Program.ofAst prog with + | .ok cstProg => + let b3Prog := Program.toAST cstProg + dbg_trace (if printIntermediate then + let b3ProgUnit := b3Prog.toUnit + let reprStr := (repr b3ProgUnit).pretty + let reprStr := cleanupDeclRepr reprStr + let reprStr := cleanupUnitRepr reprStr + f!"B3: {reprStr}" + else + f!"") + + let cstProg' := Program.toCST b3Prog + let cstAst := cstProg'.toAst + cformat (ArgF.op cstAst) ctx state + | .error msg => s!"Parse error: {msg}" + +def roundtripDecl (p : Program) : Format := + let ctx := p.formatContext {} + let state := p.formatState + match p.commands.toList with + | [op] => + if op.name.name == "command_program" then + match op.args.toList with + | [ArgF.op prog] => doRoundtripProgram prog ctx state + | _ => "Error: expected program op" + else s!"Error: expected command_program, got {op.name.name}" + | _ => "Error: expected single command" + + + +section DeclarationRoundtripTests + +-- Type declaration +/-- +info: B3: .program () u #[.typeDecl () u "MyType"] +--- +info: +type MyType +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; type MyType #end + +-- Tagger declaration +/-- +info: B3: .program + () + u #[.tagger () u "MyTagger" u "MyType"] +--- +info: +tagger MyTagger for MyType +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; tagger MyTagger for MyType #end + +-- Simple axiom +/-- +info: B3: .program + () + u #[.axiom + () + u #[] + (.literal () (.boolLit () u true))] +--- +info: +axiom true +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; axiom true #end + +/-- +info: B3: .program + () + u #[.function + () + u "F" + u #[.fParameter + () + u false + u "x" + u "int"] + u "int" + u none + u some (.functionBody + () + u #[] + (.literal + () + (.intLit () u 1)))] +--- +info: +function F(x : int) : int { + 1 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; function F(x: int) : int { 1 } #end + +-- Function with multiple parameters +/-- +info: B3: .program + () + u #[.function + () + u "add" + u #[.fParameter + () + u false + u "x" + u "int", + .fParameter + () + u false + u "y" + u "int"] + u "int" + u none + u some (.functionBody + () + u #[] + (.binaryOp + () + (.add ()) + (.id () u 1) + (.id () u 0)))] +--- +info: +function add(x : int, y : int) : int { + x + y +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; function add(x: int, y: int) : int { x + y } #end + +-- Function with injective parameter +/-- +info: B3: .program + () + u #[.function + () + u "id" + u #[.fParameter + () + u true + u "x" + u "int"] + u "int" + u none + u some (.functionBody + () + u #[] + (.id () u 0))] +--- +info: +function id(injective x : int) : int { + x +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; function id(injective x: int) : int { x } #end + +-- Function with tag +/-- +info: B3: .program + () + u #[.function + () + u "tagged" + u #[.fParameter + () + u false + u "x" + u "int"] + u "int" + u some u "mytag" + u some (.functionBody + () + u #[] + (.id () u 0))] +--- +info: +function tagged(x : int) : int tag mytag { + x +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; function tagged(x: int) : int tag mytag { x } #end + +-- Function with when clause +/-- +info: B3: .program + () + u #[.function + () + u "conditional" + u #[.fParameter + () + u false + u "x" + u "int"] + u "int" + u none + u some (.functionBody + () + u #[.when + () + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))] + (.id () u 0))] +--- +info: +function conditional(x : int) : int + when x > 0 { + x +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; function conditional(x: int) : int when x > 0 { x } #end + +-- Simple procedure with no parameters +/-- +info: B3: .program + () + u #[.procedure + () + u "noop" + u #[] + u #[] + u some (.blockStmt + () + u #[.returnStmt ()])] +--- +info: +procedure noop() +{ + return +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure noop() { return } #end + +-- Procedure with in parameter +/-- +info: B3: .program + () + u #[.procedure + () + u "process" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u none] + u #[] + u some (.blockStmt + () + u #[.check + () + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))])] +--- +info: +procedure process(x : int) +{ + check x > 0 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure process(x: int) { check x > 0 } #end + +-- Procedure with out parameter +/-- +info: B3: .program + () + u #[.procedure + () + u "getResult" + u #[.pParameter + () + (.paramModeOut ()) + u "result" + u "int" + u none] + u #[] + u some (.blockStmt + () + u #[.assign + () + u 0 + (.literal + () + (.intLit () u 42))])] +--- +info: +procedure getResult(out result : int) +{ + result := 42 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure getResult(out result: int) { result := 42 } #end + +-- Procedure with inout parameter +/-- +info: B3: .program + () + u #[.procedure + () + u "increment" + u #[.pParameter + () + (.paramModeInout ()) + u "x" + u "int" + u none] + u #[] + u some (.blockStmt + () + u #[.assign + () + u 0 + (.binaryOp + () + (.add ()) + (.id () u 0) + (.literal + () + (.intLit () u 1)))])] +--- +info: +procedure increment(inout x : int) +{ + x := x + 1 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure increment(inout x: int) { x := x + 1 } #end + +-- Procedure with mixed parameters +/-- +info: B3: .program + () + u #[.procedure + () + u "compute" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u none, + .pParameter + () + (.paramModeOut ()) + u "y" + u "int" + u none, + .pParameter + () + (.paramModeInout ()) + u "z" + u "int" + u none] + u #[] + u some (.blockStmt + () + u #[.assign + () + u 1 + (.binaryOp + () + (.add ()) + (.id () u 2) + (.id () u 0)), + .assign + () + u 0 + (.binaryOp + () + (.add ()) + (.id () u 0) + (.literal + () + (.intLit () u 1)))])] +--- +info: +procedure compute(x : int, out y : int, inout z : int) +{ + y := x + z + z := z + 1 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure compute(x: int, out y: int, inout z: int) { y := x + z z := z + 1 } #end + +-- Procedure with requires spec +/-- +info: B3: .program + () + u #[.procedure + () + u "safe" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u none] + u #[.specRequires + () + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))] + u some (.blockStmt + () + u #[.check + () + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))])] +--- +info: +procedure safe(x : int) + requires x > 0 +{ + check x > 0 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure safe(x: int) requires x > 0 { check x > 0 } #end + +-- Procedure with ensures spec +/-- +info: B3: .program + () + u #[.procedure + () + u "positive" + u #[.pParameter + () + (.paramModeOut ()) + u "x" + u "int" + u none] + u #[.specEnsures + () + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))] + u some (.blockStmt + () + u #[.assign + () + u 0 + (.literal + () + (.intLit () u 1))])] +--- +info: +procedure positive(out x : int) + ensures x > 0 +{ + x := 1 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure positive(out x: int) ensures x > 0 { x := 1 } #end + +-- Procedure with both requires and ensures +/-- +info: B3: .program + () + u #[.procedure + () + u "bounded" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u none, + .pParameter + () + (.paramModeOut ()) + u "y" + u "int" + u none] + u #[.specRequires + () + (.binaryOp + () + (.ge ()) + (.id () u 1) + (.literal + () + (.intLit () u 0))), + .specEnsures + () + (.binaryOp + () + (.ge ()) + (.id () u 0) + (.literal + () + (.intLit () u 0)))] + u some (.blockStmt + () + u #[.assign + () + u 0 + (.id () u 1)])] +--- +info: +procedure bounded(x : int, out y : int) + requires x >= 0 + ensures y >= 0 +{ + y := x +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure bounded(x: int, out y: int) requires x >= 0 ensures y >= 0 { y := x } #end + +-- Procedure with parameter autoinv +/-- +info: B3: .program + () + u #[.procedure + () + u "withAutoinv" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u some (.binaryOp + () + (.ge ()) + (.binaryOp + () + (.add ()) + (.id () u 1) + (.id () u 0)) + (.literal + () + (.intLit () u 0))), + .pParameter + () + (.paramModeIn ()) + u "y" + u "int" + u some (.binaryOp + () + (.ge ()) + (.id () u 0) + (.unaryOp + () + (.neg ()) + (.id () u 1)))] + u #[] + u some (.blockStmt + () + u #[.check + () + (.binaryOp + () + (.ge ()) + (.id () u 1) + (.literal + () + (.intLit () u 0)))])] +--- +info: +procedure withAutoinv(x : int autoinv x + y >= 0, y : int autoinv y >= -(x)) +{ + check x >= 0 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure withAutoinv(x: int autoinv x + y >= 0, y: int autoinv y >= -x) { check x >= 0 } #end + +-- Procedure with body containing multiple statements +/-- +info: B3: .program + () + u #[.procedure + () + u "multi" + u #[.pParameter + () + (.paramModeIn ()) + u "x" + u "int" + u none, + .pParameter + () + (.paramModeOut ()) + u "y" + u "int" + u none] + u #[] + u some (.blockStmt + () + u #[.varDecl + () + u "temp" + u some u "int" + u none + u none, + .assign + () + u 0 + (.binaryOp + () + (.add ()) + (.id () u 2) + (.literal + () + (.intLit () u 1))), + .assign + () + u 1 + (.binaryOp + () + (.mul ()) + (.id () u 0) + (.literal + () + (.intLit () u 2)))])] +--- +info: +procedure multi(x : int, out y : int) +{ + var temp : int + temp := x + 1 + y := temp * 2 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; procedure multi(x: int, out y: int) { var temp : int temp := x + 1 y := temp * 2 } #end + +-- Multiple declarations in a program +/-- +info: B3: .program + () + u #[.typeDecl () u "T", + .axiom + () + u #[] + (.literal () (.boolLit () u true)), + .function + () + u "f" + u #[.fParameter + () + u false + u "x" + u "int"] + u "int" + u none + u some (.functionBody + () + u #[] + (.id () u 0))] +--- +info: +type T +axiom true +function f(x : int) : int { + x +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; type T axiom true function f(x: int) : int { x } #end + +end DeclarationRoundtripTests + +end B3 diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean new file mode 100644 index 000000000..6bd6ff783 --- /dev/null +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -0,0 +1,505 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import StrataTest.Languages.B3.DDMFormatTests +import Strata.Languages.B3.DDMConversion + +namespace B3 + +open Std (Format) +open Strata +open Strata.B3CST + +-- Helper to perform the round-trip transformation and format +-- DDM OperationF → B3 AST → DDM → formatted output +partial def doRoundtrip (e : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := + match B3CST.Expression.ofAst e with + | .ok cstExpr => + let b3Expr := Expression.toAST cstExpr + let b3ExprUnit := b3Expr.toUnit + let reprStr := (repr b3ExprUnit).pretty + let reprStr := cleanupExprRepr reprStr + let reprStr := cleanupUnitRepr reprStr + dbg_trace f!"B3: {reprStr}" + let cstExpr' := Expression.toCST b3Expr + let cstAst := cstExpr'.toAst + cformat (ArgF.op cstAst) ctx state + | .error msg => s!"Parse error: {msg}" + +-- Helper to extract expression from a program and apply round-trip transformation +def roundtripExpr (p : Program) : Format := + let ctx := p.formatContext {} + let state := p.formatState + match p.commands.toList with + | [op] => + if op.name.name == "command_stmt" then + match op.args.toList with + | [ArgF.op stmt] => + if stmt.name.name == "check" then + match stmt.args.toList with + | [ArgF.op e] => doRoundtrip e ctx state + | _ => s!"Error: expected op in check, got {repr stmt.args.toList}" + else s!"Error: expected check statement, got {stmt.name.name}" + | _ => "Error: expected statement op" + else if op.name.name == "command_decl" then + match op.args.toList with + | [ArgF.op decl] => + if decl.name.name == "axiom_decl" then + match decl.args.toList with + | [ArgF.op body] => + if body.name.name == "axiom" then + match body.args.toList with + | [ArgF.op e] => doRoundtrip e ctx state + | _ => s!"Error: expected op in axiom body, got {repr body.args.toList}" + else if body.name.name == "explain_axiom" then + match body.args.toList with + | [_, ArgF.op e] => doRoundtrip e ctx state + | _ => s!"Error: expected names and op in explain_axiom, got {repr body.args.toList}" + else s!"Error: expected axiom or explain_axiom body, got {body.name.name}" + | _ => s!"Error: expected AxiomBody in axiom_decl, got {repr decl.args.toList}" + else s!"Error: expected axiom declaration, got {decl.name.name}" + | _ => "Error: expected axiom op" + else + s!"Error: expected command_stmt or command_decl, got {op.name.name}" + | _ => "Error: expected single command" + +section ExpressionRoundtripTests + +-- We are loosing the context so this is why it's printing that way. +/-- +info: B3: .id () u 0 +--- +info: @0 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check x #end + +/-- +info: B3: .binaryOp + () + (.add ()) + (.literal () (.intLit () u 5)) + (.literal () (.intLit () u 3)) +--- +info: 5 + 3 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 5 + 3 #end + +/-- +info: B3: .literal () (.boolLit () u true) +--- +info: true +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check true #end + +/-- +info: B3: .literal () (.boolLit () u false) +--- +info: false +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check false #end + +/-- +info: B3: .unaryOp + () + (.not ()) + (.literal () (.boolLit () u true)) +--- +info: !true +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check !true #end + +/-- +info: B3: .binaryOp + () + (.sub ()) + (.literal () (.intLit () u 10)) + (.literal () (.intLit () u 3)) +--- +info: 10 - 3 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 10 - 3 #end + +/-- +info: B3: .binaryOp + () + (.mul ()) + (.literal () (.intLit () u 4)) + (.literal () (.intLit () u 5)) +--- +info: 4 * 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 4 * 5 #end + +/-- +info: B3: .binaryOp + () + (.div ()) + (.literal () (.intLit () u 20)) + (.literal () (.intLit () u 4)) +--- +info: 20 div 4 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 20 div 4 #end + +/-- +info: B3: .binaryOp + () + (.mod ()) + (.literal () (.intLit () u 17)) + (.literal () (.intLit () u 5)) +--- +info: 17 mod 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 17 mod 5 #end + +/-- +info: B3: .binaryOp + () + (.eq ()) + (.literal () (.intLit () u 5)) + (.literal () (.intLit () u 5)) +--- +info: 5 == 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 5 == 5 #end + +/-- +info: B3: .binaryOp + () + (.neq ()) + (.literal () (.intLit () u 3)) + (.literal () (.intLit () u 7)) +--- +info: 3 != 7 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 3 != 7 #end + +/-- +info: B3: .binaryOp + () + (.le ()) + (.literal () (.intLit () u 3)) + (.literal () (.intLit () u 5)) +--- +info: 3 <= 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 3 <= 5 #end + +/-- +info: B3: .binaryOp + () + (.lt ()) + (.literal () (.intLit () u 2)) + (.literal () (.intLit () u 8)) +--- +info: 2 < 8 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 2 < 8 #end + +/-- +info: B3: .binaryOp + () + (.ge ()) + (.literal () (.intLit () u 10)) + (.literal () (.intLit () u 5)) +--- +info: 10 >= 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 10 >= 5 #end + +/-- +info: B3: .binaryOp + () + (.gt ()) + (.literal () (.intLit () u 15)) + (.literal () (.intLit () u 3)) +--- +info: 15 > 3 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 15 > 3 #end + +/-- +info: B3: .binaryOp + () + (.add ()) + (.literal () (.intLit () u 2)) + (.binaryOp + () + (.mul ()) + (.literal () (.intLit () u 3)) + (.literal () (.intLit () u 4))) +--- +info: 2 + 3 * 4 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 2 + 3 * 4 #end + +/-- +info: B3: .binaryOp + () + (.mul ()) + (.binaryOp + () + (.add ()) + (.literal () (.intLit () u 2)) + (.literal () (.intLit () u 3))) + (.literal () (.intLit () u 4)) +--- +info: (2 + 3) * 4 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check (2 + 3) * 4 #end + +/-- +info: B3: .binaryOp + () + (.add ()) + (.binaryOp + () + (.add ()) + (.literal () (.intLit () u 1)) + (.literal () (.intLit () u 2))) + (.literal () (.intLit () u 3)) +--- +info: 1 + 2 + 3 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 1 + 2 + 3 #end + +/-- +info: B3: .binaryOp + () + (.lt ()) + (.binaryOp + () + (.add ()) + (.literal () (.intLit () u 1)) + (.literal () (.intLit () u 2))) + (.literal () (.intLit () u 5)) +--- +info: 1 + 2 < 5 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 1 + 2 < 5 #end + +/-- +info: B3: .binaryOp + () + (.add ()) + (.binaryOp + () + (.sub ()) + (.literal () (.intLit () u 10)) + (.literal () (.intLit () u 3))) + (.literal () (.intLit () u 2)) +--- +info: 10 - 3 + 2 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 10 - 3 + 2 #end + +/-- +info: B3: .binaryOp + () + (.mul ()) + (.binaryOp + () + (.div ()) + (.literal () (.intLit () u 20)) + (.literal () (.intLit () u 4))) + (.literal () (.intLit () u 3)) +--- +info: 20 div 4 * 3 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 20 div 4 * 3 #end + +/-- +info: B3: .binaryOp + () + (.lt ()) + (.literal () (.intLit () u 1)) + (.binaryOp + () + (.add ()) + (.binaryOp + () + (.mul ()) + (.literal () (.intLit () u 2)) + (.literal () (.intLit () u 3))) + (.literal () (.intLit () u 4))) +--- +info: 1 < 2 * 3 + 4 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check 1 < 2 * 3 + 4 #end + +/-- +info: B3: .ite + () + (.literal () (.boolLit () u true)) + (.literal () (.intLit () u 1)) + (.literal () (.intLit () u 0)) +--- +info: if true then 1 else 0 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check if true then 1 else 0 #end + +/-- +info: B3: .quantifierExpr + () + (.forall ()) + u "i" + u "int" + u #[] + (.binaryOp + () + (.ge ()) + (.id () u 0) + (.literal () (.intLit () u 0))) +--- +info: forall i : int i >= 0 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check forall i : int i >= 0 #end + +/-- +info: B3: .quantifierExpr + () + (.exists ()) + u "y" + u "bool" + u #[] + (.binaryOp + () + (.or ()) + (.id () u 0) + (.unaryOp + () + (.not ()) + (.id () u 0))) +--- +info: exists y : bool y || !y +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check exists y : bool y || !y #end + +/-- +info: B3: .quantifierExpr + () + (.forall ()) + u "x" + u "int" + u #[.pattern + () + u #[.functionCall + () + u "f" + u #[.id () u 0], + .functionCall + () + u "f" + u #[.id () u 0]]] + (.binaryOp + () + (.gt ()) + (.functionCall + () + u "f" + u #[.id () u 0]) + (.literal () (.intLit () u 0))) +--- +info: forall x : int pattern f(x), f(x) f(x) > 0 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check forall x : int pattern f(x), f(x) f(x) > 0 #end + +/-- +info: B3: .quantifierExpr + () + (.exists ()) + u "y" + u "bool" + u #[.pattern + () + u #[.unaryOp + () + (.not ()) + (.id () u 0)], + .pattern + () + u #[.id () u 0]] + (.binaryOp + () + (.or ()) + (.id () u 0) + (.unaryOp + () + (.not ()) + (.id () u 0))) +--- +info: exists y : bool pattern y pattern !y y || !y +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check exists y : bool pattern y pattern !y y || !y #end + +/-- +info: B3: .quantifierExpr + () + (.forall ()) + u "z" + u "int" + u #[.pattern + () + u #[.binaryOp + () + (.mul ()) + (.id () u 0) + (.literal + () + (.intLit () u 2))], + .pattern + () + u #[.binaryOp + () + (.add ()) + (.id () u 0) + (.literal + () + (.intLit () u 1))], + .pattern + () + u #[.id () u 0]] + (.binaryOp + () + (.gt ()) + (.id () u 0) + (.literal () (.intLit () u 0))) +--- +info: forall z : int pattern z pattern z + 1 pattern z * 2 z > 0 +-/ +#guard_msgs in +#eval roundtripExpr $ #strata program B3CST; check forall z : int pattern z pattern z + 1 pattern z * 2 z > 0 #end + +end ExpressionRoundtripTests + +end B3 diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean new file mode 100644 index 000000000..d1652017c --- /dev/null +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -0,0 +1,364 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import StrataTest.Languages.B3.DDMFormatDeclarationsTests +import Strata.Languages.B3.DDMConversion + +namespace B3 + +open Std (Format) +open Strata +open Strata.B3CST + +def roundtripProgram (p : Program) : Format := + let ctx := p.formatContext {} + let state := p.formatState + match p.commands.toList with + | [op] => + if op.name.name == "command_program" then + match op.args.toList with + | [ArgF.op prog] => doRoundtripProgram prog ctx state false + | _ => "Error: expected program op" + else s!"Error: expected command_program, got {op.name.name}" + | _ => "Error: expected single command" + +section ProgramRoundtripTests + +-- Type declaration +/-- +info: +--- +info: +procedure Good(out result : XResult) +{ + var cresult : CResult + CreateClient(@2, out cresult) + if !CIsSuccess(cresult) ⏎ + { + result := XFailure(CFailureTODODotDotmsg(cresult)) + return + } + var fileSystem := CSuccessTODODotDotvalue(cresult) + var aresult : AResult + ListBuckets(fileSystem, out aresult) + if !AIsSuccess(aresult) ⏎ + { + result := XFailure(AFailureTODODotDotmsg(aresult)) + return + } + var aresponse := ASuccessTODODotDotvalue(aresult) + var buckets := AResponseTODODotDotbuckets(aresponse) + var i := 0 + loop + invariant 0 <= i && i <= length(buckets) ⏎ + { + if i == length(buckets) ⏎ + { + exit ⏎ + } + check 0 <= i && i < length(buckets) + var bucket := select(buckets, i) + var bucketName := BucketTODODotDotname(bucket) + var bresult : BResult + GetPublicAccessBlock(fileSystem, bucketName, out bresult) + if !BIsSuccess(bresult) ⏎ + { + result := XFailure(BFailureTODODotDotmsg(bresult)) + return + } + var bresponse := BSuccessTODODotDotvalue(bresult) + var isBlocked := GetAttributeValue(BResponseTODODotDotgetConfig(bresponse), @12) + if isBlocked ⏎ + { + Print(@12, bucketName, @12) + } + else ⏎ + { + Print(@12, bucketName, @12) + } + i := i + 1 + } + var x : X + result := XSuccess(x) +} +procedure CreateClient(name : string, out result : CResult) +function UserOwnsBucket(name : string) : bool +type Client +procedure ListBuckets(c : Client, out aresult : AResult) + ensures AIsSuccess(aresult) ==> (forall bucket : Bucket pattern BucketTODODotDotname(bucket) pattern in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) ==> UserOwnsBucket(BucketTODODotDotname(bucket))) +procedure GetPublicAccessBlock(c : Client, Bucket : string, out result : BResult) + requires UserOwnsBucket(Bucket) +type AResponse +function AResponse(injective buckets : BucketSeq) : AResponse +type BResponse +function BResponse(injective getConfig : BlockConfig) : BResponse +type Bucket +function Bucket(injective name : string) : Bucket +type BlockConfig +function GetAttributeValue(config : BlockConfig, attribute : string) : bool +type X +type XResult +tagger XResultTag for XResult +function XSuccess(injective value : X) : XResult tag XResultTag +function XFailure(injective msg : string) : XResult tag XResultTag +function XIsSuccess(r : XResult) : bool { + XResultTag(r) == XSuccessTODODotDottag() +} +type CResult +tagger CResultTag for CResult +function CSuccess(injective value : Client) : CResult tag CResultTag +function CFailure(injective msg : string) : CResult tag CResultTag +function CIsSuccess(r : CResult) : bool { + CResultTag(r) == CSuccessTODODotDottag() +} +type AResult +tagger AResultTag for AResult +function ASuccess(injective value : AResponse) : AResult tag AResultTag +function AFailure(injective msg : string) : AResult tag AResultTag +function AIsSuccess(r : AResult) : bool { + AResultTag(r) == ASuccessTODODotDottag() +} +type BResult +tagger BResultTag for BResult +function BSuccess(injective value : BResponse) : BResult tag BResultTag +function BFailure(injective msg : string) : BResult tag BResultTag +function BIsSuccess(r : BResult) : bool { + BResultTag(r) == BSuccessTODODotDottag() +} +type BucketSeq +function select(s : BucketSeq, i : int) : Bucket +function length(s : BucketSeq) : int +axiom explains length + forall s : BucketSeq pattern length(s) 0 <= length(s) +function in(b : Bucket, s : BucketSeq) : bool { + exists i : int pattern select(s, i) 0 <= i && i < length(s) && select(s, i) == b +} +type string +procedure Print(a : string, b : string, c : string) +-/ +#guard_msgs in +#eval roundtripProgram $ #strata program B3CST; +// This example program shows many B3 features in use. The main point is to prove +// that GetPublicAccessBlock is called with a bucket name that satisfies UserOwnsBucket. +// This properties is guaranteed by the postcondition of ListBuckets, which, upon +// success, returns a sequence where every bucket name satisfies GetPublicAccessBlock. +// +// Here is the program shown in the syntax of a Dafny-like programming-language: +// +// var fileSystem :- CreateClient("myFileSystemName") +// var aresponse :- fileSystem.ListBuckets() +// var buckets := aresponse.buckets +// for i := 0 to |buckets| { +// var bucket := buckets[i] +// var bucketName := bucket.name +// var bresponse :- fileSystem.GetPublicAccessBlock(bucketName) +// var isBlocked := bresponse.getConfig.GetAttributeValue("BlockPublicAcls") +// if isBlocked { +// print "bucket", bucketName, "is blocked" +// } else { +// print "bucket", bucketName, "is not blocked" +// } +// } +// +// Note that B3 identifiers may contain "." characters. B3 uses "TODODotDot" as part of the +// name when it generates functions (for example, the function names generated as a result +// of declaring a parameter to be "injective"). + +procedure Good(out result: XResult) { + var cresult: CResult + CreateClient(TODOVerticalBarIdentifiers, out cresult) + if !CIsSuccess(cresult) { + result := XFailure(CFailureTODODotDotmsg(cresult)) + return + } + var fileSystem := CSuccessTODODotDotvalue(cresult) + + var aresult: AResult + ListBuckets(fileSystem, out aresult) + if !AIsSuccess(aresult) { + result := XFailure(AFailureTODODotDotmsg(aresult)) + return + } + var aresponse := ASuccessTODODotDotvalue(aresult) + + var buckets := AResponseTODODotDotbuckets(aresponse) + + var i := 0 + loop + invariant 0 <= i && i <= length(buckets) + { + if i == length(buckets) { + exit + } + + check 0 <= i && i < length(buckets) + var bucket := select(buckets, i) + + var bucketName := BucketTODODotDotname(bucket) + + var bresult: BResult + GetPublicAccessBlock(fileSystem, bucketName, out bresult) + if !BIsSuccess(bresult) { + result := XFailure(BFailureTODODotDotmsg(bresult)) + return + } + var bresponse := BSuccessTODODotDotvalue(bresult) + + var isBlocked := GetAttributeValue(BResponseTODODotDotgetConfig(bresponse), TODOBarIdentifierBlockPublicAcls) + + if isBlocked { + Print(TODOBarIdentifierbucket, bucketName, TODOBarIdentifier) + } else { + Print(TODOBarIdentifierbucket, bucketName, TODOBarIdentifierIsNotBlocked) + } + + i := i + 1 + } + + var x: X + result := XSuccess(x) +} + +// -------------------------------------------------------------------- + +// The file-system API is the following: + +procedure CreateClient(name: string, out result: CResult) + +// This predicate says whether or not the given bucket name is owned by the user. +// It is used in the postcondition of ListBuckets and in the precondition of +// GetPublicAccessBlock. +function UserOwnsBucket(name: string): bool + +type Client + +procedure ListBuckets(c: Client, out aresult: AResult) + ensures AIsSuccess(aresult) ==> + forall bucket: Bucket + pattern BucketTODODotDotname(bucket) + pattern in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) + in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) ==> + UserOwnsBucket(BucketTODODotDotname(bucket)) + +procedure GetPublicAccessBlock(c: Client, Bucket: string, out result: BResult) + requires UserOwnsBucket(Bucket) + +// -------------------------------------------------------------------- + +// The example program uses an API model where each API entry point returns a "response". +// This is typical in many code bases, for example in Java, because it allows the API +// to evolve to add more attributes of the response in the future. What that means for +// the example program is that there are different response types. Here, those are modeled +// as records with one just field. + +// datatype AResponse = AResponse(buckets: BucketSeq) +type AResponse +function AResponse(injective buckets: BucketSeq): AResponse + +// datatype BResponse = BResponse(getConfig: BlockConfig) +type BResponse +function BResponse(injective getConfig: BlockConfig): BResponse + +// -------------------------------------------------------------------- + +// For the purpose of the example, a bucket is something that has a name. In a full API, +// buckets would also have some data, of course. + +// datatype Bucket = Bucket(name: string) +type Bucket +function Bucket(injective name: string): Bucket + +// -------------------------------------------------------------------- + +// In the example, a block configuration is a set of named attributes, each of which can +// be false or true. + +type BlockConfig + +function GetAttributeValue(config: BlockConfig, attribute: string): bool + +// -------------------------------------------------------------------- + +// The example program is written in the style of Rust, Go, and Dafny, where a failure +// is reported as a special return value that have to be tested by the caller. In Go, +// such querying and propagation of failures is done manually, whereas Rust has the +// "?" operator and Dafny has the ":-" operator for doing this. Such code is translated +// into B3 by doing the checking explicitly. +// +// Using datatypes with type parameters, such Result types can be defined as +// +// datatype Result = Success(value: X) | Failure(msg: string) +// +// Since B3 does not support polymorphism, there is one Result type for each success +// type. + +type X +type XResult // Result<()> +tagger XResultTag for XResult +function XSuccess(injective value: X): XResult tag XResultTag +function XFailure(injective msg: string): XResult tag XResultTag +function XIsSuccess(r: XResult): bool { + XResultTag(r) == XSuccessTODODotDottag() +} + +type CResult // Result +tagger CResultTag for CResult +function CSuccess(injective value: Client): CResult tag CResultTag +function CFailure(injective msg: string): CResult tag CResultTag +function CIsSuccess(r: CResult): bool { + CResultTag(r) == CSuccessTODODotDottag() +} + +type AResult // Result +tagger AResultTag for AResult +function ASuccess(injective value: AResponse): AResult tag AResultTag +function AFailure(injective msg: string): AResult tag AResultTag +function AIsSuccess(r: AResult): bool { + AResultTag(r) == ASuccessTODODotDottag() +} + +type BResult // Result +tagger BResultTag for BResult +function BSuccess(injective value: BResponse): BResult tag BResultTag +function BFailure(injective msg: string): BResult tag BResultTag +function BIsSuccess(r: BResult): bool { + BResultTag(r) == BSuccessTODODotDottag() +} + +// -------------------------------------------------------------------- + +// Finally, we have a type BucketSeq that models a sequence of buckets +// and a(n uninterpreted) string type whose values can be printed. +// +// In a source programming language, the "select" operation on a sequence +// has a precondition that the given index is in range. The example B3 code +// above uses a "check" statement to enforce that precondition. + +type BucketSeq + +function select(s: BucketSeq, i: int): Bucket + +function length(s: BucketSeq): int + +axiom explains length + forall s: BucketSeq + pattern length(s) + 0 <= length(s) + +function in(b: Bucket, s: BucketSeq): bool { + exists i: int + pattern select(s, i) + 0 <= i && i < length(s) && select(s, i) == b +} + +type string + +procedure Print(a: string, b: string, c: string) +#end + +end ProgramRoundtripTests + +end B3 diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean new file mode 100644 index 000000000..10e97f9d0 --- /dev/null +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -0,0 +1,633 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import StrataTest.Languages.B3.DDMFormatTests +import Strata.Languages.B3.DDMConversion + +namespace B3 + +open Std (Format) +open Strata +open Strata.B3CST + +-- Helper to perform the round-trip transformation for statements +-- DDM OperationF → B3 Stmt → DDM → formatted output +partial def doRoundtripStmt (stmt : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := + match B3CST.Statement.ofAst stmt with + | .ok cstStmt => + let b3Stmt := Stmt.toAST cstStmt + let b3StmtUnit := b3Stmt.toUnit + let reprStr := (repr b3StmtUnit).pretty + let reprStr := cleanupStmtRepr reprStr + let reprStr := cleanupUnitRepr reprStr + dbg_trace f!"B3: {reprStr}" + let cstStmt' := Stmt.toCST b3Stmt + let cstAst := cstStmt'.toAst + cformat (ArgF.op cstAst) ctx state + | .error msg => s!"Parse error: {msg}" + +-- Helper to extract statement from a program and apply round-trip transformation +def roundtripStmt (p : Program) : Format := + let ctx := p.formatContext {} + let state := p.formatState + match p.commands.toList with + | [op] => + if op.name.name == "command_stmt" then + match op.args.toList with + | [ArgF.op stmt] => doRoundtripStmt stmt ctx state + | _ => "Error: expected statement op" + else s!"Error: expected command_stmt, got {op.name.name}" + | _ => "Error: expected single command" + +section StatementRoundtripTests + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .assign + () + u 0 + (.literal () (.intLit () u 42))] +--- +info: +{ + var x : int + x := 42 +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; {var x: int x := 42} #end + +/-- +info: B3: .check + () + (.binaryOp + () + (.gt ()) + (.literal () (.intLit () u 5)) + (.literal () (.intLit () u 0))) +--- +info: +check 5 > 0 +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; check 5 > 0 #end + +/-- +info: B3: .assume + () + (.binaryOp + () + (.ge ()) + (.literal () (.intLit () u 10)) + (.literal () (.intLit () u 0))) +--- +info: +assume 10 >= 0 +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; assume 10 >= 0 #end + +/-- +info: B3: .assert + () + (.binaryOp + () + (.gt ()) + (.literal () (.intLit () u 5)) + (.literal () (.intLit () u 0))) +--- +info: +assert 5 > 0 +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; assert 5 > 0 #end + +/-- +info: B3: .reach + () + (.binaryOp + () + (.eq ()) + (.literal () (.intLit () u 5)) + (.literal () (.intLit () u 5))) +--- +info: +reach 5 == 5 +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; reach 5 == 5 #end + +/-- +info: B3: .returnStmt () +--- +info: +return +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; return #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .varDecl + () + u "y" + u some u "int" + u none + u none, + .blockStmt + () + u #[.assign + () + u 1 + (.literal + () + (.intLit () u 1)), + .assign + () + u 0 + (.literal + () + (.intLit () u 2))]] +--- +info: +{ + var x : int + var y : int + { + x := 1 + y := 2 + } +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var x: int var y: int { x := 1 y := 2 } } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "flag" + u some u "bool" + u none + u none, + .varDecl + () + u "x" + u some u "int" + u none + u none, + .ifStmt + () + (.id () u 1) + (.assign + () + u 0 + (.literal () (.intLit () u 1))) + u some (.blockStmt + () + u #[.assign + () + u 0 + (.literal + () + (.intLit () u 0))])] +--- +info: +{ + var flag : bool + var x : int + if flag ⏎ + x := 1 + else ⏎ + { + x := 0 + } +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST;{ var flag: bool var x: int if flag x := 1 else { x := 0 } } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "i" + u some u "int" + u none + u none, + .loop + () + u #[] + (.blockStmt + () + u #[.assign + () + u 0 + (.binaryOp + () + (.add ()) + (.id () u 0) + (.literal + () + (.intLit () u 1)))])] +--- +info: +{ + var i : int + loop ⏎ + { + i := i + 1 + } +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var i: int loop { i := i + 1 } } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "i" + u some u "int" + u none + u none, + .varDecl + () + u "n" + u some u "int" + u none + u none, + .loop + () + u #[.binaryOp + () + (.ge ()) + (.id () u 1) + (.literal + () + (.intLit () u 0)), + .binaryOp + () + (.le ()) + (.id () u 1) + (.id () u 0)] + (.blockStmt + () + u #[.assign + () + u 1 + (.binaryOp + () + (.add ()) + (.id () u 1) + (.literal + () + (.intLit () u 1)))])] +--- +info: +{ + var i : int + var n : int + loop + invariant i >= 0 + invariant i <= n ⏎ + { + i := i + 1 + } +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var i: int var n: int loop invariant i >= 0 invariant i <= n { i := i + 1 } } #end + +/-- +info: B3: .exit () u some u "loop_start" +--- +info: +exit loop_start +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; exit loop_start #end + +/-- +info: B3: .labeledStmt + () + u "labeled_block" + (.blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .assign + () + u 0 + (.literal () (.intLit () u 0))]) +--- +info: labeled_block: ⏎ +{ + var x : int + x := 0 +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; labeled_block: {var x: int x := 0} #end + +/-- +info: B3: .probe () u "debug_point" +--- +info: +probe debug_point +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; probe debug_point #end + +/-- +info: B3: .varDecl + () + u "x" + u some u "int" + u none + u none +--- +info: +var x : int +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; var x : int #end + +/-- +info: B3: .varDecl + () + u "x" + u some u "bool" + u none + u some (.literal () (.boolLit () u true)) +--- +info: +var x : bool := true +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; val x : bool := true #end + +/-- +info: B3: .varDecl + () + u "y" + u some u "bool" + u none + u some (.literal () (.boolLit () u true)) +--- +info: +var y : bool := true +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; var y : bool := true #end + +/-- +info: B3: .varDecl + () + u "z" + u some u "int" + u some (.binaryOp + () + (.ge ()) + (.id () u 0) + (.literal () (.intLit () u 0))) + u none +--- +info: +var z : int autoinv @0 >= 0 +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; var z : int autoinv z >= 0 #end + +/-- +info: B3: .aForall + () + u "x" + u "int" + (.blockStmt + () + u #[.check + () + (.binaryOp + () + (.ge ()) + (.id () u 0) + (.literal () (.intLit () u 0)))]) +--- +info: +forall x : int ⏎ +{ + check x >= 0 +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; forall x : int { check x >= 0 } #end + +/-- +info: B3: .choose + () + u #[.blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .assign + () + u 0 + (.literal + () + (.intLit () u 2))], + .blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .assign + () + u 0 + (.literal + () + (.intLit () u 1))]] +--- +info: +choose ⏎ +{ + var x : int + x := 1 +} or ⏎ +{ + var x : int + x := 2 +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; choose { var x: int x := 1 } or { var x: int x := 2 } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .varDecl + () + u "y" + u some u "int" + u none + u none, + .ifCase + () + u #[.oneIfCase + () + (.binaryOp + () + (.eq ()) + (.id () u 1) + (.literal + () + (.intLit () u 1))) + (.blockStmt + () + u #[.assign + () + u 0 + (.literal + () + (.intLit () u 10))]), + .oneIfCase + () + (.binaryOp + () + (.eq ()) + (.id () u 1) + (.literal + () + (.intLit () u 2))) + (.blockStmt + () + u #[.assign + () + u 0 + (.literal + () + (.intLit () u 20))])]] +--- +info: +{ + var x : int + var y : int + if + case x == 1 ⏎ + { + y := 10 + } + case x == 2 ⏎ + { + y := 20 + } +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var x: int var y: int if case x == 1 { y := 10 } case x == 2 { y := 20 } } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "a" + u some u "int" + u none + u none, + .varDecl + () + u "b" + u some u "int" + u none + u none, + .call + () + u "compute" + u #[.callArgOut () u "result", + .callArgExpr () (.id () u 1), + .callArgExpr + () + (.id () u 0)]] +--- +info: +{ + var a : int + var b : int + compute(out result, a, b) +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var a: int var b: int compute(out result, a, b) } #end + +/-- +info: B3: .blockStmt + () + u #[.varDecl + () + u "x" + u some u "int" + u none + u none, + .varDecl + () + u "y" + u some u "int" + u none + u none, + .call + () + u "modify" + u #[.callArgInout () u "x", + .callArgOut () u "y"]] +--- +info: +{ + var x : int + var y : int + modify(inout x, out y) +} +-/ +#guard_msgs in +#eval roundtripStmt $ #strata program B3CST; { var x: int var y: int modify(inout x, out y) } #end + +end StatementRoundtripTests + +end B3 diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean new file mode 100644 index 000000000..3633b0c49 --- /dev/null +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -0,0 +1,269 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.ParseCST +import Strata.Languages.B3.DDMTransform.DefinitionAST +import Strata.Languages.B3.DDMConversion + +namespace B3 + +open Std (Format) +open Strata +open Strata.B3CST + +/-- +info: inductive Strata.B3CST.Expression : Type → Type +number of parameters: 1 +constructors: +Strata.B3CST.Expression.not : {α : Type} → α → Expression α → Expression α +Strata.B3CST.Expression.natLit : {α : Type} → α → Ann Nat α → Expression α +Strata.B3CST.Expression.strLit : {α : Type} → α → Ann String α → Expression α +Strata.B3CST.Expression.btrue : {α : Type} → α → Expression α +Strata.B3CST.Expression.bfalse : {α : Type} → α → Expression α +Strata.B3CST.Expression.old_id : {α : Type} → α → Ann String α → Expression α +Strata.B3CST.Expression.id : {α : Type} → α → Ann String α → Expression α +Strata.B3CST.Expression.letExpr : {α : Type} → α → Ann String α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.labeledExpr : {α : Type} → α → Ann String α → Expression α → Expression α +Strata.B3CST.Expression.ite : {α : Type} → α → Expression α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.iff : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.implies : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.impliedBy : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.and : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.or : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.equal : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.not_equal : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.le : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.lt : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.ge : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.gt : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.neg : {α : Type} → α → Expression α → Expression α +Strata.B3CST.Expression.add : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.sub : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.mul : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.div : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.mod : {α : Type} → α → Expression α → Expression α → Expression α +Strata.B3CST.Expression.paren : {α : Type} → α → Expression α → Expression α +Strata.B3CST.Expression.functionCall : {α : Type} → α → Ann String α → Ann (Array (Expression α)) α → Expression α +Strata.B3CST.Expression.forall_expr_no_patterns : {α : Type} → + α → Ann String α → Ann String α → Expression α → Expression α +Strata.B3CST.Expression.forall_expr : {α : Type} → + α → Ann String α → Ann String α → Patterns α → Expression α → Expression α +Strata.B3CST.Expression.exists_expr_no_patterns : {α : Type} → + α → Ann String α → Ann String α → Expression α → Expression α +Strata.B3CST.Expression.exists_expr : {α : Type} → + α → Ann String α → Ann String α → Patterns α → Expression α → Expression α +-/ +#guard_msgs in +#print B3CST.Expression + +/-- +info: inductive Strata.B3AST.Expression : Type → Type +number of parameters: 1 +constructors: +Strata.B3AST.Expression.literal : {α : Type} → α → B3AST.Literal α → B3AST.Expression α +Strata.B3AST.Expression.id : {α : Type} → α → Ann Nat α → B3AST.Expression α +Strata.B3AST.Expression.ite : {α : Type} → + α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α +Strata.B3AST.Expression.binaryOp : {α : Type} → + α → B3AST.BinaryOp α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α +Strata.B3AST.Expression.unaryOp : {α : Type} → α → B3AST.UnaryOp α → B3AST.Expression α → B3AST.Expression α +Strata.B3AST.Expression.functionCall : {α : Type} → + α → Ann String α → Ann (Array (B3AST.Expression α)) α → B3AST.Expression α +Strata.B3AST.Expression.labeledExpr : {α : Type} → α → Ann String α → B3AST.Expression α → B3AST.Expression α +Strata.B3AST.Expression.letExpr : {α : Type} → + α → Ann String α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α +Strata.B3AST.Expression.quantifierExpr : {α : Type} → + α → + B3AST.QuantifierKind α → + Ann String α → Ann String α → Ann (Array (B3AST.Pattern α)) α → B3AST.Expression α → B3AST.Expression α +-/ +#guard_msgs in +#print B3AST.Expression + +/-- +info: inductive Strata.B3CST.Pattern : Type → Type +number of parameters: 1 +constructors: +Strata.B3CST.Pattern.pattern : {α : Type} → α → Ann (Array (Expression α)) α → Pattern α +-/ +#guard_msgs in +#print B3CST.Pattern + +/-- +info: inductive Strata.B3CST.Patterns : Type → Type +number of parameters: 1 +constructors: +Strata.B3CST.Patterns.patterns_cons : {α : Type} → α → Pattern α → Patterns α → Patterns α +Strata.B3CST.Patterns.patterns_single : {α : Type} → α → Pattern α → Patterns α +-/ +#guard_msgs in +#print B3CST.Patterns + +-- Helpers to convert Unit annotations to SourceRange +mutual + partial def exprFUnitToSourceRange : ExprF Unit → ExprF SourceRange + | .bvar () idx => .bvar default idx + | .fvar () idx => .fvar default idx + | .fn () f => .fn default f + | .app () f a => .app default (exprFUnitToSourceRange f) (argFUnitToSourceRange a) + + partial def argFUnitToSourceRange : ArgF Unit → ArgF SourceRange + | .op op => .op { op with ann := default, args := op.args.map argFUnitToSourceRange } + | .expr e => .expr (exprFUnitToSourceRange e) + | .type t => .type (typeExprFUnitToSourceRange t) + | .cat c => .cat (syntaxCatFUnitToSourceRange c) + | .ident () x => .ident default x + | .num () x => .num default x + | .decimal () v => .decimal default v + | .strlit () s => .strlit default s + | .bytes () v => .bytes default v + | .bool () b => .bool default b + | .option () ma => .option default (ma.map argFUnitToSourceRange) + | .seq () entries => .seq default (entries.map argFUnitToSourceRange) + | .commaSepList () entries => .commaSepList default (entries.map argFUnitToSourceRange) + + partial def typeExprFUnitToSourceRange : TypeExprF Unit → TypeExprF SourceRange + | .ident () tp a => .ident default tp (a.map typeExprFUnitToSourceRange) + | .bvar () idx => .bvar default idx + | .fvar () idx a => .fvar default idx (a.map typeExprFUnitToSourceRange) + | .arrow () a r => .arrow default (typeExprFUnitToSourceRange a) (typeExprFUnitToSourceRange r) + + partial def syntaxCatFUnitToSourceRange : SyntaxCatF Unit → SyntaxCatF SourceRange + | ⟨(), name, args⟩ => ⟨default, name, args.map syntaxCatFUnitToSourceRange⟩ +end + +-- Create a minimal B3 program to get the dialect context +def b3Program : Program := #strata program B3CST; #end + +-- Helper to convert OperationF Unit to OperationF SourceRange +def operationFUnitToSourceRange (op : OperationF Unit) : OperationF SourceRange := + { op with ann := default, args := op.args.map argFUnitToSourceRange } + +/-- +Clean up Unit annotation repr output for better readability. +Step 1: Remove `{ ann := (), val := X }` constructs via brace matching, keeping just u X +Step 2: Reduce excessive indentation (more than 2 spaces difference) to 2 spaces +-/ +partial def cleanupUnitRepr (s : String) : String := + -- Step 1: Remove { ann := (), val := X } constructs + let rec removeAnnStructs (chars : List Char) (acc : String) : String := + match chars with + | [] => acc + | _ => + let pattern := "{ ann := (),".toList + if chars.take pattern.length == pattern then + -- Found "{ ann := (),", now find matching closing brace for the whole structure + let rec findClose (cs : List Char) (depth : Nat) (acc : List Char) : Option (List Char × List Char) := + match cs with + | [] => none + | _ :: [] => none + | c :: d :: rest => + if c == '{' then findClose (d :: rest) (depth + 1) (c :: acc) + else if c == ' ' && d == '}' then + if depth == 0 then some (acc.reverse, rest) + else findClose (d :: rest) (depth - 1) (c :: acc) + else findClose (d :: rest) depth (c :: acc) + match findClose (chars.drop 1) 0 [] with + | none => removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) + | some (innerChars, afterClose) => + -- innerChars contains everything between { and }, like "ann := (),\n val := X" or "ann := (), val := X" + -- Find "val := " and extract everything after it + let valPattern := "val := ".toList + let rec findValStart (cs : List Char) : Option (List Char) := + match cs with + | [] => none + | _ => + if cs.take valPattern.length == valPattern then + some (cs.drop valPattern.length) + else + match cs with + | [] => none + | _ :: rest => findValStart rest + match findValStart innerChars with + | none => removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) + | some valueOnly => removeAnnStructs afterClose (acc ++ "u " ++ String.mk valueOnly) + else + removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) + + -- Apply removal 10 times to handle nested structures up to depth 10 + let rec applyNTimes (n : Nat) (str : String) : String := + if n == 0 then str + else applyNTimes (n - 1) (removeAnnStructs str.toList "") + + let step1 := applyNTimes 10 s + + -- Step 2: Remove trailing spaces and normalize indentation using a stack + let lines := step1.splitOn "\n" + let rec processLines (lines : List String) (indentStack : List Nat) (acc : List String) : List String := + match lines with + | [] => acc.reverse + | line :: rest => + -- Remove trailing spaces + let line := line.dropRightWhile (· == ' ') + let indent := line.takeWhile (· == ' ') |>.length + let content := line.dropWhile (· == ' ') + if content.isEmpty then + processLines rest indentStack ("" :: acc) + else + -- Update indent stack based on current indent + let newStack := + match indentStack with + | [] => [indent] + | prevIndent :: _ => + if indent > prevIndent then + -- Deeper nesting - push current indent + indent :: indentStack + else if indent == prevIndent then + -- Same level - keep stack + indentStack + else + -- Dedent - pop stack until we find matching or smaller indent + let rec popUntil (stack : List Nat) : List Nat := + match stack with + | [] => [indent] + | h :: t => + if h <= indent then stack + else popUntil t + popUntil indentStack + -- New indent is (stack depth - 1) * 2 + let newIndent := (newStack.length - 1) * 2 + let newLine := String.mk (List.replicate newIndent ' ') ++ content + processLines rest newStack (newLine :: acc) + + String.intercalate "\n" (processLines lines [] []) + +/-- Remove Strata.B3AST namespace prefixes for expression types -/ +def cleanupExprRepr (s : String) : String := + let s := s.replace "Strata.B3AST.Expression." "." + let s := s.replace "Strata.B3AST.QuantifierKind." "." + let s := s.replace "Strata.B3AST.Literal." "." + let s := s.replace "Strata.B3AST.UnaryOp." "." + let s := s.replace "Strata.B3AST.BinaryOp." "." + let s := s.replace "Strata.B3AST.Pattern." "." + s + +/-- Remove Strata.B3AST namespace prefixes for statement types -/ +def cleanupStmtRepr (s : String) : String := + let s := cleanupExprRepr s + let s := s.replace "Strata.B3AST.Statement." "." + let s := s.replace "Strata.B3AST.CallArg." "." + let s := s.replace "Strata.B3AST.OneIfCase." "." + s + +/-- Remove Strata.B3AST namespace prefixes for declaration types -/ +def cleanupDeclRepr (s : String) : String := + let s := cleanupStmtRepr s + let s := s.replace "Strata.B3AST.Program." "." + let s := s.replace "Strata.B3AST.Decl." "." + let s := s.replace "Strata.B3AST.FParameter." "." + let s := s.replace "Strata.B3AST.PParameter." "." + let s := s.replace "Strata.B3AST.Spec." "." + let s := s.replace "Strata.B3AST.ParamMode." "." + let s := s.replace "Strata.B3AST.FunctionBody." "." + let s := s.replace "Strata.B3AST.When." "." + s + +end B3 From 6025738b1759a26f8ebc65dfec9f6c65572a4666 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 10:50:54 -0600 Subject: [PATCH 02/24] Remove empty B3.lean file and note old() syntax investigation - Removed Strata/Languages/B3/B3.lean (empty documentation file with no code) - Investigated old() support for inout parameters: - B3 has old_id operation with syntax: old name (not old(name)) - Test expectations show unwrap is working correctly (indices are plain Nat) - Further investigation needed for proper old() syntax in specs and body --- Strata/Languages/B3/B3.lean | 27 ------------ Strata/Languages/B3/DDMConversion.lean | 46 ++++++++++----------- StrataTest/Languages/B3/DDMFormatTests.lean | 3 +- 3 files changed, 23 insertions(+), 53 deletions(-) delete mode 100644 Strata/Languages/B3/B3.lean diff --git a/Strata/Languages/B3/B3.lean b/Strata/Languages/B3/B3.lean deleted file mode 100644 index 78b5ef417..000000000 --- a/Strata/Languages/B3/B3.lean +++ /dev/null @@ -1,27 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.DDMTransform.ParseCST -import Strata.Languages.B3.DDMTransform.DefinitionAST -import Strata.Languages.B3.Identifiers - ---------------------------------------------------------------------- - -namespace B3 - -/-! -## B3 Language - -B3 is a simplified imperative verification language with: -- Basic types (bool, int, string) -- Expressions with binary/unary operators -- Statements including assignments, assertions, loops -- Procedure calls with in/out/inout parameters -- Quantifiers with optional patterns -- Control flow (if, loop, choose, exit) --/ - -end B3 diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean index 8da494126..ca03bb6f4 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMConversion.lean @@ -222,18 +222,18 @@ partial def unaryOpToCST [Inhabited (B3CST.Expression M)] : B3AST.UnaryOp M → | .neg _ => B3CST.Expression.neg partial def literalToCST [Inhabited (B3CST.Expression M)] : B3AST.Literal M → B3CST.Expression M - | .intLit m n => B3CST.Expression.natLit m n - | .boolLit m b => match b with | ⟨_, true⟩ => B3CST.Expression.btrue m | ⟨_, false⟩ => B3CST.Expression.bfalse m - | .stringLit m s => B3CST.Expression.strLit m s + | .intLit m n => B3CST.Expression.natLit m (mkAnn m n) + | .boolLit m b => if b then B3CST.Expression.btrue m else B3CST.Expression.bfalse m + | .stringLit m s => B3CST.Expression.strLit m (mkAnn m s) partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : B3AST.Expression M → B3CST.Expression M | .literal _m lit => literalToCST lit | .id m idx => - if ctx.inProcedure && ctx.isShadowed idx.val then - B3CST.Expression.old_id m (mkAnn m (ctx.lookup idx.val)) + if ctx.inProcedure && ctx.isShadowed idx then + B3CST.Expression.old_id m (mkAnn m (ctx.lookup idx)) else - B3CST.Expression.id m (mkAnn m (ctx.lookup idx.val)) + B3CST.Expression.id m (mkAnn m (ctx.lookup idx)) | .ite m cond thn els => B3CST.Expression.ite m (expressionToCST ctx cond) (expressionToCST ctx thn) (expressionToCST ctx els) | .binaryOp m op lhs rhs => @@ -368,12 +368,12 @@ partial def patternsToArray [Inhabited M] : B3CST.Patterns M → Array (B3CST.Pa | .patterns_cons _ p ps => patternsToArray ps |>.push p partial def expressionFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Expression M → Strata.B3AST.Expression M - | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, n.val⟩) - | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, s.val⟩) - | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, true⟩) - | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) ⟨B3AnnFromCST.annForLiteralValue ann, false⟩) - | .id ann name => .id (B3AnnFromCST.annForId ann) ⟨B3AnnFromCST.annForIdValue ann, ctx.lookup name.val⟩ - | .old_id ann name => .id (B3AnnFromCST.annForId ann) ⟨B3AnnFromCST.annForIdValue ann, ctx.lookupLast name.val⟩ + | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n.val) + | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s.val) + | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) + | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) + | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name.val) + | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name.val) | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) @@ -639,15 +639,13 @@ They duplicate the Unit-based conversions but thread M through all recursive cal mutual partial def literalToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ann : M) : B3AST.Literal M → B3CST.Expression M - | .intLit _ n => B3CST.Expression.natLit ann (mkAnn ann n.val) - | .boolLit _ b => match b with - | ⟨_, true⟩ => B3CST.Expression.btrue ann - | ⟨_, false⟩ => B3CST.Expression.bfalse ann - | .stringLit _ s => B3CST.Expression.strLit ann (mkAnn ann s.val) + | .intLit _ n => B3CST.Expression.natLit ann (mkAnn ann n) + | .boolLit _ b => if b then B3CST.Expression.btrue ann else B3CST.Expression.bfalse ann + | .stringLit _ s => B3CST.Expression.strLit ann (mkAnn ann s) partial def expressionToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Expression M → B3CST.Expression M | .literal ann lit => literalToCSTSR ann lit - | .id ann idx => B3CST.Expression.id ann (mkAnn ann (ctx.lookup idx.val)) + | .id ann idx => B3CST.Expression.id ann (mkAnn ann (ctx.lookup idx)) | .ite ann cond thn els => B3CST.Expression.ite ann (expressionToCSTSR ctx cond) (expressionToCSTSR ctx thn) (expressionToCSTSR ctx els) | .binaryOp ann op lhs rhs => let ctor := match op with @@ -706,12 +704,12 @@ partial def patternsToArraySR [Inhabited $ Strata.B3AST.Expression M] : B3CST.Pa | .patterns_cons _ p ps => patternsToArraySR ps |>.push p partial def expressionFromDDMSR [Inhabited $ Strata.B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.Expression M → Strata.B3AST.Expression M - | .natLit ann n => .literal ann (.intLit ann (mkAnn ann n.val)) - | .strLit ann s => .literal ann (.stringLit ann (mkAnn ann s.val)) - | .btrue ann => .literal ann (.boolLit ann (mkAnn ann true)) - | .bfalse ann => .literal ann (.boolLit ann (mkAnn ann false)) - | .id ann name => .id ann (mkAnn ann (ctx.lookup name.val)) - | .old_id ann name => .id ann (mkAnn ann (ctx.lookupLast name.val)) + | .natLit ann n => .literal ann (.intLit ann n.val) + | .strLit ann s => .literal ann (.stringLit ann s.val) + | .btrue ann => .literal ann (.boolLit ann true) + | .bfalse ann => .literal ann (.boolLit ann false) + | .id ann name => .id ann (ctx.lookup name.val) + | .old_id ann name => .id ann (ctx.lookupLast name.val) | .not ann arg => .unaryOp ann (.not ann) (expressionFromDDMSR ctx arg) | .neg ann arg => .unaryOp ann (.neg ann) (expressionFromDDMSR ctx arg) | .iff ann lhs rhs => .binaryOp ann (.iff ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index 3633b0c49..22477dcd7 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -64,7 +64,7 @@ info: inductive Strata.B3AST.Expression : Type → Type number of parameters: 1 constructors: Strata.B3AST.Expression.literal : {α : Type} → α → B3AST.Literal α → B3AST.Expression α -Strata.B3AST.Expression.id : {α : Type} → α → Ann Nat α → B3AST.Expression α +Strata.B3AST.Expression.id : {α : Type} → α → Nat → B3AST.Expression α Strata.B3AST.Expression.ite : {α : Type} → α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α → B3AST.Expression α Strata.B3AST.Expression.binaryOp : {α : Type} → @@ -120,7 +120,6 @@ mutual | .decimal () v => .decimal default v | .strlit () s => .strlit default s | .bytes () v => .bytes default v - | .bool () b => .bool default b | .option () ma => .option default (ma.map argFUnitToSourceRange) | .seq () entries => .seq default (entries.map argFUnitToSourceRange) | .commaSepList () entries => .commaSepList default (entries.map argFUnitToSourceRange) From d199dd12c66624674c946b45a5a9f29de31dc257 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 11:00:16 -0600 Subject: [PATCH 03/24] Rename fromDDM to fromCST for clarity DDM is used for both CST and AST representations, so renamed: - FromDDMContext -> FromCSTContext - expressionFromDDM -> expressionFromCST - statementFromDDM -> statementFromCST - declFromDDM -> declFromCST - programFromDDM -> programFromCST This makes it clear these functions convert from CST to AST. --- Strata/Languages/B3/DDMConversion.lean | 312 +++++++++--------- .../B3/DDMFormatDeclarationsTests.lean | 73 ++-- 2 files changed, 200 insertions(+), 185 deletions(-) diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean index ca03bb6f4..c3dc8a1d0 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMConversion.lean @@ -335,17 +335,17 @@ end ToCST -- B3CST → B3AST Conversion (Concrete to Abstract) --------------------------------------------------------------------- -section FromDDM +section FromCST -structure FromDDMContext where +structure FromCSTContext where vars : List String -namespace FromDDMContext +namespace FromCSTContext -def lookup (ctx : FromDDMContext) (name : String) : Nat := +def lookup (ctx : FromCSTContext) (name : String) : Nat := ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length -def lookupLast (ctx : FromDDMContext) (name : String) : Nat := +def lookupLast (ctx : FromCSTContext) (name : String) : Nat := -- Find the last occurrence by searching from the end let rec findLast (vars : List String) (idx : Nat) : Option Nat := match vars with @@ -356,72 +356,72 @@ def lookupLast (ctx : FromDDMContext) (name : String) : Nat := | none => if v == name then some idx else none findLast ctx.vars 0 |>.getD ctx.vars.length -def push (ctx : FromDDMContext) (name : String) : FromDDMContext := +def push (ctx : FromCSTContext) (name : String) : FromCSTContext := { vars := name :: ctx.vars } -def empty : FromDDMContext := { vars := [] } +def empty : FromCSTContext := { vars := [] } -end FromDDMContext +end FromCSTContext partial def patternsToArray [Inhabited M] : B3CST.Patterns M → Array (B3CST.Pattern M) | .patterns_single _ p => #[p] | .patterns_cons _ p ps => patternsToArray ps |>.push p -partial def expressionFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Expression M → Strata.B3AST.Expression M +partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Expression M → Strata.B3AST.Expression M | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n.val) | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s.val) | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name.val) | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name.val) - | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) - | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromDDM ctx arg) - | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .implies ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.implies (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .impliedBy ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.impliedBy (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .and ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.and (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .or ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.or (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.eq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .not_equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.neq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .lt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.lt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .le ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.le (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .ge ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.ge (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .gt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.gt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .add ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.add (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .sub ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.sub (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .mul ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mul (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .div ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.div (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .mod ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mod (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromDDM ctx lhs) (expressionFromDDM ctx rhs) - | .functionCall ann fn args => .functionCall (B3AnnFromCST.annForFunctionCall ann) ⟨B3AnnFromCST.annForFunctionCallName ann, fn.val⟩ ⟨B3AnnFromCST.annForFunctionCallArgs ann, args.val.map (expressionFromDDM ctx)⟩ - | .labeledExpr ann label expr => .labeledExpr (B3AnnFromCST.annForLabeledExpr ann) ⟨B3AnnFromCST.annForLabeledExprLabel ann, label.val⟩ (expressionFromDDM ctx expr) + | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) + | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) + | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .implies ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.implies (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .impliedBy ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.impliedBy (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .and ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.and (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .or ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.or (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.eq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .not_equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.neq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .lt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.lt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .le ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.le (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .ge ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.ge (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .gt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.gt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .add ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.add (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .sub ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.sub (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .mul ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mul (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .div ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.div (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .mod ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mod (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) + | .functionCall ann fn args => .functionCall (B3AnnFromCST.annForFunctionCall ann) ⟨B3AnnFromCST.annForFunctionCallName ann, fn.val⟩ ⟨B3AnnFromCST.annForFunctionCallArgs ann, args.val.map (expressionFromCST ctx)⟩ + | .labeledExpr ann label expr => .labeledExpr (B3AnnFromCST.annForLabeledExpr ann) ⟨B3AnnFromCST.annForLabeledExprLabel ann, label.val⟩ (expressionFromCST ctx expr) | .letExpr ann var value body => let ctx' := ctx.push var.val - .letExpr (B3AnnFromCST.annForLetExpr ann) ⟨B3AnnFromCST.annForLetExprVar ann, var.val⟩ (expressionFromDDM ctx value) (expressionFromDDM ctx' body) - | .ite ann cond thenExpr elseExpr => .ite (B3AnnFromCST.annForIte ann) (expressionFromDDM ctx cond) (expressionFromDDM ctx thenExpr) (expressionFromDDM ctx elseExpr) + .letExpr (B3AnnFromCST.annForLetExpr ann) ⟨B3AnnFromCST.annForLetExprVar ann, var.val⟩ (expressionFromCST ctx value) (expressionFromCST ctx' body) + | .ite ann cond thenExpr elseExpr => .ite (B3AnnFromCST.annForIte ann) (expressionFromCST ctx cond) (expressionFromCST ctx thenExpr) (expressionFromCST ctx elseExpr) | .forall_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromDDM ctx' body) + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromCST ctx' body) | .forall_expr ann var ty patterns body => let ctx' := ctx.push var.val let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := match p with - | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromDDM ctx')⟩ + | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromCST ctx')⟩ let patternsArray := patternsToArray patterns |>.map convertPattern - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromDDM ctx' body) + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromCST ctx' body) | .exists_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromDDM ctx' body) + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromCST ctx' body) | .exists_expr ann var ty patterns body => let ctx' := ctx.push var.val let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := match p with - | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromDDM ctx')⟩ + | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromCST ctx')⟩ let patternsArray := patternsToArray patterns |>.map convertPattern - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromDDM ctx' body) - | .paren _ expr => expressionFromDDM ctx expr + .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromCST ctx' body) + | .paren _ expr => expressionFromCST ctx expr -partial def callArgFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.CallArg M → Strata.B3AST.CallArg M - | .call_arg_expr m expr => .callArgExpr m (expressionFromDDM ctx expr) +partial def callArgFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.CallArg M → Strata.B3AST.CallArg M + | .call_arg_expr m expr => .callArgExpr m (expressionFromCST ctx expr) | .call_arg_out m id => .callArgOut m (mapAnn (fun x => x) id) | .call_arg_inout m id => .callArgInout m (mapAnn (fun x => x) id) @@ -433,43 +433,43 @@ partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List match branch with | .choice_branch _ stmt => stmt :: choiceBranchesToList branches -partial def stmtFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Statement M → Strata.B3AST.Statement M +partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Statement M → Strata.B3AST.Statement M | .var_decl_full m name ty autoinv init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) (mkAnn m (some (expressionFromDDM ctx' init))) + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) (mkAnn m (some (expressionFromCST ctx' init))) | .var_decl_with_autoinv m name ty autoinv => - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) (mkAnn m none) + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) (mkAnn m none) | .var_decl_with_init m name ty init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .var_decl_typed m name ty => .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m none) | .var_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .val_decl m name ty init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .val_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDM ctx' init))) + .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromDDM ctx rhs) + .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCST ctx rhs) | .reinit_statement m v => .reinit m (mkAnn m (ctx.lookup v.val)) | .check m expr => - .check m (expressionFromDDM ctx expr) + .check m (expressionFromCST ctx expr) | .assume m expr => - .assume m (expressionFromDDM ctx expr) + .assume m (expressionFromCST ctx expr) | .reach m expr => - .reach m (expressionFromDDM ctx expr) + .reach m (expressionFromCST ctx expr) | .assert m expr => - .assert m (expressionFromDDM ctx expr) + .assert m (expressionFromCST ctx expr) | .return_statement m => .returnStmt m | .block m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtFromDDM ctx stmt + let stmt' := stmtFromCST ctx stmt let ctx' := match stmt with | .var_decl_full _ name _ _ _ => ctx.push name.val | .var_decl_with_autoinv _ name _ _ => ctx.push name.val @@ -483,30 +483,30 @@ partial def stmtFromDDM [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : ) ([], ctx) .blockStmt m (mkAnn m stmts'.toArray) | .if_statement m cond thenB elseB => - let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromDDM ctx stmt)) elseB - .ifStmt m (expressionFromDDM ctx cond) (stmtFromDDM ctx thenB) elseBranch + let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromCST ctx stmt)) elseB + .ifStmt m (expressionFromCST ctx cond) (stmtFromCST ctx thenB) elseBranch | .loop_statement m invs body => let invariants := invs.val.toList.map fun inv => match inv with - | .invariant _ expr => expressionFromDDM ctx expr - .loop m (mkAnn m invariants.toArray) (stmtFromDDM ctx body) + | .invariant _ expr => expressionFromCST ctx expr + .loop m (mkAnn m invariants.toArray) (stmtFromCST ctx body) | .exit_statement m label => .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) | .labeled_statement m label stmt => - .labeledStmt m (mapAnn (fun x => x) label) (stmtFromDDM ctx stmt) + .labeledStmt m (mapAnn (fun x => x) label) (stmtFromCST ctx stmt) | .probe m label => .probe m (mapAnn (fun x => x) label) | .aForall_statement m var ty body => let ctx' := ctx.push var.val - .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromDDM ctx' body) + .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromCST ctx' body) | .choose_statement m branches => - .choose m (mkAnn m (choiceBranchesToList branches |>.map (stmtFromDDM ctx)).toArray) + .choose m (mkAnn m (choiceBranchesToList branches |>.map (stmtFromCST ctx)).toArray) | .if_case_statement m cases => .ifCase m (mapAnn (fun arr => arr.toList.map (fun case => match case with - | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromDDM ctx cond) (stmtFromDDM ctx stmt)) |>.toArray) cases) + | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromCST ctx cond) (stmtFromCST ctx stmt)) |>.toArray) cases) | .call_statement m procName args => - .call m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgFromDDM ctx) |>.toArray) args) + .call m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgFromCST ctx) |>.toArray) args) def paramModeFromCST [Inhabited M] : Ann (Option (B3CST.PParamMode M)) M → Strata.B3AST.ParamMode M | ⟨m, none⟩ => .paramModeIn m @@ -520,20 +520,20 @@ def fParameterFromCST [Inhabited M] : B3CST.FParam M → Strata.B3AST.FParameter | none => false .fParameter m (mkAnn m inj) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) -def pParameterFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.PParam M → Strata.B3AST.PParameter M +def pParameterFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.PParam M → Strata.B3AST.PParameter M | .pparam m mode name ty => .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m none) | .pparam_with_autoinv m mode name ty autoinv => - .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m (some (expressionFromDDM ctx autoinv))) + .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) -def specFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Spec M → Strata.B3AST.Spec M - | .spec_requires m expr => .specRequires m (expressionFromDDM ctx expr) - | .spec_ensures m expr => .specEnsures m (expressionFromDDM ctx expr) +def specFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Spec M → Strata.B3AST.Spec M + | .spec_requires m expr => .specRequires m (expressionFromCST ctx expr) + | .spec_ensures m expr => .specEnsures m (expressionFromCST ctx expr) def fparamsToList : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) | ⟨_, arr⟩ => arr.toList -def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.Decl M → Strata.B3AST.Decl M +def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Decl M → Strata.B3AST.Decl M | .type_decl m name => .typeDecl m (mapAnn (fun x => x) name) | .tagger_decl m name forType => @@ -545,16 +545,16 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.De let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .function_body_some bm whens expr => - let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromDDM ctx' e)) - B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromDDM ctx' expr))) body + let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCST ctx' e)) + B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromCST ctx' expr))) body .function m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mapAnn (fun x => x) resultType) (mkAnn m tagAST) bodyAST | .axiom_decl m axiomBody => match axiomBody with | .axiom _ expr => - .axiom m (mkAnn m #[]) (expressionFromDDM ctx expr) + .axiom m (mkAnn m #[]) (expressionFromCST ctx expr) | .explain_axiom _ names expr => let namesAST := names.val.toList.map (fun n => mkAnn m n.val) - .axiom m (mkAnn m namesAST.toArray) (expressionFromDDM ctx expr) + .axiom m (mkAnn m namesAST.toArray) (expressionFromCST ctx expr) | .procedure_decl m name params specs body => -- First, collect all parameter names to build context for autoinv expressions let paramNames := params.val.toList.map (fun p => match p with @@ -564,10 +564,10 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromDDMContext) : B3CST.De -- Now convert all parameters with the full context (so autoinv can reference all params) let paramsAST := params.val.toList.map (pParameterFromCST ctx') let specsAST := specs.val.toList.map (specFromCST ctx') - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => stmtFromDDM ctx' s)) body + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => stmtFromCST ctx' s)) body .procedure m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST -end FromDDM +end FromCST --------------------------------------------------------------------- -- Annotation-Preserving Conversions (B3CST M ↔ B3AST M) @@ -603,15 +603,15 @@ def empty : ToCSTContextSR := { vars := [] } end ToCSTContextSR -structure FromDDMContextSR where +structure FromCSTContextSR where vars : List String -namespace FromDDMContextSR +namespace FromCSTContextSR -def lookup (ctx : FromDDMContextSR) (name : String) : Nat := +def lookup (ctx : FromCSTContextSR) (name : String) : Nat := ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length -def lookupLast (ctx : FromDDMContextSR) (name : String) : Nat := +def lookupLast (ctx : FromCSTContextSR) (name : String) : Nat := -- Find the last occurrence by searching from the end let rec findLast (vars : List String) (idx : Nat) : Option Nat := match vars with @@ -622,12 +622,12 @@ def lookupLast (ctx : FromDDMContextSR) (name : String) : Nat := | none => if v == name then some idx else none findLast ctx.vars 0 |>.getD ctx.vars.length -def push (ctx : FromDDMContextSR) (name : String) : FromDDMContextSR := +def push (ctx : FromCSTContextSR) (name : String) : FromCSTContextSR := { vars := name :: ctx.vars } -def empty : FromDDMContextSR := { vars := [] } +def empty : FromCSTContextSR := { vars := [] } -end FromDDMContextSR +end FromCSTContextSR /-! ## Annotation-Preserving Conversions @@ -703,65 +703,65 @@ partial def patternsToArraySR [Inhabited $ Strata.B3AST.Expression M] : B3CST.Pa | .patterns_single _ p => #[p] | .patterns_cons _ p ps => patternsToArraySR ps |>.push p -partial def expressionFromDDMSR [Inhabited $ Strata.B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.Expression M → Strata.B3AST.Expression M +partial def expressionFromCSTSR [Inhabited $ Strata.B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.Expression M → Strata.B3AST.Expression M | .natLit ann n => .literal ann (.intLit ann n.val) | .strLit ann s => .literal ann (.stringLit ann s.val) | .btrue ann => .literal ann (.boolLit ann true) | .bfalse ann => .literal ann (.boolLit ann false) | .id ann name => .id ann (ctx.lookup name.val) | .old_id ann name => .id ann (ctx.lookupLast name.val) - | .not ann arg => .unaryOp ann (.not ann) (expressionFromDDMSR ctx arg) - | .neg ann arg => .unaryOp ann (.neg ann) (expressionFromDDMSR ctx arg) - | .iff ann lhs rhs => .binaryOp ann (.iff ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .implies ann lhs rhs => .binaryOp ann (.implies ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .impliedBy ann lhs rhs => .binaryOp ann (.impliedBy ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .and ann lhs rhs => .binaryOp ann (.and ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .or ann lhs rhs => .binaryOp ann (.or ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .equal ann lhs rhs => .binaryOp ann (.eq ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .not_equal ann lhs rhs => .binaryOp ann (.neq ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .lt ann lhs rhs => .binaryOp ann (.lt ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .le ann lhs rhs => .binaryOp ann (.le ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .ge ann lhs rhs => .binaryOp ann (.ge ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .gt ann lhs rhs => .binaryOp ann (.gt ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .add ann lhs rhs => .binaryOp ann (.add ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .sub ann lhs rhs => .binaryOp ann (.sub ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .mul ann lhs rhs => .binaryOp ann (.mul ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .div ann lhs rhs => .binaryOp ann (.div ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .mod ann lhs rhs => .binaryOp ann (.mod ann) (expressionFromDDMSR ctx lhs) (expressionFromDDMSR ctx rhs) - | .functionCall ann fn args => .functionCall ann (mkAnn ann fn.val) (mkAnn ann (args.val.map (expressionFromDDMSR ctx))) - | .labeledExpr ann label expr => .labeledExpr ann (mkAnn ann label.val) (expressionFromDDMSR ctx expr) + | .not ann arg => .unaryOp ann (.not ann) (expressionFromCSTSR ctx arg) + | .neg ann arg => .unaryOp ann (.neg ann) (expressionFromCSTSR ctx arg) + | .iff ann lhs rhs => .binaryOp ann (.iff ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .implies ann lhs rhs => .binaryOp ann (.implies ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .impliedBy ann lhs rhs => .binaryOp ann (.impliedBy ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .and ann lhs rhs => .binaryOp ann (.and ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .or ann lhs rhs => .binaryOp ann (.or ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .equal ann lhs rhs => .binaryOp ann (.eq ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .not_equal ann lhs rhs => .binaryOp ann (.neq ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .lt ann lhs rhs => .binaryOp ann (.lt ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .le ann lhs rhs => .binaryOp ann (.le ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .ge ann lhs rhs => .binaryOp ann (.ge ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .gt ann lhs rhs => .binaryOp ann (.gt ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .add ann lhs rhs => .binaryOp ann (.add ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .sub ann lhs rhs => .binaryOp ann (.sub ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .mul ann lhs rhs => .binaryOp ann (.mul ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .div ann lhs rhs => .binaryOp ann (.div ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .mod ann lhs rhs => .binaryOp ann (.mod ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) + | .functionCall ann fn args => .functionCall ann (mkAnn ann fn.val) (mkAnn ann (args.val.map (expressionFromCSTSR ctx))) + | .labeledExpr ann label expr => .labeledExpr ann (mkAnn ann label.val) (expressionFromCSTSR ctx expr) | .letExpr ann var value body => let ctx' := ctx.push var.val - .letExpr ann (mkAnn ann var.val) (expressionFromDDMSR ctx value) (expressionFromDDMSR ctx' body) - | .ite ann cond thenExpr elseExpr => .ite ann (expressionFromDDMSR ctx cond) (expressionFromDDMSR ctx thenExpr) (expressionFromDDMSR ctx elseExpr) + .letExpr ann (mkAnn ann var.val) (expressionFromCSTSR ctx value) (expressionFromCSTSR ctx' body) + | .ite ann cond thenExpr elseExpr => .ite ann (expressionFromCSTSR ctx cond) (expressionFromCSTSR ctx thenExpr) (expressionFromCSTSR ctx elseExpr) | .forall_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromDDMSR ctx' body) + .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromCSTSR ctx' body) | .forall_expr ann var ty patterns body => let ctx' := ctx.push var.val let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := match p with - | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromDDMSR ctx'))) + | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromCSTSR ctx'))) let patternsArray := patternsToArraySR patterns |>.map convertPattern - .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromDDMSR ctx' body) + .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromCSTSR ctx' body) | .exists_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromDDMSR ctx' body) + .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromCSTSR ctx' body) | .exists_expr ann var ty patterns body => let ctx' := ctx.push var.val let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := match p with - | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromDDMSR ctx'))) + | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromCSTSR ctx'))) let patternsArray := patternsToArraySR patterns |>.map convertPattern - .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromDDMSR ctx' body) - | .paren _ expr => expressionFromDDMSR ctx expr + .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromCSTSR ctx' body) + | .paren _ expr => expressionFromCSTSR ctx expr end namespace Expression def toAST [Inhabited $ Strata.B3AST.Expression M] (e : B3CST.Expression M) : Strata.B3AST.Expression M := - expressionFromDDMSR FromDDMContextSR.empty e + expressionFromCSTSR FromCSTContextSR.empty e def toCST [Inhabited $ Strata.B3CST.Expression M] (e : Strata.B3AST.Expression M) : B3CST.Expression M := expressionToCSTSR ToCSTContextSR.empty e @@ -829,8 +829,8 @@ partial def stmtToCSTSR [Inhabited (B3CST.Expression M)] [Inhabited $ B3CST.Stat | .returnStmt m => B3CST.Statement.return_statement m | .probe m label => B3CST.Statement.probe m (mkAnn m label.val) -partial def callArgFromDDMSR [Inhabited (B3AST.Expression M)] (ctx : FromDDMContextSR) : B3CST.CallArg M → Strata.B3AST.CallArg M - | .call_arg_expr m expr => .callArgExpr m (expressionFromDDMSR ctx expr) +partial def callArgFromCSTSR [Inhabited (B3AST.Expression M)] (ctx : FromCSTContextSR) : B3CST.CallArg M → Strata.B3AST.CallArg M + | .call_arg_expr m expr => .callArgExpr m (expressionFromCSTSR ctx expr) | .call_arg_out m id => .callArgOut m (mkAnn m id.val) | .call_arg_inout m id => .callArgInout m (mkAnn m id.val) @@ -842,43 +842,43 @@ partial def choiceBranchesToListSR : B3CST.ChoiceBranches M → List (B3CST.Stat match branch with | .choice_branch _ stmt => stmt :: choiceBranchesToListSR branches -partial def stmtFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Statement M → Strata.B3AST.Statement M +partial def stmtFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Statement M → Strata.B3AST.Statement M | .var_decl_full m name ty autoinv init => let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) (mkAnn m (some (expressionFromDDMSR ctx' init))) + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) (mkAnn m (some (expressionFromCSTSR ctx' init))) | .var_decl_with_autoinv m name ty autoinv => - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) (mkAnn m none) + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) (mkAnn m none) | .var_decl_with_init m name ty init => let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) | .var_decl_typed m name ty => .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m none) | .var_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) | .val_decl m name ty init => let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) | .val_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromDDMSR ctx' init))) + .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromDDMSR ctx rhs) + .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCSTSR ctx rhs) | .reinit_statement m v => .reinit m (mkAnn m (ctx.lookup v.val)) | .check m expr => - .check m (expressionFromDDMSR ctx expr) + .check m (expressionFromCSTSR ctx expr) | .assume m expr => - .assume m (expressionFromDDMSR ctx expr) + .assume m (expressionFromCSTSR ctx expr) | .reach m expr => - .reach m (expressionFromDDMSR ctx expr) + .reach m (expressionFromCSTSR ctx expr) | .assert m expr => - .assert m (expressionFromDDMSR ctx expr) + .assert m (expressionFromCSTSR ctx expr) | .return_statement m => .returnStmt m | .block m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtFromDDMSR ctx stmt + let stmt' := stmtFromCSTSR ctx stmt let ctx' := match stmt with | .var_decl_full _ name _ _ _ => ctx.push name.val | .var_decl_with_autoinv _ name _ _ => ctx.push name.val @@ -892,35 +892,35 @@ partial def stmtFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.St ) ([], ctx) .blockStmt m (mkAnn m stmts'.toArray) | .if_statement m cond thenB elseB => - let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromDDMSR ctx stmt)) elseB - .ifStmt m (expressionFromDDMSR ctx cond) (stmtFromDDMSR ctx thenB) elseBranch + let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromCSTSR ctx stmt)) elseB + .ifStmt m (expressionFromCSTSR ctx cond) (stmtFromCSTSR ctx thenB) elseBranch | .loop_statement m invs body => let invariants := invs.val.toList.map fun inv => match inv with - | .invariant _ expr => expressionFromDDMSR ctx expr - .loop m (mkAnn m invariants.toArray) (stmtFromDDMSR ctx body) + | .invariant _ expr => expressionFromCSTSR ctx expr + .loop m (mkAnn m invariants.toArray) (stmtFromCSTSR ctx body) | .exit_statement m label => .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) | .labeled_statement m label stmt => - .labeledStmt m (mkAnn m label.val) (stmtFromDDMSR ctx stmt) + .labeledStmt m (mkAnn m label.val) (stmtFromCSTSR ctx stmt) | .probe m label => .probe m (mkAnn m label.val) | .aForall_statement m var ty body => let ctx' := ctx.push var.val - .aForall m (mkAnn m var.val) (mkAnn m ty.val) (stmtFromDDMSR ctx' body) + .aForall m (mkAnn m var.val) (mkAnn m ty.val) (stmtFromCSTSR ctx' body) | .choose_statement m branches => - .choose m (mkAnn m (choiceBranchesToListSR branches |>.map (stmtFromDDMSR ctx)).toArray) + .choose m (mkAnn m (choiceBranchesToListSR branches |>.map (stmtFromCSTSR ctx)).toArray) | .if_case_statement m cases => .ifCase m (mkAnn m (cases.val.toList.map (fun case => match case with - | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromDDMSR ctx cond) (stmtFromDDMSR ctx stmt)) |>.toArray)) + | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromCSTSR ctx cond) (stmtFromCSTSR ctx stmt)) |>.toArray)) | .call_statement m procName args => - .call m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgFromDDMSR ctx) |>.toArray)) + .call m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgFromCSTSR ctx) |>.toArray)) end def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (s : B3CST.Statement M) : Strata.B3AST.Statement M := - stmtFromDDMSR FromDDMContextSR.empty s + stmtFromCSTSR FromCSTContextSR.empty s def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (s : Strata.B3AST.Statement M) : B3CST.Statement M := stmtToCSTSR ToCSTContextSR.empty s @@ -979,14 +979,14 @@ partial def declToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Stat let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (Stmt.stmtToCSTSR ctx' s))) body B3CST.Decl.procedure_decl m (mkAnn m name.val) paramsCST (mkAnn m specsCST.toArray) bodyCST -partial def fParameterFromDDMSR : B3CST.FParam M → Strata.B3AST.FParameter M +partial def fParameterFromCSTSR : B3CST.FParam M → Strata.B3AST.FParameter M | .fparam m injective name ty => let inj := match injective.val with | some (.injective_some _) => true | none => false .fParameter m (mkAnn m inj) (mkAnn m name.val) (mkAnn m ty.val) -partial def pParameterFromDDMSR [Inhabited $ B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.PParam M → Strata.B3AST.PParameter M +partial def pParameterFromCSTSR [Inhabited $ B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.PParam M → Strata.B3AST.PParameter M | .pparam m mode name ty => let modeAST := match mode.val with | none => Strata.B3AST.ParamMode.paramModeIn m @@ -998,37 +998,37 @@ partial def pParameterFromDDMSR [Inhabited $ B3AST.Expression M] (ctx : FromDDMC | none => Strata.B3AST.ParamMode.paramModeIn m | some (.pmode_out _) => Strata.B3AST.ParamMode.paramModeOut m | some (.pmode_inout _) => Strata.B3AST.ParamMode.paramModeInout m - .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m (some (expressionFromDDMSR ctx autoinv))) + .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) -partial def specFromDDMSR [Inhabited $ B3AST.Expression M] (ctx : FromDDMContextSR) : B3CST.Spec M → Strata.B3AST.Spec M - | .spec_requires m expr => .specRequires m (expressionFromDDMSR ctx expr) - | .spec_ensures m expr => .specEnsures m (expressionFromDDMSR ctx expr) +partial def specFromCSTSR [Inhabited $ B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.Spec M → Strata.B3AST.Spec M + | .spec_requires m expr => .specRequires m (expressionFromCSTSR ctx expr) + | .spec_ensures m expr => .specEnsures m (expressionFromCSTSR ctx expr) partial def fparamsToListSR : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) | ⟨_, arr⟩ => arr.toList -partial def declFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Decl M → Strata.B3AST.Decl M +partial def declFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Decl M → Strata.B3AST.Decl M | .type_decl m name => .typeDecl m (mkAnn m name.val) | .tagger_decl m name forType => .tagger m (mkAnn m name.val) (mkAnn m forType.val) | .function_decl m name params resultType tag body => - let paramsAST := fparamsToListSR params |>.map fParameterFromDDMSR + let paramsAST := fparamsToListSR params |>.map fParameterFromCSTSR let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .function_body_some bm whens expr => - let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromDDMSR ctx' e)) - B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromDDMSR ctx' expr))) body + let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCSTSR ctx' e)) + B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromCSTSR ctx' expr))) body .function m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m resultType.val) (mkAnn m tagAST) bodyAST | .axiom_decl m axiomBody => match axiomBody with | .axiom _ expr => - .axiom m (mkAnn m #[]) (expressionFromDDMSR ctx expr) + .axiom m (mkAnn m #[]) (expressionFromCSTSR ctx expr) | .explain_axiom _ names expr => let namesAST := names.val.toList.map (fun n => mkAnn m n.val) - .axiom m (mkAnn m namesAST.toArray) (expressionFromDDMSR ctx expr) + .axiom m (mkAnn m namesAST.toArray) (expressionFromCSTSR ctx expr) | .procedure_decl m name params specs body => -- First, collect all parameter names to build context for autoinv expressions let paramNames := params.val.toList.map (fun p => match p with @@ -1036,15 +1036,15 @@ partial def declFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.St | .pparam_with_autoinv _ _ n _ _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx -- Now convert all parameters with the full context (so autoinv can reference all params) - let paramsAST := params.val.toList.map (pParameterFromDDMSR ctx') - let specsAST := specs.val.toList.map (specFromDDMSR ctx') - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => Stmt.stmtFromDDMSR ctx' s)) body + let paramsAST := params.val.toList.map (pParameterFromCSTSR ctx') + let specsAST := specs.val.toList.map (specFromCSTSR ctx') + let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => Stmt.stmtFromCSTSR ctx' s)) body .procedure m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST end def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (d : B3CST.Decl M) : Strata.B3AST.Decl M := - declFromDDMSR FromDDMContextSR.empty d + declFromCSTSR FromCSTContextSR.empty d def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (d : Strata.B3AST.Decl M) : B3CST.Decl M := declToCSTSR ToCSTContextSR.empty d @@ -1053,14 +1053,14 @@ end Decl namespace Program -partial def programFromDDMSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromDDMContextSR) : B3CST.Program M → Strata.B3AST.Program M - | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declFromDDMSR ctx) |>.toArray)) +partial def programFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Program M → Strata.B3AST.Program M + | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declFromCSTSR ctx) |>.toArray)) partial def programToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Program M → B3CST.Program M | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declToCSTSR ctx) |>.toArray)) def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (p : B3CST.Program M) : Strata.B3AST.Program M := - programFromDDMSR FromDDMContextSR.empty p + programFromCSTSR FromCSTContextSR.empty p def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (p : Strata.B3AST.Program M) : B3CST.Program M := programToCSTSR ToCSTContextSR.empty p diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 5d86d9def..5b9d884de 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -90,7 +90,7 @@ info: B3: .program u #[.axiom () u #[] - (.literal () (.boolLit () u true))] + (.literal () (.boolLit () true))] --- info: axiom true @@ -114,9 +114,7 @@ info: B3: .program u some (.functionBody () u #[] - (.literal - () - (.intLit () u 1)))] + (.literal () (.intLit () 1)))] --- info: function F(x : int) : int { @@ -151,8 +149,8 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () u 1) - (.id () u 0)))] + (.id () 1) + (.id () 0)))] --- info: function add(x : int, y : int) : int { @@ -179,7 +177,7 @@ info: B3: .program u some (.functionBody () u #[] - (.id () u 0))] + (.id () 0))] --- info: function id(injective x : int) : int { @@ -206,7 +204,7 @@ info: B3: .program u some (.functionBody () u #[] - (.id () u 0))] + (.id () 0))] --- info: function tagged(x : int) : int tag mytag { @@ -237,11 +235,9 @@ info: B3: .program (.binaryOp () (.gt ()) - (.id () u 0) - (.literal - () - (.intLit () u 0)))] - (.id () u 0))] + (.id () 0) + (.literal () (.intLit () 0)))] + (.id () 0))] --- info: function conditional(x : int) : int @@ -295,10 +291,10 @@ info: B3: .program (.binaryOp () (.gt ()) - (.id () u 0) + (.id () 0) (.literal () - (.intLit () u 0)))])] + (.intLit () 0)))])] --- info: procedure process(x : int) @@ -328,9 +324,7 @@ info: B3: .program u #[.assign () u 0 - (.literal - () - (.intLit () u 42))])] + (.literal () (.intLit () 42))])] --- info: procedure getResult(out result : int) @@ -354,7 +348,17 @@ info: B3: .program u "x" u "int" u none] - u #[] + u #[.specEnsures + () + (.binaryOp + () + (.eq ()) + (.id () 0) + (.binaryOp + () + (.add ()) + (.id () 0) + (.literal () (.intLit () 1))))] u some (.blockStmt () u #[.assign @@ -363,19 +367,32 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () u 0) - (.literal + (.id () 0) + (.literal () (.intLit () 1))), + .assert + () + (.binaryOp + () + (.eq ()) + (.id () 0) + (.binaryOp () - (.intLit () u 1)))])] + (.add ()) + (.id () 0) + (.literal + () + (.intLit () 1))))])] --- info: procedure increment(inout x : int) + ensures x == old x + 1 { x := x + 1 + assert x == old x + 1 } -/ #guard_msgs in -#eval roundtripDecl $ #strata program B3CST; procedure increment(inout x: int) { x := x + 1 } #end +#eval roundtripDecl $ #strata program B3CST; procedure increment(inout x: int) ensures x == old x + 1 { x := x + 1 assert x == old x + 1 } #end -- Procedure with mixed parameters /-- @@ -666,20 +683,18 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () u 2) - (.literal - () - (.intLit () u 1))), + (.id () 2) + (.literal () (.intLit () 1))), .assign () u 1 (.binaryOp () (.mul ()) - (.id () u 0) + (.id () 0) (.literal () - (.intLit () u 2)))])] + (.intLit () 2)))])] --- info: procedure multi(x : int, out y : int) From e85b31b408e7231f3beb0ced5efc2dcc27034ef0 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 11:19:27 -0600 Subject: [PATCH 04/24] Fix inout parameter handling with old() support - Inout parameters now create two context entries (old and current values) - ToCSTContext.lookup now returns (name, isOld) tuple - isOld is computed dynamically by checking for shadowing - When isOld is true, emit old_id CST node instead of id - Added test for inout parameter with old() in spec and body - This enables proper roundtrip for procedures using old values of inout parameters --- Strata/Languages/B3/DDMConversion.lean | 89 +++++++----- .../B3/DDMFormatDeclarationsTests.lean | 128 +++++++++++++----- 2 files changed, 147 insertions(+), 70 deletions(-) diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean index c3dc8a1d0..d9e227a9a 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMConversion.lean @@ -152,10 +152,14 @@ structure ToCSTContext where namespace ToCSTContext -def lookup (ctx : ToCSTContext) (idx : Nat): String := +def lookup (ctx : ToCSTContext) (idx : Nat): String × Bool := match ctx.vars[idx]? with | .some name => - if name == "" then s!"@{idx}" else + if name == "" then (s!"@{idx}", false) else + -- Determine if this is an old value: first occurrence with shadowing + let isOld := + -- Check if there's a later occurrence (lower index) with the same name + ctx.vars.take idx |>.any (· == name) -- We need to resolve ambiguities let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := let default := fun _: Unit => if pastIndex == 0 then @@ -173,17 +177,14 @@ def lookup (ctx : ToCSTContext) (idx : Nat): String := else go tail pastIndex (idx - 1) - go ctx.vars 0 idx + (go ctx.vars 0 idx, isOld) | .none => - s!"@{idx}" + (s!"@{idx}", false) -- Check if a variable at index idx is shadowed (has a later occurrence with same name) +-- This is now computed in lookup, but kept for compatibility def isShadowed (ctx : ToCSTContext) (idx : Nat) : Bool := - match ctx.vars[idx]? with - | .some name => - -- Check if there's another occurrence of this name at a lower index (later in the list) - ctx.vars.take idx |>.any (· == name) - | .none => false + (ctx.lookup idx).2 def push (ctx : ToCSTContext) (name : String) : ToCSTContext := { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } @@ -230,10 +231,11 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext | .literal _m lit => literalToCST lit | .id m idx => - if ctx.inProcedure && ctx.isShadowed idx then - B3CST.Expression.old_id m (mkAnn m (ctx.lookup idx)) + let (name, isOld) := ctx.lookup idx + if isOld then + B3CST.Expression.old_id m (mkAnn m name) else - B3CST.Expression.id m (mkAnn m (ctx.lookup idx)) + B3CST.Expression.id m (mkAnn m name) | .ite m cond thn els => B3CST.Expression.ite m (expressionToCST ctx cond) (expressionToCST ctx thn) (expressionToCST ctx els) | .binaryOp m op lhs rhs => @@ -290,8 +292,8 @@ partial def stmtToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.Statemen | some t, none, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val) | none, _, some i => B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) (expressionToCST ctx' i) | none, _, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val)) (expressionToCST ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val)) + | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).1) (expressionToCST ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).1) | .blockStmt m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => let stmt' := stmtToCST ctx stmt @@ -556,11 +558,15 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.De let namesAST := names.val.toList.map (fun n => mkAnn m n.val) .axiom m (mkAnn m namesAST.toArray) (expressionFromCST ctx expr) | .procedure_decl m name params specs body => - -- First, collect all parameter names to build context for autoinv expressions - let paramNames := params.val.toList.map (fun p => match p with - | .pparam _ _ n _ => n.val - | .pparam_with_autoinv _ _ n _ _ => n.val) - let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + -- Build context for parameters: inout parameters need two entries (old and current) + let ctx' := params.val.toList.foldl (fun acc p => + let (pname, mode) := match p with + | .pparam _ mode n _ => (n.val, mode.val) + | .pparam_with_autoinv _ mode n _ _ => (n.val, mode.val) + match mode with + | some (.pmode_inout _) => acc.push pname |>.push pname -- Push twice: old value, then current value + | _ => acc.push pname -- Push once for in/out parameters + ) ctx -- Now convert all parameters with the full context (so autoinv can reference all params) let paramsAST := params.val.toList.map (pParameterFromCST ctx') let specsAST := specs.val.toList.map (specFromCST ctx') @@ -580,10 +586,12 @@ structure ToCSTContextSR where namespace ToCSTContextSR -def lookup (ctx : ToCSTContextSR) (idx : Nat): String := +def lookup (ctx : ToCSTContextSR) (idx : Nat): String × Bool := match ctx.vars[idx]? with | .some name => - if name == "" then s!"@{idx}" else + if name == "" then (s!"@{idx}", false) else + -- Determine if this is an old value: first occurrence with shadowing + let isOld := ctx.vars.take idx |>.any (· == name) let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := let default := fun _: Unit => if pastIndex == 0 then name else s!"name@{pastIndex}" if idx == 0 then default () @@ -593,8 +601,8 @@ def lookup (ctx : ToCSTContextSR) (idx : Nat): String := | otherName :: tail => if name == otherName then go tail (pastIndex + 1) (idx - 1) else go tail pastIndex (idx - 1) - go ctx.vars 0 idx - | .none => s!"@{idx}" + (go ctx.vars 0 idx, isOld) + | .none => (s!"@{idx}", false) def push (ctx : ToCSTContextSR) (name : String) : ToCSTContextSR := { vars := name :: ctx.vars } @@ -645,7 +653,12 @@ partial def literalToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ann : M) : B partial def expressionToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Expression M → B3CST.Expression M | .literal ann lit => literalToCSTSR ann lit - | .id ann idx => B3CST.Expression.id ann (mkAnn ann (ctx.lookup idx)) + | .id ann idx => + let (name, isOld) := ctx.lookup idx + if isOld then + B3CST.Expression.old_id ann (mkAnn ann name) + else + B3CST.Expression.id ann (mkAnn ann name) | .ite ann cond thn els => B3CST.Expression.ite ann (expressionToCSTSR ctx cond) (expressionToCSTSR ctx thn) (expressionToCSTSR ctx els) | .binaryOp ann op lhs rhs => let ctor := match op with @@ -792,8 +805,8 @@ partial def stmtToCSTSR [Inhabited (B3CST.Expression M)] [Inhabited $ B3CST.Stat | some t, none, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m t.val) | none, _, some i => B3CST.Statement.var_decl_inferred m (mkAnn m name.val) (expressionToCSTSR ctx' i) | none, _, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val)) (expressionToCSTSR ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val)) + | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).fst) (expressionToCSTSR ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).fst) | .blockStmt m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => let stmt' := stmtToCSTSR ctx stmt @@ -972,8 +985,14 @@ partial def declToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Stat else B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST (expressionToCSTSR ctx expr)) | .procedure m name params specs body => - let paramNames := params.val.toList.map (fun p => match p with | .pParameter _ _ n _ _ => n.val) - let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + -- Build context: inout parameters need two entries (old and current) + let ctx' := params.val.toList.foldl (fun acc p => + match p with + | .pParameter _ mode pname _ _ => + match mode with + | .paramModeInout _ => acc.push s!"old {pname.val}" |>.push pname.val -- Push "old x" then "x" + | _ => acc.push pname.val + ) ctx let paramsCST := mkAnn m (params.val.toList.map (pParameterToCSTSR ctx') |>.toArray) let specsCST := specs.val.toList.map (specToCSTSR ctx') let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (Stmt.stmtToCSTSR ctx' s))) body @@ -1030,11 +1049,15 @@ partial def declFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.St let namesAST := names.val.toList.map (fun n => mkAnn m n.val) .axiom m (mkAnn m namesAST.toArray) (expressionFromCSTSR ctx expr) | .procedure_decl m name params specs body => - -- First, collect all parameter names to build context for autoinv expressions - let paramNames := params.val.toList.map (fun p => match p with - | .pparam _ _ n _ => n.val - | .pparam_with_autoinv _ _ n _ _ => n.val) - let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + -- Build context for parameters: inout parameters need two entries (old and current) + let ctx' := params.val.toList.foldl (fun acc p => + let (pname, mode) := match p with + | .pparam _ mode n _ => (n.val, mode.val) + | .pparam_with_autoinv _ mode n _ _ => (n.val, mode.val) + match mode with + | some (.pmode_inout _) => acc.push pname |>.push pname -- Push twice: old value, then current value + | _ => acc.push pname -- Push once for in/out parameters + ) ctx -- Now convert all parameters with the full context (so autoinv can reference all params) let paramsAST := params.val.toList.map (pParameterFromCSTSR ctx') let specsAST := specs.val.toList.map (specFromCSTSR ctx') diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 5b9d884de..325451fe5 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -428,18 +428,18 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () u 2) - (.id () u 0)), + (.id () 2) + (.id () 0)), .assign () u 0 (.binaryOp () (.add ()) - (.id () u 0) + (.id () 0) (.literal () - (.intLit () u 1)))])] + (.intLit () 1)))])] --- info: procedure compute(x : int, out y : int, inout z : int) @@ -469,10 +469,8 @@ info: B3: .program (.binaryOp () (.gt ()) - (.id () u 0) - (.literal - () - (.intLit () u 0)))] + (.id () 0) + (.literal () (.intLit () 0)))] u some (.blockStmt () u #[.check @@ -480,10 +478,10 @@ info: B3: .program (.binaryOp () (.gt ()) - (.id () u 0) + (.id () 0) (.literal () - (.intLit () u 0)))])] + (.intLit () 0)))])] --- info: procedure safe(x : int) @@ -513,18 +511,14 @@ info: B3: .program (.binaryOp () (.gt ()) - (.id () u 0) - (.literal - () - (.intLit () u 0)))] + (.id () 0) + (.literal () (.intLit () 0)))] u some (.blockStmt () u #[.assign () u 0 - (.literal - () - (.intLit () u 1))])] + (.literal () (.intLit () 1))])] --- info: procedure positive(out x : int) @@ -560,25 +554,21 @@ info: B3: .program (.binaryOp () (.ge ()) - (.id () u 1) - (.literal - () - (.intLit () u 0))), + (.id () 1) + (.literal () (.intLit () 0))), .specEnsures () (.binaryOp () (.ge ()) - (.id () u 0) - (.literal - () - (.intLit () u 0)))] + (.id () 0) + (.literal () (.intLit () 0)))] u some (.blockStmt () u #[.assign () u 0 - (.id () u 1)])] + (.id () 1)])] --- info: procedure bounded(x : int, out y : int) @@ -609,11 +599,9 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () u 1) - (.id () u 0)) - (.literal - () - (.intLit () u 0))), + (.id () 1) + (.id () 0)) + (.literal () (.intLit () 0))), .pParameter () (.paramModeIn ()) @@ -622,11 +610,11 @@ info: B3: .program u some (.binaryOp () (.ge ()) - (.id () u 0) + (.id () 0) (.unaryOp () (.neg ()) - (.id () u 1)))] + (.id () 1)))] u #[] u some (.blockStmt () @@ -635,10 +623,10 @@ info: B3: .program (.binaryOp () (.ge ()) - (.id () u 1) + (.id () 1) (.literal () - (.intLit () u 0)))])] + (.intLit () 0)))])] --- info: procedure withAutoinv(x : int autoinv x + y >= 0, y : int autoinv y >= -(x)) @@ -715,7 +703,7 @@ info: B3: .program .axiom () u #[] - (.literal () (.boolLit () u true)), + (.literal () (.boolLit () true)), .function () u "f" @@ -729,7 +717,7 @@ info: B3: .program u some (.functionBody () u #[] - (.id () u 0))] + (.id () 0))] --- info: type T @@ -741,6 +729,72 @@ function f(x : int) : int { #guard_msgs in #eval roundtripDecl $ #strata program B3CST; type T axiom true function f(x: int) : int { x } #end +-- Procedure with inout parameter using old values in spec and body +/-- +info: B3: .program + () + u #[.procedure + () + u "incrementWithOld" + u #[.pParameter + () + (.paramModeInout ()) + u "x" + u "int" + u none] + u #[.specEnsures + () + (.binaryOp + () + (.eq ()) + (.id () 0) + (.binaryOp + () + (.add ()) + (.id () 1) + (.literal () (.intLit () 1))))] + u some (.blockStmt + () + u #[.assign + () + u 0 + (.binaryOp + () + (.add ()) + (.id () 0) + (.literal () (.intLit () 1))), + .assert + () + (.binaryOp + () + (.eq ()) + (.id () 0) + (.binaryOp + () + (.add ()) + (.id () 1) + (.literal + () + (.intLit () 1))))])] +--- +info: +procedure incrementWithOld(inout x : int) + ensures x == old x + 1 +{ + x := x + 1 + assert x == old x + 1 +} +-/ +#guard_msgs in +#eval roundtripDecl $ #strata program B3CST; +procedure incrementWithOld(inout x: int) + ensures x == old x + 1 +{ + x := x + 1 + assert x == old x + 1 +} +#end + end DeclarationRoundtripTests end B3 From a6ac8d9b6fff5839b2e2b7d09207423b544dff53 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 11:19:27 -0600 Subject: [PATCH 05/24] Fix inout parameter handling with old() support - Inout parameters now create two context entries (old and current values) - ToCSTContext.lookup returns (name, isOld) computed dynamically - isOld determined by checking if variable is first occurrence with shadowing - When isOld is true, emit old_id CST node which prints as 'old x' - Added test demonstrating old() in both spec and body for inout parameters - Enables proper roundtrip for procedures using old values --- .../B3/DDMFormatDeclarationsTests.lean | 23 ++- .../B3/DDMFormatExpressionsTests.lean | 154 ++++++++---------- .../B3/DDMFormatStatementsTests.lean | 102 +++++------- 3 files changed, 126 insertions(+), 153 deletions(-) diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 325451fe5..2b42c60d4 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -357,11 +357,18 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () 0) + (.id () 1) (.literal () (.intLit () 1))))] u some (.blockStmt () - u #[.assign + u #[.assert + () + (.binaryOp + () + (.eq ()) + (.id () 0) + (.id () 1)), + .assign () u 0 (.binaryOp @@ -378,7 +385,7 @@ info: B3: .program (.binaryOp () (.add ()) - (.id () 0) + (.id () 1) (.literal () (.intLit () 1))))])] @@ -387,12 +394,16 @@ info: procedure increment(inout x : int) ensures x == old x + 1 { + assert x == old x x := x + 1 assert x == old x + 1 } -/ #guard_msgs in -#eval roundtripDecl $ #strata program B3CST; procedure increment(inout x: int) ensures x == old x + 1 { x := x + 1 assert x == old x + 1 } #end +#eval roundtripDecl $ #strata program B3CST; procedure increment(inout x: int) ensures x == old x + 1 { assert x == old x + x := x + 1 + assert x == old x + 1 +} #end -- Procedure with mixed parameters /-- @@ -424,11 +435,11 @@ info: B3: .program () u #[.assign () - u 1 + u 2 (.binaryOp () (.add ()) - (.id () 2) + (.id () 3) (.id () 0)), .assign () diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index 6bd6ff783..c6f2f3bbc 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -70,7 +70,7 @@ section ExpressionRoundtripTests -- We are loosing the context so this is why it's printing that way. /-- -info: B3: .id () u 0 +info: B3: .id () 0 --- info: @0 -/ @@ -81,8 +81,8 @@ info: @0 info: B3: .binaryOp () (.add ()) - (.literal () (.intLit () u 5)) - (.literal () (.intLit () u 3)) + (.literal () (.intLit () 5)) + (.literal () (.intLit () 3)) --- info: 5 + 3 -/ @@ -90,7 +90,7 @@ info: 5 + 3 #eval roundtripExpr $ #strata program B3CST; check 5 + 3 #end /-- -info: B3: .literal () (.boolLit () u true) +info: B3: .literal () (.boolLit () true) --- info: true -/ @@ -98,7 +98,7 @@ info: true #eval roundtripExpr $ #strata program B3CST; check true #end /-- -info: B3: .literal () (.boolLit () u false) +info: B3: .literal () (.boolLit () false) --- info: false -/ @@ -109,7 +109,7 @@ info: false info: B3: .unaryOp () (.not ()) - (.literal () (.boolLit () u true)) + (.literal () (.boolLit () true)) --- info: !true -/ @@ -120,8 +120,8 @@ info: !true info: B3: .binaryOp () (.sub ()) - (.literal () (.intLit () u 10)) - (.literal () (.intLit () u 3)) + (.literal () (.intLit () 10)) + (.literal () (.intLit () 3)) --- info: 10 - 3 -/ @@ -132,8 +132,8 @@ info: 10 - 3 info: B3: .binaryOp () (.mul ()) - (.literal () (.intLit () u 4)) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 4)) + (.literal () (.intLit () 5)) --- info: 4 * 5 -/ @@ -144,8 +144,8 @@ info: 4 * 5 info: B3: .binaryOp () (.div ()) - (.literal () (.intLit () u 20)) - (.literal () (.intLit () u 4)) + (.literal () (.intLit () 20)) + (.literal () (.intLit () 4)) --- info: 20 div 4 -/ @@ -156,8 +156,8 @@ info: 20 div 4 info: B3: .binaryOp () (.mod ()) - (.literal () (.intLit () u 17)) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 17)) + (.literal () (.intLit () 5)) --- info: 17 mod 5 -/ @@ -168,8 +168,8 @@ info: 17 mod 5 info: B3: .binaryOp () (.eq ()) - (.literal () (.intLit () u 5)) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 5)) + (.literal () (.intLit () 5)) --- info: 5 == 5 -/ @@ -180,8 +180,8 @@ info: 5 == 5 info: B3: .binaryOp () (.neq ()) - (.literal () (.intLit () u 3)) - (.literal () (.intLit () u 7)) + (.literal () (.intLit () 3)) + (.literal () (.intLit () 7)) --- info: 3 != 7 -/ @@ -192,8 +192,8 @@ info: 3 != 7 info: B3: .binaryOp () (.le ()) - (.literal () (.intLit () u 3)) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 3)) + (.literal () (.intLit () 5)) --- info: 3 <= 5 -/ @@ -204,8 +204,8 @@ info: 3 <= 5 info: B3: .binaryOp () (.lt ()) - (.literal () (.intLit () u 2)) - (.literal () (.intLit () u 8)) + (.literal () (.intLit () 2)) + (.literal () (.intLit () 8)) --- info: 2 < 8 -/ @@ -216,8 +216,8 @@ info: 2 < 8 info: B3: .binaryOp () (.ge ()) - (.literal () (.intLit () u 10)) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 10)) + (.literal () (.intLit () 5)) --- info: 10 >= 5 -/ @@ -228,8 +228,8 @@ info: 10 >= 5 info: B3: .binaryOp () (.gt ()) - (.literal () (.intLit () u 15)) - (.literal () (.intLit () u 3)) + (.literal () (.intLit () 15)) + (.literal () (.intLit () 3)) --- info: 15 > 3 -/ @@ -240,12 +240,12 @@ info: 15 > 3 info: B3: .binaryOp () (.add ()) - (.literal () (.intLit () u 2)) + (.literal () (.intLit () 2)) (.binaryOp () (.mul ()) - (.literal () (.intLit () u 3)) - (.literal () (.intLit () u 4))) + (.literal () (.intLit () 3)) + (.literal () (.intLit () 4))) --- info: 2 + 3 * 4 -/ @@ -259,9 +259,9 @@ info: B3: .binaryOp (.binaryOp () (.add ()) - (.literal () (.intLit () u 2)) - (.literal () (.intLit () u 3))) - (.literal () (.intLit () u 4)) + (.literal () (.intLit () 2)) + (.literal () (.intLit () 3))) + (.literal () (.intLit () 4)) --- info: (2 + 3) * 4 -/ @@ -275,9 +275,9 @@ info: B3: .binaryOp (.binaryOp () (.add ()) - (.literal () (.intLit () u 1)) - (.literal () (.intLit () u 2))) - (.literal () (.intLit () u 3)) + (.literal () (.intLit () 1)) + (.literal () (.intLit () 2))) + (.literal () (.intLit () 3)) --- info: 1 + 2 + 3 -/ @@ -291,9 +291,9 @@ info: B3: .binaryOp (.binaryOp () (.add ()) - (.literal () (.intLit () u 1)) - (.literal () (.intLit () u 2))) - (.literal () (.intLit () u 5)) + (.literal () (.intLit () 1)) + (.literal () (.intLit () 2))) + (.literal () (.intLit () 5)) --- info: 1 + 2 < 5 -/ @@ -307,9 +307,9 @@ info: B3: .binaryOp (.binaryOp () (.sub ()) - (.literal () (.intLit () u 10)) - (.literal () (.intLit () u 3))) - (.literal () (.intLit () u 2)) + (.literal () (.intLit () 10)) + (.literal () (.intLit () 3))) + (.literal () (.intLit () 2)) --- info: 10 - 3 + 2 -/ @@ -323,9 +323,9 @@ info: B3: .binaryOp (.binaryOp () (.div ()) - (.literal () (.intLit () u 20)) - (.literal () (.intLit () u 4))) - (.literal () (.intLit () u 3)) + (.literal () (.intLit () 20)) + (.literal () (.intLit () 4))) + (.literal () (.intLit () 3)) --- info: 20 div 4 * 3 -/ @@ -336,16 +336,16 @@ info: 20 div 4 * 3 info: B3: .binaryOp () (.lt ()) - (.literal () (.intLit () u 1)) + (.literal () (.intLit () 1)) (.binaryOp () (.add ()) (.binaryOp () (.mul ()) - (.literal () (.intLit () u 2)) - (.literal () (.intLit () u 3))) - (.literal () (.intLit () u 4))) + (.literal () (.intLit () 2)) + (.literal () (.intLit () 3))) + (.literal () (.intLit () 4))) --- info: 1 < 2 * 3 + 4 -/ @@ -355,9 +355,9 @@ info: 1 < 2 * 3 + 4 /-- info: B3: .ite () - (.literal () (.boolLit () u true)) - (.literal () (.intLit () u 1)) - (.literal () (.intLit () u 0)) + (.literal () (.boolLit () true)) + (.literal () (.intLit () 1)) + (.literal () (.intLit () 0)) --- info: if true then 1 else 0 -/ @@ -374,8 +374,8 @@ info: B3: .quantifierExpr (.binaryOp () (.ge ()) - (.id () u 0) - (.literal () (.intLit () u 0))) + (.id () 0) + (.literal () (.intLit () 0))) --- info: forall i : int i >= 0 -/ @@ -392,11 +392,8 @@ info: B3: .quantifierExpr (.binaryOp () (.or ()) - (.id () u 0) - (.unaryOp - () - (.not ()) - (.id () u 0))) + (.id () 0) + (.unaryOp () (.not ()) (.id () 0))) --- info: exists y : bool y || !y -/ @@ -414,19 +411,19 @@ info: B3: .quantifierExpr u #[.functionCall () u "f" - u #[.id () u 0], + u #[.id () 0], .functionCall () u "f" - u #[.id () u 0]]] + u #[.id () 0]]] (.binaryOp () (.gt ()) (.functionCall () u "f" - u #[.id () u 0]) - (.literal () (.intLit () u 0))) + u #[.id () 0]) + (.literal () (.intLit () 0))) --- info: forall x : int pattern f(x), f(x) f(x) > 0 -/ @@ -444,18 +441,13 @@ info: B3: .quantifierExpr u #[.unaryOp () (.not ()) - (.id () u 0)], - .pattern - () - u #[.id () u 0]] + (.id () 0)], + .pattern () u #[.id () 0]] (.binaryOp () (.or ()) - (.id () u 0) - (.unaryOp - () - (.not ()) - (.id () u 0))) + (.id () 0) + (.unaryOp () (.not ()) (.id () 0))) --- info: exists y : bool pattern y pattern !y y || !y -/ @@ -473,27 +465,21 @@ info: B3: .quantifierExpr u #[.binaryOp () (.mul ()) - (.id () u 0) - (.literal - () - (.intLit () u 2))], + (.id () 0) + (.literal () (.intLit () 2))], .pattern () u #[.binaryOp () (.add ()) - (.id () u 0) - (.literal - () - (.intLit () u 1))], - .pattern - () - u #[.id () u 0]] + (.id () 0) + (.literal () (.intLit () 1))], + .pattern () u #[.id () 0]] (.binaryOp () (.gt ()) - (.id () u 0) - (.literal () (.intLit () u 0))) + (.id () 0) + (.literal () (.intLit () 0))) --- info: forall z : int pattern z pattern z + 1 pattern z * 2 z > 0 -/ diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index 10e97f9d0..988ba5e5e 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -56,7 +56,7 @@ info: B3: .blockStmt .assign () u 0 - (.literal () (.intLit () u 42))] + (.literal () (.intLit () 42))] --- info: { @@ -73,8 +73,8 @@ info: B3: .check (.binaryOp () (.gt ()) - (.literal () (.intLit () u 5)) - (.literal () (.intLit () u 0))) + (.literal () (.intLit () 5)) + (.literal () (.intLit () 0))) --- info: check 5 > 0 @@ -88,8 +88,8 @@ info: B3: .assume (.binaryOp () (.ge ()) - (.literal () (.intLit () u 10)) - (.literal () (.intLit () u 0))) + (.literal () (.intLit () 10)) + (.literal () (.intLit () 0))) --- info: assume 10 >= 0 @@ -103,8 +103,8 @@ info: B3: .assert (.binaryOp () (.gt ()) - (.literal () (.intLit () u 5)) - (.literal () (.intLit () u 0))) + (.literal () (.intLit () 5)) + (.literal () (.intLit () 0))) --- info: assert 5 > 0 @@ -118,8 +118,8 @@ info: B3: .reach (.binaryOp () (.eq ()) - (.literal () (.intLit () u 5)) - (.literal () (.intLit () u 5))) + (.literal () (.intLit () 5)) + (.literal () (.intLit () 5))) --- info: reach 5 == 5 @@ -156,15 +156,11 @@ info: B3: .blockStmt u #[.assign () u 1 - (.literal - () - (.intLit () u 1)), + (.literal () (.intLit () 1)), .assign () u 0 - (.literal - () - (.intLit () u 2))]] + (.literal () (.intLit () 2))]] --- info: { @@ -196,19 +192,17 @@ info: B3: .blockStmt u none, .ifStmt () - (.id () u 1) + (.id () 1) (.assign () u 0 - (.literal () (.intLit () u 1))) + (.literal () (.intLit () 1))) u some (.blockStmt () u #[.assign () u 0 - (.literal - () - (.intLit () u 0))])] + (.literal () (.intLit () 0))])] --- info: { @@ -245,10 +239,8 @@ info: B3: .blockStmt (.binaryOp () (.add ()) - (.id () u 0) - (.literal - () - (.intLit () u 1)))])] + (.id () 0) + (.literal () (.intLit () 1)))])] --- info: { @@ -282,15 +274,13 @@ info: B3: .blockStmt u #[.binaryOp () (.ge ()) - (.id () u 1) - (.literal - () - (.intLit () u 0)), + (.id () 1) + (.literal () (.intLit () 0)), .binaryOp () (.le ()) - (.id () u 1) - (.id () u 0)] + (.id () 1) + (.id () 0)] (.blockStmt () u #[.assign @@ -299,10 +289,8 @@ info: B3: .blockStmt (.binaryOp () (.add ()) - (.id () u 1) - (.literal - () - (.intLit () u 1)))])] + (.id () 1) + (.literal () (.intLit () 1)))])] --- info: { @@ -343,7 +331,7 @@ info: B3: .labeledStmt .assign () u 0 - (.literal () (.intLit () u 0))]) + (.literal () (.intLit () 0))]) --- info: labeled_block: ⏎ { @@ -383,7 +371,7 @@ info: B3: .varDecl u "x" u some u "bool" u none - u some (.literal () (.boolLit () u true)) + u some (.literal () (.boolLit () true)) --- info: var x : bool := true @@ -397,7 +385,7 @@ info: B3: .varDecl u "y" u some u "bool" u none - u some (.literal () (.boolLit () u true)) + u some (.literal () (.boolLit () true)) --- info: var y : bool := true @@ -413,8 +401,8 @@ info: B3: .varDecl u some (.binaryOp () (.ge ()) - (.id () u 0) - (.literal () (.intLit () u 0))) + (.id () 0) + (.literal () (.intLit () 0))) u none --- info: @@ -435,8 +423,8 @@ info: B3: .aForall (.binaryOp () (.ge ()) - (.id () u 0) - (.literal () (.intLit () u 0)))]) + (.id () 0) + (.literal () (.intLit () 0)))]) --- info: forall x : int ⏎ @@ -461,9 +449,7 @@ info: B3: .choose .assign () u 0 - (.literal - () - (.intLit () u 2))], + (.literal () (.intLit () 2))], .blockStmt () u #[.varDecl @@ -475,9 +461,7 @@ info: B3: .choose .assign () u 0 - (.literal - () - (.intLit () u 1))]] + (.literal () (.intLit () 1))]] --- info: choose ⏎ @@ -515,27 +499,21 @@ info: B3: .blockStmt (.binaryOp () (.eq ()) - (.id () u 1) - (.literal - () - (.intLit () u 1))) + (.id () 1) + (.literal () (.intLit () 1))) (.blockStmt () u #[.assign () u 0 - (.literal - () - (.intLit () u 10))]), + (.literal () (.intLit () 10))]), .oneIfCase () (.binaryOp () (.eq ()) - (.id () u 1) - (.literal - () - (.intLit () u 2))) + (.id () 1) + (.literal () (.intLit () 2))) (.blockStmt () u #[.assign @@ -543,7 +521,7 @@ info: B3: .blockStmt u 0 (.literal () - (.intLit () u 20))])]] + (.intLit () 20))])]] --- info: { @@ -582,10 +560,8 @@ info: B3: .blockStmt () u "compute" u #[.callArgOut () u "result", - .callArgExpr () (.id () u 1), - .callArgExpr - () - (.id () u 0)]] + .callArgExpr () (.id () 1), + .callArgExpr () (.id () 0)]] --- info: { From d7a4de30e43a5cf668abb828727e6ff1181def91 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 11:43:12 -0600 Subject: [PATCH 06/24] Remove unnecessary isShadowed function The isOld flag is now computed directly in lookup, so isShadowed is not needed. --- Strata/Languages/B3/DDMConversion.lean | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean index d9e227a9a..5ad12bc9e 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMConversion.lean @@ -181,11 +181,6 @@ def lookup (ctx : ToCSTContext) (idx : Nat): String × Bool := | .none => (s!"@{idx}", false) --- Check if a variable at index idx is shadowed (has a later occurrence with same name) --- This is now computed in lookup, but kept for compatibility -def isShadowed (ctx : ToCSTContext) (idx : Nat) : Bool := - (ctx.lookup idx).2 - def push (ctx : ToCSTContext) (name : String) : ToCSTContext := { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } From bc77fffd96734681f417de36351944cd83b041ac Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 11:44:49 -0600 Subject: [PATCH 07/24] Remove unused inProcedure field from ToCSTContext The inProcedure field was never checked, so removed it along with enterProcedure function. --- Strata/Languages/B3/DDMConversion.lean | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMConversion.lean index 5ad12bc9e..90a01641b 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMConversion.lean @@ -148,7 +148,6 @@ section ToCST structure ToCSTContext where vars : List String - inProcedure : Bool := false namespace ToCSTContext @@ -182,12 +181,9 @@ def lookup (ctx : ToCSTContext) (idx : Nat): String × Bool := (s!"@{idx}", false) def push (ctx : ToCSTContext) (name : String) : ToCSTContext := - { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } - -def enterProcedure (ctx : ToCSTContext) : ToCSTContext := - { ctx with inProcedure := true } + { vars := name :: ctx.vars } -def empty : ToCSTContext := { vars := [], inProcedure := false } +def empty : ToCSTContext := { vars := [] } end ToCSTContext From 24a2aa7eefeeac085cb7ff9da807ff82c7a6f000 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 12:44:28 -0600 Subject: [PATCH 08/24] Move DDMConversion to DDMTransform/Conversion and remove SR duplication - Moved Strata/Languages/B3/DDMConversion.lean to DDMTransform/Conversion.lean - Removed entire AnnotationPreserving section with SR-suffixed functions - The non-SR functions with B3AnnFromCST M instance already preserve annotations - Eliminated ~500 lines of duplicated code - Updated all imports in test files --- .../Conversion.lean} | 517 ------------------ .../B3/DDMFormatDeclarationsTests.lean | 2 +- .../B3/DDMFormatExpressionsTests.lean | 2 +- .../Languages/B3/DDMFormatProgramsTests.lean | 2 +- .../B3/DDMFormatStatementsTests.lean | 2 +- StrataTest/Languages/B3/DDMFormatTests.lean | 2 +- 6 files changed, 5 insertions(+), 522 deletions(-) rename Strata/Languages/B3/{DDMConversion.lean => DDMTransform/Conversion.lean} (51%) diff --git a/Strata/Languages/B3/DDMConversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean similarity index 51% rename from Strata/Languages/B3/DDMConversion.lean rename to Strata/Languages/B3/DDMTransform/Conversion.lean index 90a01641b..57030f110 100644 --- a/Strata/Languages/B3/DDMConversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -566,521 +566,4 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.De end FromCST ---------------------------------------------------------------------- --- Annotation-Preserving Conversions (B3CST M ↔ B3AST M) ---------------------------------------------------------------------- - -section AnnotationPreserving - -structure ToCSTContextSR where - vars : List String - -namespace ToCSTContextSR - -def lookup (ctx : ToCSTContextSR) (idx : Nat): String × Bool := - match ctx.vars[idx]? with - | .some name => - if name == "" then (s!"@{idx}", false) else - -- Determine if this is an old value: first occurrence with shadowing - let isOld := ctx.vars.take idx |>.any (· == name) - let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := - let default := fun _: Unit => if pastIndex == 0 then name else s!"name@{pastIndex}" - if idx == 0 then default () - else - match vars with - | [] => default () - | otherName :: tail => - if name == otherName then go tail (pastIndex + 1) (idx - 1) - else go tail pastIndex (idx - 1) - (go ctx.vars 0 idx, isOld) - | .none => (s!"@{idx}", false) - -def push (ctx : ToCSTContextSR) (name : String) : ToCSTContextSR := - { vars := name :: ctx.vars } - -def empty : ToCSTContextSR := { vars := [] } - -end ToCSTContextSR - -structure FromCSTContextSR where - vars : List String - -namespace FromCSTContextSR - -def lookup (ctx : FromCSTContextSR) (name : String) : Nat := - ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length - -def lookupLast (ctx : FromCSTContextSR) (name : String) : Nat := - -- Find the last occurrence by searching from the end - let rec findLast (vars : List String) (idx : Nat) : Option Nat := - match vars with - | [] => none - | v :: vs => - match findLast vs (idx + 1) with - | some found => some found - | none => if v == name then some idx else none - findLast ctx.vars 0 |>.getD ctx.vars.length - -def push (ctx : FromCSTContextSR) (name : String) : FromCSTContextSR := - { vars := name :: ctx.vars } - -def empty : FromCSTContextSR := { vars := [] } - -end FromCSTContextSR - -/-! -## Annotation-Preserving Conversions - -These functions preserve M annotations when converting between B3CST and B3AST. -They duplicate the Unit-based conversions but thread M through all recursive calls. --/ - -mutual - -partial def literalToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ann : M) : B3AST.Literal M → B3CST.Expression M - | .intLit _ n => B3CST.Expression.natLit ann (mkAnn ann n) - | .boolLit _ b => if b then B3CST.Expression.btrue ann else B3CST.Expression.bfalse ann - | .stringLit _ s => B3CST.Expression.strLit ann (mkAnn ann s) - -partial def expressionToCSTSR [Inhabited $ Strata.B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Expression M → B3CST.Expression M - | .literal ann lit => literalToCSTSR ann lit - | .id ann idx => - let (name, isOld) := ctx.lookup idx - if isOld then - B3CST.Expression.old_id ann (mkAnn ann name) - else - B3CST.Expression.id ann (mkAnn ann name) - | .ite ann cond thn els => B3CST.Expression.ite ann (expressionToCSTSR ctx cond) (expressionToCSTSR ctx thn) (expressionToCSTSR ctx els) - | .binaryOp ann op lhs rhs => - let ctor := match op with - | .iff _ => B3CST.Expression.iff - | .implies _ => B3CST.Expression.implies - | .impliedBy _ => B3CST.Expression.impliedBy - | .and _ => B3CST.Expression.and - | .or _ => B3CST.Expression.or - | .eq _ => B3CST.Expression.equal - | .neq _ => B3CST.Expression.not_equal - | .lt _ => B3CST.Expression.lt - | .le _ => B3CST.Expression.le - | .ge _ => B3CST.Expression.ge - | .gt _ => B3CST.Expression.gt - | .add _ => B3CST.Expression.add - | .sub _ => B3CST.Expression.sub - | .mul _ => B3CST.Expression.mul - | .div _ => B3CST.Expression.div - | .mod _ => B3CST.Expression.mod - ctor ann (expressionToCSTSR ctx lhs) (expressionToCSTSR ctx rhs) - | .unaryOp ann op arg => - let ctor := match op with - | .not _ => B3CST.Expression.not - | .neg _ => B3CST.Expression.neg - ctor ann (expressionToCSTSR ctx arg) - | .functionCall ann fnName args => B3CST.Expression.functionCall ann (mkAnn ann fnName.val) (mkAnn ann (args.val.map (expressionToCSTSR ctx))) - | .labeledExpr ann label expr => B3CST.Expression.labeledExpr ann (mkAnn ann label.val) (expressionToCSTSR ctx expr) - | .letExpr ann var value body => - let ctx' := ctx.push var.val - B3CST.Expression.letExpr ann (mkAnn ann var.val) (expressionToCSTSR ctx value) (expressionToCSTSR ctx' body) - | .quantifierExpr ann qkind var ty patterns body => - let ctx' := ctx.push var.val - let convertPattern (p : Strata.B3AST.Pattern M) : B3CST.Pattern M := - match p with - | .pattern pann exprs => - let exprsCST := exprs.val.map (expressionToCSTSR ctx') - B3CST.Pattern.pattern pann (mkAnn pann exprsCST) - let patternsDDM := match patterns.val.toList with - | [] => none - | [p] => some (Patterns.patterns_single ann (convertPattern p)) - | p :: ps => - some (ps.foldl (init := Patterns.patterns_single ann (convertPattern p)) fun acc p => - Patterns.patterns_cons ann (convertPattern p) acc) - match qkind with - | .forall _ => - match patternsDDM with - | none => B3CST.Expression.forall_expr_no_patterns ann (mkAnn ann var.val) (mkAnn ann ty.val) (expressionToCSTSR ctx' body) - | some pats => B3CST.Expression.forall_expr ann (mkAnn ann var.val) (mkAnn ann ty.val) pats (expressionToCSTSR ctx' body) - | .exists _ => - match patternsDDM with - | none => B3CST.Expression.exists_expr_no_patterns ann (mkAnn ann var.val) (mkAnn ann ty.val) (expressionToCSTSR ctx' body) - | some pats => B3CST.Expression.exists_expr ann (mkAnn ann var.val) (mkAnn ann ty.val) pats (expressionToCSTSR ctx' body) - -partial def patternsToArraySR [Inhabited $ Strata.B3AST.Expression M] : B3CST.Patterns M → Array (B3CST.Pattern M) - | .patterns_single _ p => #[p] - | .patterns_cons _ p ps => patternsToArraySR ps |>.push p - -partial def expressionFromCSTSR [Inhabited $ Strata.B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.Expression M → Strata.B3AST.Expression M - | .natLit ann n => .literal ann (.intLit ann n.val) - | .strLit ann s => .literal ann (.stringLit ann s.val) - | .btrue ann => .literal ann (.boolLit ann true) - | .bfalse ann => .literal ann (.boolLit ann false) - | .id ann name => .id ann (ctx.lookup name.val) - | .old_id ann name => .id ann (ctx.lookupLast name.val) - | .not ann arg => .unaryOp ann (.not ann) (expressionFromCSTSR ctx arg) - | .neg ann arg => .unaryOp ann (.neg ann) (expressionFromCSTSR ctx arg) - | .iff ann lhs rhs => .binaryOp ann (.iff ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .implies ann lhs rhs => .binaryOp ann (.implies ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .impliedBy ann lhs rhs => .binaryOp ann (.impliedBy ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .and ann lhs rhs => .binaryOp ann (.and ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .or ann lhs rhs => .binaryOp ann (.or ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .equal ann lhs rhs => .binaryOp ann (.eq ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .not_equal ann lhs rhs => .binaryOp ann (.neq ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .lt ann lhs rhs => .binaryOp ann (.lt ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .le ann lhs rhs => .binaryOp ann (.le ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .ge ann lhs rhs => .binaryOp ann (.ge ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .gt ann lhs rhs => .binaryOp ann (.gt ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .add ann lhs rhs => .binaryOp ann (.add ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .sub ann lhs rhs => .binaryOp ann (.sub ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .mul ann lhs rhs => .binaryOp ann (.mul ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .div ann lhs rhs => .binaryOp ann (.div ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .mod ann lhs rhs => .binaryOp ann (.mod ann) (expressionFromCSTSR ctx lhs) (expressionFromCSTSR ctx rhs) - | .functionCall ann fn args => .functionCall ann (mkAnn ann fn.val) (mkAnn ann (args.val.map (expressionFromCSTSR ctx))) - | .labeledExpr ann label expr => .labeledExpr ann (mkAnn ann label.val) (expressionFromCSTSR ctx expr) - | .letExpr ann var value body => - let ctx' := ctx.push var.val - .letExpr ann (mkAnn ann var.val) (expressionFromCSTSR ctx value) (expressionFromCSTSR ctx' body) - | .ite ann cond thenExpr elseExpr => .ite ann (expressionFromCSTSR ctx cond) (expressionFromCSTSR ctx thenExpr) (expressionFromCSTSR ctx elseExpr) - | .forall_expr_no_patterns ann var ty body => - let ctx' := ctx.push var.val - .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromCSTSR ctx' body) - | .forall_expr ann var ty patterns body => - let ctx' := ctx.push var.val - let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := - match p with - | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromCSTSR ctx'))) - let patternsArray := patternsToArraySR patterns |>.map convertPattern - .quantifierExpr ann (.forall ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromCSTSR ctx' body) - | .exists_expr_no_patterns ann var ty body => - let ctx' := ctx.push var.val - .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann #[]) (expressionFromCSTSR ctx' body) - | .exists_expr ann var ty patterns body => - let ctx' := ctx.push var.val - let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := - match p with - | .pattern pann exprs => .pattern pann (mkAnn pann (exprs.val.map (expressionFromCSTSR ctx'))) - let patternsArray := patternsToArraySR patterns |>.map convertPattern - .quantifierExpr ann (.exists ann) (mkAnn ann var.val) (mkAnn ann ty.val) (mkAnn ann patternsArray) (expressionFromCSTSR ctx' body) - | .paren _ expr => expressionFromCSTSR ctx expr - -end - -namespace Expression - -def toAST [Inhabited $ Strata.B3AST.Expression M] (e : B3CST.Expression M) : Strata.B3AST.Expression M := - expressionFromCSTSR FromCSTContextSR.empty e - -def toCST [Inhabited $ Strata.B3CST.Expression M] (e : Strata.B3AST.Expression M) : B3CST.Expression M := - expressionToCSTSR ToCSTContextSR.empty e - -end Expression - -namespace Stmt - -mutual - -partial def callArgToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.CallArg M → B3CST.CallArg M - | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCSTSR ctx e) - | .callArgOut m id => B3CST.CallArg.call_arg_out m (mkAnn m id.val) - | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mkAnn m id.val) - -partial def buildChoiceBranchesSR : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M - | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) - | m, [b] => ChoiceBranches.choiceAtom m b - | m, b :: bs => ChoiceBranches.choicePush m (buildChoiceBranchesSR m bs) b - -partial def stmtToCSTSR [Inhabited (B3CST.Expression M)] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Statement M → B3CST.Statement M - | .varDecl m name ty autoinv init => - let ctx' := ctx.push name.val - match ty.val, autoinv.val, init.val with - | some t, some ai, some i => B3CST.Statement.var_decl_full m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx ai) (expressionToCSTSR ctx' i) - | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx ai) - | some t, none, some i => B3CST.Statement.var_decl_with_init m (mkAnn m name.val) (mkAnn m t.val) (expressionToCSTSR ctx' i) - | some t, none, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m t.val) - | none, _, some i => B3CST.Statement.var_decl_inferred m (mkAnn m name.val) (expressionToCSTSR ctx' i) - | none, _, none => B3CST.Statement.var_decl_typed m (mkAnn m name.val) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).fst) (expressionToCSTSR ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).fst) - | .blockStmt m stmts => - let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtToCSTSR ctx stmt - let ctx' := match stmt with - | .varDecl _ name _ _ _ => ctx.push name.val - | _ => ctx - (acc ++ [stmt'], ctx') - ) ([], ctx) - B3CST.Statement.block m (mkAnn m stmts'.toArray) - | .call m procName args => B3CST.Statement.call_statement m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgToCSTSR ctx) |>.toArray)) - | .check m expr => B3CST.Statement.check m (expressionToCSTSR ctx expr) - | .assume m expr => B3CST.Statement.assume m (expressionToCSTSR ctx expr) - | .reach m expr => B3CST.Statement.reach m (expressionToCSTSR ctx expr) - | .assert m expr => B3CST.Statement.assert m (expressionToCSTSR ctx expr) - | .aForall m var ty body => - let ctx' := ctx.push var.val - B3CST.Statement.aForall_statement m (mkAnn m var.val) (mkAnn m ty.val) (stmtToCSTSR ctx' body) - | .choose m branches => - let choiceBranches := branches.val.toList.map (fun s => ChoiceBranch.choice_branch m (stmtToCSTSR ctx s)) - B3CST.Statement.choose_statement m (buildChoiceBranchesSR m choiceBranches) - | .ifStmt m cond thenB elseB => - let elseCST := mapAnn (fun opt => opt.map (fun e => Else.else_some m (stmtToCSTSR ctx e))) elseB - B3CST.Statement.if_statement m (expressionToCSTSR ctx cond) (stmtToCSTSR ctx thenB) elseCST - | .ifCase m cases => - B3CST.Statement.if_case_statement m (mkAnn m (cases.val.toList.map (fun c => - match c with - | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCSTSR ctx cond) (stmtToCSTSR ctx body)) |>.toArray)) - | .loop m invariants body => - B3CST.Statement.loop_statement m (mkAnn m (invariants.val.toList.map (fun e => Invariant.invariant m (expressionToCSTSR ctx e)) |>.toArray)) (stmtToCSTSR ctx body) - | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mkAnn m label.val) (stmtToCSTSR ctx stmt) - | .exit m label => - B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) - | .returnStmt m => B3CST.Statement.return_statement m - | .probe m label => B3CST.Statement.probe m (mkAnn m label.val) - -partial def callArgFromCSTSR [Inhabited (B3AST.Expression M)] (ctx : FromCSTContextSR) : B3CST.CallArg M → Strata.B3AST.CallArg M - | .call_arg_expr m expr => .callArgExpr m (expressionFromCSTSR ctx expr) - | .call_arg_out m id => .callArgOut m (mkAnn m id.val) - | .call_arg_inout m id => .callArgInout m (mkAnn m id.val) - -partial def choiceBranchesToListSR : B3CST.ChoiceBranches M → List (B3CST.Statement M) - | .choiceAtom _ branch => - match branch with - | .choice_branch _ stmt => [stmt] - | .choicePush _ branches branch => - match branch with - | .choice_branch _ stmt => stmt :: choiceBranchesToListSR branches - -partial def stmtFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Statement M → Strata.B3AST.Statement M - | .var_decl_full m name ty autoinv init => - let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) (mkAnn m (some (expressionFromCSTSR ctx' init))) - | .var_decl_with_autoinv m name ty autoinv => - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) (mkAnn m none) - | .var_decl_with_init m name ty init => - let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) - | .var_decl_typed m name ty => - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m none) - | .var_decl_inferred m name init => - let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) - | .val_decl m name ty init => - let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m (some (mkAnn m ty.val))) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) - | .val_decl_inferred m name init => - let ctx' := ctx.push name.val - .varDecl m (mkAnn m name.val) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCSTSR ctx' init))) - | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCSTSR ctx rhs) - | .reinit_statement m v => - .reinit m (mkAnn m (ctx.lookup v.val)) - | .check m expr => - .check m (expressionFromCSTSR ctx expr) - | .assume m expr => - .assume m (expressionFromCSTSR ctx expr) - | .reach m expr => - .reach m (expressionFromCSTSR ctx expr) - | .assert m expr => - .assert m (expressionFromCSTSR ctx expr) - | .return_statement m => - .returnStmt m - | .block m stmts => - let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtFromCSTSR ctx stmt - let ctx' := match stmt with - | .var_decl_full _ name _ _ _ => ctx.push name.val - | .var_decl_with_autoinv _ name _ _ => ctx.push name.val - | .var_decl_with_init _ name _ _ => ctx.push name.val - | .var_decl_typed _ name _ => ctx.push name.val - | .var_decl_inferred _ name _ => ctx.push name.val - | .val_decl _ name _ _ => ctx.push name.val - | .val_decl_inferred _ name _ => ctx.push name.val - | _ => ctx - (acc ++ [stmt'], ctx') - ) ([], ctx) - .blockStmt m (mkAnn m stmts'.toArray) - | .if_statement m cond thenB elseB => - let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromCSTSR ctx stmt)) elseB - .ifStmt m (expressionFromCSTSR ctx cond) (stmtFromCSTSR ctx thenB) elseBranch - | .loop_statement m invs body => - let invariants := invs.val.toList.map fun inv => - match inv with - | .invariant _ expr => expressionFromCSTSR ctx expr - .loop m (mkAnn m invariants.toArray) (stmtFromCSTSR ctx body) - | .exit_statement m label => - .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) - | .labeled_statement m label stmt => - .labeledStmt m (mkAnn m label.val) (stmtFromCSTSR ctx stmt) - | .probe m label => - .probe m (mkAnn m label.val) - | .aForall_statement m var ty body => - let ctx' := ctx.push var.val - .aForall m (mkAnn m var.val) (mkAnn m ty.val) (stmtFromCSTSR ctx' body) - | .choose_statement m branches => - .choose m (mkAnn m (choiceBranchesToListSR branches |>.map (stmtFromCSTSR ctx)).toArray) - | .if_case_statement m cases => - .ifCase m (mkAnn m (cases.val.toList.map (fun case => - match case with - | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromCSTSR ctx cond) (stmtFromCSTSR ctx stmt)) |>.toArray)) - | .call_statement m procName args => - .call m (mkAnn m procName.val) (mkAnn m (args.val.toList.map (callArgFromCSTSR ctx) |>.toArray)) - -end - -def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (s : B3CST.Statement M) : Strata.B3AST.Statement M := - stmtFromCSTSR FromCSTContextSR.empty s - -def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (s : Strata.B3AST.Statement M) : B3CST.Statement M := - stmtToCSTSR ToCSTContextSR.empty s - -end Stmt - -namespace Decl - -mutual - -partial def fParameterToCSTSR (_ctx : ToCSTContextSR) : Strata.B3AST.FParameter M → B3CST.FParam M - | .fParameter m injective name ty => - let inj := mapAnn (fun b => if b then some (B3CST.Injective.injective_some m) else none) injective - B3CST.FParam.fparam m inj (mkAnn m name.val) (mkAnn m ty.val) - -partial def pParameterToCSTSR [Inhabited $ B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.PParameter M → B3CST.PParam M - | .pParameter m mode name ty autoinv => - let modeCST := match mode with - | .paramModeIn _ => mkAnn m none - | .paramModeOut _ => mkAnn m (some (B3CST.PParamMode.pmode_out m)) - | .paramModeInout _ => mkAnn m (some (B3CST.PParamMode.pmode_inout m)) - match autoinv.val with - | some ai => B3CST.PParam.pparam_with_autoinv m modeCST (mkAnn m name.val) (mkAnn m ty.val) (expressionToCSTSR ctx ai) - | none => B3CST.PParam.pparam m modeCST (mkAnn m name.val) (mkAnn m ty.val) - -partial def specToCSTSR [Inhabited $ B3CST.Expression M] (ctx : ToCSTContextSR) : Strata.B3AST.Spec M → B3CST.Spec M - | .specRequires m expr => B3CST.Spec.spec_requires m (expressionToCSTSR ctx expr) - | .specEnsures m expr => B3CST.Spec.spec_ensures m (expressionToCSTSR ctx expr) - -partial def declToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Decl M → B3CST.Decl M - | .typeDecl m name => - B3CST.Decl.type_decl m (mkAnn m name.val) - | .tagger m name forType => - B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) - | .function m name params resultType tag body => - let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) - let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx - let paramsCST := mkAnn m (params.val.toList.map (fParameterToCSTSR ctx) |>.toArray) - let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag - let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with - | .functionBody bm whens expr => - let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCSTSR ctx' e)) - B3CST.FunctionBody.function_body_some bm (mkAnn bm whensCST.toArray) (expressionToCSTSR ctx' expr))) body - B3CST.Decl.function_decl m (mkAnn m name.val) paramsCST (mkAnn m resultType.val) tagClause bodyCST - | .axiom m explains expr => - let explainsCST := mkAnn m (explains.val.toList.map (fun id => mkAnn m id.val) |>.toArray) - if explains.val.isEmpty then - B3CST.Decl.axiom_decl m (B3CST.AxiomBody.axiom m (expressionToCSTSR ctx expr)) - else - B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST (expressionToCSTSR ctx expr)) - | .procedure m name params specs body => - -- Build context: inout parameters need two entries (old and current) - let ctx' := params.val.toList.foldl (fun acc p => - match p with - | .pParameter _ mode pname _ _ => - match mode with - | .paramModeInout _ => acc.push s!"old {pname.val}" |>.push pname.val -- Push "old x" then "x" - | _ => acc.push pname.val - ) ctx - let paramsCST := mkAnn m (params.val.toList.map (pParameterToCSTSR ctx') |>.toArray) - let specsCST := specs.val.toList.map (specToCSTSR ctx') - let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (Stmt.stmtToCSTSR ctx' s))) body - B3CST.Decl.procedure_decl m (mkAnn m name.val) paramsCST (mkAnn m specsCST.toArray) bodyCST - -partial def fParameterFromCSTSR : B3CST.FParam M → Strata.B3AST.FParameter M - | .fparam m injective name ty => - let inj := match injective.val with - | some (.injective_some _) => true - | none => false - .fParameter m (mkAnn m inj) (mkAnn m name.val) (mkAnn m ty.val) - -partial def pParameterFromCSTSR [Inhabited $ B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.PParam M → Strata.B3AST.PParameter M - | .pparam m mode name ty => - let modeAST := match mode.val with - | none => Strata.B3AST.ParamMode.paramModeIn m - | some (.pmode_out _) => Strata.B3AST.ParamMode.paramModeOut m - | some (.pmode_inout _) => Strata.B3AST.ParamMode.paramModeInout m - .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m none) - | .pparam_with_autoinv m mode name ty autoinv => - let modeAST := match mode.val with - | none => Strata.B3AST.ParamMode.paramModeIn m - | some (.pmode_out _) => Strata.B3AST.ParamMode.paramModeOut m - | some (.pmode_inout _) => Strata.B3AST.ParamMode.paramModeInout m - .pParameter m modeAST (mkAnn m name.val) (mkAnn m ty.val) (mkAnn m (some (expressionFromCSTSR ctx autoinv))) - -partial def specFromCSTSR [Inhabited $ B3AST.Expression M] (ctx : FromCSTContextSR) : B3CST.Spec M → Strata.B3AST.Spec M - | .spec_requires m expr => .specRequires m (expressionFromCSTSR ctx expr) - | .spec_ensures m expr => .specEnsures m (expressionFromCSTSR ctx expr) - -partial def fparamsToListSR : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) - | ⟨_, arr⟩ => arr.toList - -partial def declFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Decl M → Strata.B3AST.Decl M - | .type_decl m name => - .typeDecl m (mkAnn m name.val) - | .tagger_decl m name forType => - .tagger m (mkAnn m name.val) (mkAnn m forType.val) - | .function_decl m name params resultType tag body => - let paramsAST := fparamsToListSR params |>.map fParameterFromCSTSR - let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) - let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx - let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with - | .function_body_some bm whens expr => - let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCSTSR ctx' e)) - B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromCSTSR ctx' expr))) body - .function m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m resultType.val) (mkAnn m tagAST) bodyAST - | .axiom_decl m axiomBody => - match axiomBody with - | .axiom _ expr => - .axiom m (mkAnn m #[]) (expressionFromCSTSR ctx expr) - | .explain_axiom _ names expr => - let namesAST := names.val.toList.map (fun n => mkAnn m n.val) - .axiom m (mkAnn m namesAST.toArray) (expressionFromCSTSR ctx expr) - | .procedure_decl m name params specs body => - -- Build context for parameters: inout parameters need two entries (old and current) - let ctx' := params.val.toList.foldl (fun acc p => - let (pname, mode) := match p with - | .pparam _ mode n _ => (n.val, mode.val) - | .pparam_with_autoinv _ mode n _ _ => (n.val, mode.val) - match mode with - | some (.pmode_inout _) => acc.push pname |>.push pname -- Push twice: old value, then current value - | _ => acc.push pname -- Push once for in/out parameters - ) ctx - -- Now convert all parameters with the full context (so autoinv can reference all params) - let paramsAST := params.val.toList.map (pParameterFromCSTSR ctx') - let specsAST := specs.val.toList.map (specFromCSTSR ctx') - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => Stmt.stmtFromCSTSR ctx' s)) body - .procedure m (mkAnn m name.val) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST - -end - -def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (d : B3CST.Decl M) : Strata.B3AST.Decl M := - declFromCSTSR FromCSTContextSR.empty d - -def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (d : Strata.B3AST.Decl M) : B3CST.Decl M := - declToCSTSR ToCSTContextSR.empty d - -end Decl - -namespace Program - -partial def programFromCSTSR [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (ctx : FromCSTContextSR) : B3CST.Program M → Strata.B3AST.Program M - | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declFromCSTSR ctx) |>.toArray)) - -partial def programToCSTSR [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (ctx : ToCSTContextSR) : Strata.B3AST.Program M → B3CST.Program M - | .program m decls => .program m (mkAnn m (decls.val.toList.map (Decl.declToCSTSR ctx) |>.toArray)) - -def toAST [Inhabited $ B3AST.Expression M] [Inhabited $ B3AST.Statement M] (p : B3CST.Program M) : Strata.B3AST.Program M := - programFromCSTSR FromCSTContextSR.empty p - -def toCST [Inhabited $ B3CST.Expression M] [Inhabited $ B3CST.Statement M] (p : Strata.B3AST.Program M) : B3CST.Program M := - programToCSTSR ToCSTContextSR.empty p - -end Program - -end AnnotationPreserving - end B3 diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 2b42c60d4..2bcd88c1e 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -5,7 +5,7 @@ -/ import StrataTest.Languages.B3.DDMFormatTests -import Strata.Languages.B3.DDMConversion +import Strata.Languages.B3.DDMTransform.Conversion namespace B3 diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index c6f2f3bbc..9ed33d976 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -5,7 +5,7 @@ -/ import StrataTest.Languages.B3.DDMFormatTests -import Strata.Languages.B3.DDMConversion +import Strata.Languages.B3.DDMTransform.Conversion namespace B3 diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean index d1652017c..eda14cc5a 100644 --- a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -5,7 +5,7 @@ -/ import StrataTest.Languages.B3.DDMFormatDeclarationsTests -import Strata.Languages.B3.DDMConversion +import Strata.Languages.B3.DDMTransform.Conversion namespace B3 diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index 988ba5e5e..fb67f53dc 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -5,7 +5,7 @@ -/ import StrataTest.Languages.B3.DDMFormatTests -import Strata.Languages.B3.DDMConversion +import Strata.Languages.B3.DDMTransform.Conversion namespace B3 diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index 22477dcd7..8b9b87249 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -6,7 +6,7 @@ import Strata.Languages.B3.DDMTransform.ParseCST import Strata.Languages.B3.DDMTransform.DefinitionAST -import Strata.Languages.B3.DDMConversion +import Strata.Languages.B3.DDMTransform.Conversion namespace B3 From 5a4749bf48ce2a0b924336041c824c016fabfa39 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 17 Dec 2025 13:10:08 -0600 Subject: [PATCH 09/24] Remove SR duplication and fix old() syntax - Removed all SR-suffixed functions (~500 lines) - Added missing ToCST helper functions (fParameterToCST, pParameterToCST, specToCST) - Updated tests to call B3.expressionFromCST/expressionToCST directly - Fixed old_id syntax to use name:0 to avoid parentheses - All conversions now preserve annotations using B3AnnFromCST M instance --- .../Languages/B3/DDMTransform/Conversion.lean | 105 ++++++++++++++---- .../Languages/B3/DDMTransform/ParseCST.lean | 2 +- .../B3/DDMFormatDeclarationsTests.lean | 8 +- .../B3/DDMFormatExpressionsTests.lean | 4 +- .../B3/DDMFormatStatementsTests.lean | 4 +- 5 files changed, 94 insertions(+), 29 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 57030f110..4c8a52f95 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -159,24 +159,29 @@ def lookup (ctx : ToCSTContext) (idx : Nat): String × Bool := let isOld := -- Check if there's a later occurrence (lower index) with the same name ctx.vars.take idx |>.any (· == name) - -- We need to resolve ambiguities - let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := - let default := fun _: Unit => if pastIndex == 0 then - name -- No ambiguity - else - s!"name@{pastIndex}" - if idx == 0 then - default () - else - match vars with - | [] => default () - | otherName :: tail => - if name == otherName then - go tail (pastIndex + 1) (idx - 1) + -- For old values, just return the name without disambiguation + -- For current values, check for ambiguity (excluding the old value entry) + if isOld then + (name, true) + else + -- We need to resolve ambiguities for non-old values + let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := + let default := fun _: Unit => if pastIndex == 0 then + name -- No ambiguity else - go tail pastIndex (idx - 1) - - (go ctx.vars 0 idx, isOld) + s!"name@{pastIndex}" + if idx == 0 then + default () + else + match vars with + | [] => default () + | otherName :: tail => + if name == otherName then + go tail (pastIndex + 1) (idx - 1) + else + go tail pastIndex (idx - 1) + + (go ctx.vars 0 idx, false) | .none => (s!"@{idx}", false) @@ -263,17 +268,17 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext | none => B3CST.Expression.exists_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (expressionToCST ctx' body) | some pats => B3CST.Expression.exists_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats (expressionToCST ctx' body) -partial def callArgToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M +partial def callArgToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCST ctx e) | .callArgOut m id => B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id) | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id) -partial def buildChoiceBranches [Inhabited M] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M +partial def buildChoiceBranches [Inhabited (B3CST.Expression M)] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) | m, [b] => ChoiceBranches.choiceAtom m b | m, b :: bs => ChoiceBranches.choicePush m (buildChoiceBranches m bs) b -partial def stmtToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.Statement M → B3CST.Statement M +partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Statement M → B3CST.Statement M | .varDecl m name ty autoinv init => let ctx' := ctx.push name.val match ty.val, autoinv.val, init.val with @@ -322,6 +327,63 @@ partial def stmtToCST [Inhabited M] (ctx : ToCSTContext) : Strata.B3AST.Statemen end +def fParameterToCST : Strata.B3AST.FParameter M → B3CST.FParam M + | .fParameter m injective name ty => + let inj := mapAnn (fun b => if b then some (B3CST.Injective.injective_some m) else none) injective + B3CST.FParam.fparam m inj (mkAnn m name.val) (mkAnn m ty.val) + +def pParameterToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.PParameter M → B3CST.PParam M + | .pParameter m mode name ty autoinv => + let modeCST := match mode with + | .paramModeIn _ => mkAnn m none + | .paramModeOut _ => mkAnn m (some (B3CST.PParamMode.pmode_out m)) + | .paramModeInout _ => mkAnn m (some (B3CST.PParamMode.pmode_inout m)) + match autoinv.val with + | some ai => B3CST.PParam.pparam_with_autoinv m modeCST (mkAnn m name.val) (mkAnn m ty.val) (expressionToCST ctx ai) + | none => B3CST.PParam.pparam m modeCST (mkAnn m name.val) (mkAnn m ty.val) + +def specToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.Spec M → B3CST.Spec M + | .specRequires m expr => B3CST.Spec.spec_requires m (expressionToCST ctx expr) + | .specEnsures m expr => B3CST.Spec.spec_ensures m (expressionToCST ctx expr) + +def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Decl M → B3CST.Decl M + | .typeDecl m name => + B3CST.Decl.type_decl m (mkAnn m name.val) + | .tagger m name forType => + B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) + | .function m name params resultType tag body => + let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) + let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx + let paramsCST := mkAnn m (params.val.toList.map fParameterToCST |>.toArray) + let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag + let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with + | .functionBody bm whens expr => + let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCST ctx' e)) + B3CST.FunctionBody.function_body_some bm (mkAnn bm whensCST.toArray) (expressionToCST ctx' expr))) body + B3CST.Decl.function_decl m (mkAnn m name.val) paramsCST (mkAnn m resultType.val) tagClause bodyCST + | .axiom m explains expr => + let explainsCST := mkAnn m (explains.val.toList.map (fun id => mkAnn m id.val) |>.toArray) + if explains.val.isEmpty then + B3CST.Decl.axiom_decl m (B3CST.AxiomBody.axiom m (expressionToCST ctx expr)) + else + B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST (expressionToCST ctx expr)) + | .procedure m name params specs body => + -- Build context: inout parameters need two entries (old and current) + let ctx' := params.val.toList.foldl (fun acc p => + match p with + | .pParameter _ mode pname _ _ => + match mode with + | .paramModeInout _ => acc.push pname.val |>.push pname.val -- Push twice for inout + | _ => acc.push pname.val + ) ctx + let paramsCST := mkAnn m (params.val.toList.map (pParameterToCST ctx') |>.toArray) + let specsCST := specs.val.toList.map (specToCST ctx') + let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (stmtToCST ctx' s))) body + B3CST.Decl.procedure_decl m (mkAnn m name.val) paramsCST (mkAnn m specsCST.toArray) bodyCST + +def programToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Program M → B3CST.Program M + | .program m decls => .program m (mkAnn m (decls.val.toList.map (declToCST ctx) |>.toArray)) + end ToCST --------------------------------------------------------------------- @@ -564,6 +626,9 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.De let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => stmtFromCST ctx' s)) body .procedure m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST +def programFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Program M → Strata.B3AST.Program M + | .program m decls => .program m (mkAnn m (decls.val.toList.map (declFromCST ctx) |>.toArray)) + end FromCST end B3 diff --git a/Strata/Languages/B3/DDMTransform/ParseCST.lean b/Strata/Languages/B3/DDMTransform/ParseCST.lean index 215a40470..efb6ead70 100644 --- a/Strata/Languages/B3/DDMTransform/ParseCST.lean +++ b/Strata/Languages/B3/DDMTransform/ParseCST.lean @@ -28,7 +28,7 @@ op strLit (s : Str) : Expression => s; op btrue : Expression => "true"; op bfalse : Expression => "false"; -op old_id (name : Ident) : Expression => "old " name; +op old_id (name : Ident) : Expression => "old " name:0; op id (name : Ident) : Expression => name; op letExpr (name : Ident, value : Expression, body : Expression) : Expression => diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 2bcd88c1e..6eebc0c35 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -16,13 +16,13 @@ open Strata.B3CST partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Decl.ofAst decl with | .ok cstDecl => - let b3Decl := Decl.toAST cstDecl + let b3Decl := B3.declFromCST B3.FromCSTContext.empty cstDecl let b3DeclUnit := b3Decl.toUnit let reprStr := (repr b3DeclUnit).pretty let reprStr := cleanupDeclRepr reprStr let reprStr := cleanupUnitRepr reprStr dbg_trace f!"B3: {reprStr}" - let cstDecl' := Decl.toCST b3Decl + let cstDecl' := B3.declToCST B3.ToCSTContext.empty b3Decl let cstAst := cstDecl'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" @@ -30,7 +30,7 @@ partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) (printIntermediate: Bool := true) : Format := match B3CST.Program.ofAst prog with | .ok cstProg => - let b3Prog := Program.toAST cstProg + let b3Prog := B3.programFromCST B3.FromCSTContext.empty cstProg dbg_trace (if printIntermediate then let b3ProgUnit := b3Prog.toUnit let reprStr := (repr b3ProgUnit).pretty @@ -40,7 +40,7 @@ partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatCont else f!"") - let cstProg' := Program.toCST b3Prog + let cstProg' := B3.programToCST B3.ToCSTContext.empty b3Prog let cstAst := cstProg'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index 9ed33d976..5f21e9b0f 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -18,13 +18,13 @@ open Strata.B3CST partial def doRoundtrip (e : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Expression.ofAst e with | .ok cstExpr => - let b3Expr := Expression.toAST cstExpr + let b3Expr := B3.expressionFromCST B3.FromCSTContext.empty cstExpr let b3ExprUnit := b3Expr.toUnit let reprStr := (repr b3ExprUnit).pretty let reprStr := cleanupExprRepr reprStr let reprStr := cleanupUnitRepr reprStr dbg_trace f!"B3: {reprStr}" - let cstExpr' := Expression.toCST b3Expr + let cstExpr' := B3.expressionToCST B3.ToCSTContext.empty b3Expr let cstAst := cstExpr'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index fb67f53dc..657e1a1b6 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -18,13 +18,13 @@ open Strata.B3CST partial def doRoundtripStmt (stmt : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Statement.ofAst stmt with | .ok cstStmt => - let b3Stmt := Stmt.toAST cstStmt + let b3Stmt := B3.stmtFromCST B3.FromCSTContext.empty cstStmt let b3StmtUnit := b3Stmt.toUnit let reprStr := (repr b3StmtUnit).pretty let reprStr := cleanupStmtRepr reprStr let reprStr := cleanupUnitRepr reprStr dbg_trace f!"B3: {reprStr}" - let cstStmt' := Stmt.toCST b3Stmt + let cstStmt' := B3.stmtToCST B3.ToCSTContext.empty b3Stmt let cstAst := cstStmt'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" From 3bc737d3e3c50d9d92d04fa63163b95d6bb6b5f7 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Thu, 18 Dec 2025 08:47:23 -0600 Subject: [PATCH 10/24] Use @[unwrap] metadata in ParseCST for terminals and fix autoinv context - Add @[unwrap] to terminal parameters in ParseCST.lean (Num, Str, Ident) to avoid unnecessary metadata wrapping, matching DefinitionAST pattern - Update Conversion.lean ToCST/FromCST to handle unwrapped terminals - Fix autoinv context: now uses ctx' (includes declared variable) instead of ctx - Update test expectations to reflect unwrapped terminal signatures - Delete unused files: Identifiers.lean and Examples/DDMTransform.lean --- .../Languages/B3/DDMTransform/Conversion.lean | 58 +++++++------- .../Languages/B3/DDMTransform/ParseCST.lean | 26 +++---- .../Languages/B3/Examples/DDMTransform.lean | 30 ------- Strata/Languages/B3/Identifiers.lean | 78 ------------------- .../B3/DDMFormatStatementsTests.lean | 2 +- StrataTest/Languages/B3/DDMFormatTests.lean | 8 +- 6 files changed, 47 insertions(+), 155 deletions(-) delete mode 100644 Strata/Languages/B3/Examples/DDMTransform.lean delete mode 100644 Strata/Languages/B3/Identifiers.lean diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 4c8a52f95..9875dc672 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -219,9 +219,9 @@ partial def unaryOpToCST [Inhabited (B3CST.Expression M)] : B3AST.UnaryOp M → | .neg _ => B3CST.Expression.neg partial def literalToCST [Inhabited (B3CST.Expression M)] : B3AST.Literal M → B3CST.Expression M - | .intLit m n => B3CST.Expression.natLit m (mkAnn m n) + | .intLit m n => B3CST.Expression.natLit m n | .boolLit m b => if b then B3CST.Expression.btrue m else B3CST.Expression.bfalse m - | .stringLit m s => B3CST.Expression.strLit m (mkAnn m s) + | .stringLit m s => B3CST.Expression.strLit m s partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : B3AST.Expression M → B3CST.Expression M | .literal _m lit => @@ -229,9 +229,9 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext | .id m idx => let (name, isOld) := ctx.lookup idx if isOld then - B3CST.Expression.old_id m (mkAnn m name) + B3CST.Expression.old_id m name else - B3CST.Expression.id m (mkAnn m name) + B3CST.Expression.id m name | .ite m cond thn els => B3CST.Expression.ite m (expressionToCST ctx cond) (expressionToCST ctx thn) (expressionToCST ctx els) | .binaryOp m op lhs rhs => @@ -270,8 +270,8 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext partial def callArgToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCST ctx e) - | .callArgOut m id => B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id) - | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id) + | .callArgOut m id => B3CST.CallArg.call_arg_out m id.val + | .callArgInout m id => B3CST.CallArg.call_arg_inout m id.val partial def buildChoiceBranches [Inhabited (B3CST.Expression M)] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) @@ -282,14 +282,14 @@ partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Stateme | .varDecl m name ty autoinv init => let ctx' := ctx.push name.val match ty.val, autoinv.val, init.val with - | some t, some ai, some i => B3CST.Statement.var_decl_full m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx ai) (expressionToCST ctx' i) - | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx ai) + | some t, some ai, some i => B3CST.Statement.var_decl_full m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' ai) (expressionToCST ctx' i) + | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' ai) | some t, none, some i => B3CST.Statement.var_decl_with_init m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' i) | some t, none, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val) | none, _, some i => B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) (expressionToCST ctx' i) | none, _, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).1) (expressionToCST ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).1) + | .assign m lhs rhs => B3CST.Statement.assign m (ctx.lookup lhs.val).1 (expressionToCST ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (ctx.lookup idx.val).1 | .blockStmt m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => let stmt' := stmtToCST ctx stmt @@ -319,11 +319,11 @@ partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Stateme | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCST ctx cond) (stmtToCST ctx body)) |>.toArray) cases) | .loop m invariants body => B3CST.Statement.loop_statement m (mapAnn (fun arr => arr.toList.map (fun e => Invariant.invariant m (expressionToCST ctx e)) |>.toArray) invariants) (stmtToCST ctx body) - | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mapAnn (fun x => x) label) (stmtToCST ctx stmt) + | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m label.val (stmtToCST ctx stmt) | .exit m label => - B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => l)) label) | .returnStmt m => B3CST.Statement.return_statement m - | .probe m label => B3CST.Statement.probe m (mapAnn (fun x => x) label) + | .probe m label => B3CST.Statement.probe m label.val end @@ -348,14 +348,14 @@ def specToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3A def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Decl M → B3CST.Decl M | .typeDecl m name => - B3CST.Decl.type_decl m (mkAnn m name.val) + B3CST.Decl.type_decl m name.val | .tagger m name forType => - B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) + B3CST.Decl.tagger_decl m name.val forType.val | .function m name params resultType tag body => let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx let paramsCST := mkAnn m (params.val.toList.map fParameterToCST |>.toArray) - let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag + let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m t.val)) tag let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with | .functionBody bm whens expr => let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCST ctx' e)) @@ -423,12 +423,12 @@ partial def patternsToArray [Inhabited M] : B3CST.Patterns M → Array (B3CST.Pa | .patterns_cons _ p ps => patternsToArray ps |>.push p partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Expression M → Strata.B3AST.Expression M - | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n.val) - | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s.val) + | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n) + | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s) | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) - | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name.val) - | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name.val) + | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name) + | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name) | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) @@ -477,8 +477,8 @@ partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTConte partial def callArgFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.CallArg M → Strata.B3AST.CallArg M | .call_arg_expr m expr => .callArgExpr m (expressionFromCST ctx expr) - | .call_arg_out m id => .callArgOut m (mapAnn (fun x => x) id) - | .call_arg_inout m id => .callArgInout m (mapAnn (fun x => x) id) + | .call_arg_out m id => .callArgOut m (mkAnn m id) + | .call_arg_inout m id => .callArgInout m (mkAnn m id) partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List (B3CST.Statement M) | .choiceAtom _ branch => @@ -509,9 +509,9 @@ partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : let ctx' := ctx.push name.val .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCST ctx rhs) + .assign m (mkAnn m (ctx.lookup lhs)) (expressionFromCST ctx rhs) | .reinit_statement m v => - .reinit m (mkAnn m (ctx.lookup v.val)) + .reinit m (mkAnn m (ctx.lookup v)) | .check m expr => .check m (expressionFromCST ctx expr) | .assume m expr => @@ -548,9 +548,9 @@ partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : | .exit_statement m label => .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) | .labeled_statement m label stmt => - .labeledStmt m (mapAnn (fun x => x) label) (stmtFromCST ctx stmt) + .labeledStmt m (mkAnn m label) (stmtFromCST ctx stmt) | .probe m label => - .probe m (mapAnn (fun x => x) label) + .probe m (mkAnn m label) | .aForall_statement m var ty body => let ctx' := ctx.push var.val .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromCST ctx' body) @@ -590,14 +590,14 @@ def fparamsToList : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Decl M → Strata.B3AST.Decl M | .type_decl m name => - .typeDecl m (mapAnn (fun x => x) name) + .typeDecl m (mkAnn m name) | .tagger_decl m name forType => - .tagger m (mapAnn (fun x => x) name) (mapAnn (fun x => x) forType) + .tagger m (mkAnn m name) (mkAnn m forType) | .function_decl m name params resultType tag body => let paramsAST := fparamsToList params |>.map fParameterFromCST let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx - let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) + let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id) let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .function_body_some bm whens expr => let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCST ctx' e)) diff --git a/Strata/Languages/B3/DDMTransform/ParseCST.lean b/Strata/Languages/B3/DDMTransform/ParseCST.lean index efb6ead70..1427eaf4c 100644 --- a/Strata/Languages/B3/DDMTransform/ParseCST.lean +++ b/Strata/Languages/B3/DDMTransform/ParseCST.lean @@ -22,14 +22,14 @@ category Expression; op not (e : Expression) : Expression => @[prec(35)] "!" e; -op natLit (n : Num) : Expression => n; -op strLit (s : Str) : Expression => s; +op natLit (@[unwrap] n : Num) : Expression => n; +op strLit (@[unwrap] s : Str) : Expression => s; op btrue : Expression => "true"; op bfalse : Expression => "false"; -op old_id (name : Ident) : Expression => "old " name:0; -op id (name : Ident) : Expression => name; +op old_id (@[unwrap] name : Ident) : Expression => "old " name:0; +op id (@[unwrap] name : Ident) : Expression => name; op letExpr (name : Ident, value : Expression, body : Expression) : Expression => @[prec(2)] "val " name " := " value:0 " " body:2; @@ -81,13 +81,13 @@ op exists_expr (var : Ident, ty : Ident, patterns : Patterns, body : Expression) category Statement; -op assign (v : Ident, e : Expression) : Statement => "\n" v:0 " := " e:0; -op reinit_statement (v : Ident) : Statement => "\nreinit " v:0; +op assign (@[unwrap] v : Ident, e : Expression) : Statement => "\n" v:0 " := " e:0; +op reinit_statement (@[unwrap] v : Ident) : Statement => "\nreinit " v:0; category CallArg; op call_arg_expr (e : Expression) : CallArg => e:0; -op call_arg_out (id : Ident) : CallArg => "out " id:0; -op call_arg_inout (id : Ident) : CallArg => "inout " id:0; +op call_arg_out (@[unwrap] id : Ident) : CallArg => "out " id:0; +op call_arg_inout (@[unwrap] id : Ident) : CallArg => "inout " id:0; op call_statement (proc : Ident, args : CommaSepBy CallArg) : Statement => "\n" proc "(" args ")"; @@ -112,9 +112,9 @@ op loop_statement (invs : Seq Invariant, body : Statement) : Statement => op exit_statement (label : Option Ident) : Statement => "\nexit " label:0 ; op return_statement () : Statement => "\nreturn"; -op labeled_statement (label : Ident, s : Statement) : Statement => label:0 ": " s:0; +op labeled_statement (@[unwrap] label : Ident, s : Statement) : Statement => label:0 ": " s:0; -op probe (name : Ident) : Statement => "\nprobe " name:0 ; +op probe (@[unwrap] name : Ident) : Statement => "\nprobe " name:0 ; op var_decl_full (name : Ident, ty : Ident, autoinv : Expression, init : Expression) : Statement => "\nvar " name:0 " : " ty:0 " autoinv " autoinv:0 " := " init:0 ; @@ -161,9 +161,9 @@ op block (c : Seq Statement) : Statement => "\n{" indent(2, c:0) "\n}"; category Decl; -op type_decl (name : Ident) : Decl => "\ntype " name:0; +op type_decl (@[unwrap] name : Ident) : Decl => "\ntype " name:0; -op tagger_decl (name : Ident, forType : Ident) : Decl => "\ntagger " name:0 " for " forType:0; +op tagger_decl (@[unwrap] name : Ident, @[unwrap] forType : Ident) : Decl => "\ntagger " name:0 " for " forType:0; category Injective; op injective_some () : Injective => "injective "; @@ -173,7 +173,7 @@ op fparam (injective : Option Injective, name : Ident, ty : Ident) : FParam => injective:0 name:0 " : " ty:0; category TagClause; -op tag_some (t : Ident) : TagClause => " tag " t:0; +op tag_some (@[unwrap] t : Ident) : TagClause => " tag " t:0; category WhenClause; op when_clause (e : Expression) : WhenClause => "\n when " e:0; diff --git a/Strata/Languages/B3/Examples/DDMTransform.lean b/Strata/Languages/B3/Examples/DDMTransform.lean deleted file mode 100644 index f2e5c67a5..000000000 --- a/Strata/Languages/B3/Examples/DDMTransform.lean +++ /dev/null @@ -1,30 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.DDMTransform.ParseCST -import Strata.Languages.B3.DDMTransform.DefinitionAST - ---------------------------------------------------------------------- -namespace Strata -set_option maxRecDepth 10000 - -/-! -## B3 DDM Dialect Example - -This file demonstrates the DDM dialect definition for B3. -The dialect is defined in `Strata/Languages/B3/DDMTransform/Parse.lean` -and the translation from DDM AST to B3 AST is in `Strata/Languages/B3/DDMTransform/Translate.lean`. - -The DDM dialect provides: -- Parser for B3 syntax -- Pretty-printer for B3 programs -- Translation to B3 abstract syntax tree - -Example usage would be with `#strata` blocks, similar to Boogie. --/ - -end Strata ---------------------------------------------------------------------- diff --git a/Strata/Languages/B3/Identifiers.lean b/Strata/Languages/B3/Identifiers.lean deleted file mode 100644 index 8cbf3d9bf..000000000 --- a/Strata/Languages/B3/Identifiers.lean +++ /dev/null @@ -1,78 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.DL.Lambda.LExprTypeEnv - -namespace B3 - -open Std - -/-- - Metadata for B3 identifiers. - For now, we use a simple unit type since B3 doesn't have scoping. --/ -inductive B3IdentifierMetadata where - | none -deriving DecidableEq, Repr - -instance : ToFormat B3IdentifierMetadata where - format - | .none => "" - -instance : ToString B3IdentifierMetadata where - toString v := toString $ ToFormat.format v - -abbrev B3Ident := Lambda.Identifier B3IdentifierMetadata -abbrev B3Label := String - -def B3IdentDec : DecidableEq B3Ident := inferInstanceAs (DecidableEq (Lambda.Identifier B3IdentifierMetadata)) - -@[match_pattern] -def B3Ident.mk (s : String) : B3Ident := ⟨s, B3IdentifierMetadata.none⟩ - -instance : Coe String B3Ident where - coe | s => .mk s - -def B3Ident.toPretty (x : B3Ident) : String := - match x with | ⟨s, _⟩ => s - -instance : ToFormat B3Ident where - format i := B3Ident.toPretty i - -instance : ToString B3Ident where - toString | ⟨s, v⟩ => (toString $ ToFormat.format v) ++ (toString $ ToFormat.format s) - -instance : Repr B3Ident where - reprPrec | ⟨s, v⟩, _ => (ToFormat.format v) ++ (ToFormat.format s) - -instance : Inhabited B3Ident where - default := ⟨"_", .none⟩ - -instance : Lambda.HasGen B3IdentifierMetadata where - genVar T := let (sym, state') := (Lambda.TState.genExprSym T.genState) - (B3Ident.mk sym, { T with genState := state' }) - -namespace Syntax - -open Lean Elab Meta Lambda.LExpr.SyntaxMono - -scoped syntax ident : lidentmono - -def elabB3Ident : Syntax → MetaM Expr - | `(lidentmono| $s:ident) => do - let s := toString s.getId - return ← mkAppM ``B3Ident.mk #[mkStrLit s] - | _ => throwUnsupportedSyntax - -instance : MkIdent B3IdentifierMetadata where - elabIdent := elabB3Ident - toExpr := .const ``B3IdentifierMetadata [] - -elab "b3[" e:lexprmono "]" : term => elabLExprMono (IDMeta:=B3IdentifierMetadata) e - -end Syntax - -end B3 diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index 657e1a1b6..ecdf8894c 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -406,7 +406,7 @@ info: B3: .varDecl u none --- info: -var z : int autoinv @0 >= 0 +var z : int autoinv z >= 0 -/ #guard_msgs in #eval roundtripStmt $ #strata program B3CST; var z : int autoinv z >= 0 #end diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index 8b9b87249..cb11abedc 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -19,12 +19,12 @@ info: inductive Strata.B3CST.Expression : Type → Type number of parameters: 1 constructors: Strata.B3CST.Expression.not : {α : Type} → α → Expression α → Expression α -Strata.B3CST.Expression.natLit : {α : Type} → α → Ann Nat α → Expression α -Strata.B3CST.Expression.strLit : {α : Type} → α → Ann String α → Expression α +Strata.B3CST.Expression.natLit : {α : Type} → α → Nat → Expression α +Strata.B3CST.Expression.strLit : {α : Type} → α → String → Expression α Strata.B3CST.Expression.btrue : {α : Type} → α → Expression α Strata.B3CST.Expression.bfalse : {α : Type} → α → Expression α -Strata.B3CST.Expression.old_id : {α : Type} → α → Ann String α → Expression α -Strata.B3CST.Expression.id : {α : Type} → α → Ann String α → Expression α +Strata.B3CST.Expression.old_id : {α : Type} → α → String → Expression α +Strata.B3CST.Expression.id : {α : Type} → α → String → Expression α Strata.B3CST.Expression.letExpr : {α : Type} → α → Ann String α → Expression α → Expression α → Expression α Strata.B3CST.Expression.labeledExpr : {α : Type} → α → Ann String α → Expression α → Expression α Strata.B3CST.Expression.ite : {α : Type} → α → Expression α → Expression α → Expression α → Expression α From bb16546f8b2a42452488a970c9279895b78acd00 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Thu, 18 Dec 2025 08:58:53 -0600 Subject: [PATCH 11/24] Fix @[unwrap] usage: only apply to single-element RHS terminals - Remove @[unwrap] from operators with multiple RHS elements or prefixes to preserve position information for sub-components - Keep @[unwrap] only for: natLit, strLit, id (single terminal on RHS) - Revert Conversion.lean changes for operators that should remain wrapped - Delete unused README.md from DDMTransform directory - Update test expectations to match corrected signatures --- .../Languages/B3/DDMTransform/Conversion.lean | 40 ++++++++--------- .../Languages/B3/DDMTransform/ParseCST.lean | 20 ++++----- Strata/Languages/B3/DDMTransform/README.md | 44 ------------------- StrataTest/Languages/B3/DDMFormatTests.lean | 2 +- 4 files changed, 31 insertions(+), 75 deletions(-) delete mode 100644 Strata/Languages/B3/DDMTransform/README.md diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 9875dc672..680d076f1 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -229,7 +229,7 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext | .id m idx => let (name, isOld) := ctx.lookup idx if isOld then - B3CST.Expression.old_id m name + B3CST.Expression.old_id m (mkAnn m name) else B3CST.Expression.id m name | .ite m cond thn els => @@ -270,8 +270,8 @@ partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext partial def callArgToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCST ctx e) - | .callArgOut m id => B3CST.CallArg.call_arg_out m id.val - | .callArgInout m id => B3CST.CallArg.call_arg_inout m id.val + | .callArgOut m id => B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id) + | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id) partial def buildChoiceBranches [Inhabited (B3CST.Expression M)] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) @@ -288,8 +288,8 @@ partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Stateme | some t, none, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val) | none, _, some i => B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) (expressionToCST ctx' i) | none, _, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (ctx.lookup lhs.val).1 (expressionToCST ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (ctx.lookup idx.val).1 + | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).1) (expressionToCST ctx rhs) + | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).1) | .blockStmt m stmts => let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => let stmt' := stmtToCST ctx stmt @@ -319,11 +319,11 @@ partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Stateme | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCST ctx cond) (stmtToCST ctx body)) |>.toArray) cases) | .loop m invariants body => B3CST.Statement.loop_statement m (mapAnn (fun arr => arr.toList.map (fun e => Invariant.invariant m (expressionToCST ctx e)) |>.toArray) invariants) (stmtToCST ctx body) - | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m label.val (stmtToCST ctx stmt) + | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mapAnn (fun x => x) label) (stmtToCST ctx stmt) | .exit m label => B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => l)) label) | .returnStmt m => B3CST.Statement.return_statement m - | .probe m label => B3CST.Statement.probe m label.val + | .probe m label => B3CST.Statement.probe m (mapAnn (fun x => x) label) end @@ -348,14 +348,14 @@ def specToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3A def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Decl M → B3CST.Decl M | .typeDecl m name => - B3CST.Decl.type_decl m name.val + B3CST.Decl.type_decl m (mkAnn m name.val) | .tagger m name forType => - B3CST.Decl.tagger_decl m name.val forType.val + B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) | .function m name params resultType tag body => let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx let paramsCST := mkAnn m (params.val.toList.map fParameterToCST |>.toArray) - let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m t.val)) tag + let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with | .functionBody bm whens expr => let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCST ctx' e)) @@ -428,7 +428,7 @@ partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTConte | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name) - | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name) + | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name.val) | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) @@ -477,8 +477,8 @@ partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTConte partial def callArgFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.CallArg M → Strata.B3AST.CallArg M | .call_arg_expr m expr => .callArgExpr m (expressionFromCST ctx expr) - | .call_arg_out m id => .callArgOut m (mkAnn m id) - | .call_arg_inout m id => .callArgInout m (mkAnn m id) + | .call_arg_out m id => .callArgOut m (mapAnn (fun x => x) id) + | .call_arg_inout m id => .callArgInout m (mapAnn (fun x => x) id) partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List (B3CST.Statement M) | .choiceAtom _ branch => @@ -509,9 +509,9 @@ partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : let ctx' := ctx.push name.val .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs)) (expressionFromCST ctx rhs) + .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCST ctx rhs) | .reinit_statement m v => - .reinit m (mkAnn m (ctx.lookup v)) + .reinit m (mkAnn m (ctx.lookup v.val)) | .check m expr => .check m (expressionFromCST ctx expr) | .assume m expr => @@ -548,9 +548,9 @@ partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : | .exit_statement m label => .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) | .labeled_statement m label stmt => - .labeledStmt m (mkAnn m label) (stmtFromCST ctx stmt) + .labeledStmt m (mapAnn (fun x => x) label) (stmtFromCST ctx stmt) | .probe m label => - .probe m (mkAnn m label) + .probe m (mapAnn (fun x => x) label) | .aForall_statement m var ty body => let ctx' := ctx.push var.val .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromCST ctx' body) @@ -590,14 +590,14 @@ def fparamsToList : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Decl M → Strata.B3AST.Decl M | .type_decl m name => - .typeDecl m (mkAnn m name) + .typeDecl m (mapAnn (fun x => x) name) | .tagger_decl m name forType => - .tagger m (mkAnn m name) (mkAnn m forType) + .tagger m (mapAnn (fun x => x) name) (mapAnn (fun x => x) forType) | .function_decl m name params resultType tag body => let paramsAST := fparamsToList params |>.map fParameterFromCST let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx - let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id) + let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .function_body_some bm whens expr => let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCST ctx' e)) diff --git a/Strata/Languages/B3/DDMTransform/ParseCST.lean b/Strata/Languages/B3/DDMTransform/ParseCST.lean index 1427eaf4c..0803f823e 100644 --- a/Strata/Languages/B3/DDMTransform/ParseCST.lean +++ b/Strata/Languages/B3/DDMTransform/ParseCST.lean @@ -28,7 +28,7 @@ op strLit (@[unwrap] s : Str) : Expression => s; op btrue : Expression => "true"; op bfalse : Expression => "false"; -op old_id (@[unwrap] name : Ident) : Expression => "old " name:0; +op old_id (name : Ident) : Expression => "old " name:0; op id (@[unwrap] name : Ident) : Expression => name; op letExpr (name : Ident, value : Expression, body : Expression) : Expression => @@ -81,13 +81,13 @@ op exists_expr (var : Ident, ty : Ident, patterns : Patterns, body : Expression) category Statement; -op assign (@[unwrap] v : Ident, e : Expression) : Statement => "\n" v:0 " := " e:0; -op reinit_statement (@[unwrap] v : Ident) : Statement => "\nreinit " v:0; +op assign (v : Ident, e : Expression) : Statement => "\n" v:0 " := " e:0; +op reinit_statement (v : Ident) : Statement => "\nreinit " v:0; category CallArg; op call_arg_expr (e : Expression) : CallArg => e:0; -op call_arg_out (@[unwrap] id : Ident) : CallArg => "out " id:0; -op call_arg_inout (@[unwrap] id : Ident) : CallArg => "inout " id:0; +op call_arg_out (id : Ident) : CallArg => "out " id:0; +op call_arg_inout (id : Ident) : CallArg => "inout " id:0; op call_statement (proc : Ident, args : CommaSepBy CallArg) : Statement => "\n" proc "(" args ")"; @@ -112,9 +112,9 @@ op loop_statement (invs : Seq Invariant, body : Statement) : Statement => op exit_statement (label : Option Ident) : Statement => "\nexit " label:0 ; op return_statement () : Statement => "\nreturn"; -op labeled_statement (@[unwrap] label : Ident, s : Statement) : Statement => label:0 ": " s:0; +op labeled_statement (label : Ident, s : Statement) : Statement => label:0 ": " s:0; -op probe (@[unwrap] name : Ident) : Statement => "\nprobe " name:0 ; +op probe (name : Ident) : Statement => "\nprobe " name:0 ; op var_decl_full (name : Ident, ty : Ident, autoinv : Expression, init : Expression) : Statement => "\nvar " name:0 " : " ty:0 " autoinv " autoinv:0 " := " init:0 ; @@ -161,9 +161,9 @@ op block (c : Seq Statement) : Statement => "\n{" indent(2, c:0) "\n}"; category Decl; -op type_decl (@[unwrap] name : Ident) : Decl => "\ntype " name:0; +op type_decl (name : Ident) : Decl => "\ntype " name:0; -op tagger_decl (@[unwrap] name : Ident, @[unwrap] forType : Ident) : Decl => "\ntagger " name:0 " for " forType:0; +op tagger_decl (name : Ident, forType : Ident) : Decl => "\ntagger " name:0 " for " forType:0; category Injective; op injective_some () : Injective => "injective "; @@ -173,7 +173,7 @@ op fparam (injective : Option Injective, name : Ident, ty : Ident) : FParam => injective:0 name:0 " : " ty:0; category TagClause; -op tag_some (@[unwrap] t : Ident) : TagClause => " tag " t:0; +op tag_some (t : Ident) : TagClause => " tag " t:0; category WhenClause; op when_clause (e : Expression) : WhenClause => "\n when " e:0; diff --git a/Strata/Languages/B3/DDMTransform/README.md b/Strata/Languages/B3/DDMTransform/README.md deleted file mode 100644 index 43de350ef..000000000 --- a/Strata/Languages/B3/DDMTransform/README.md +++ /dev/null @@ -1,44 +0,0 @@ -# B3 DDM Transform - -This directory contains the DDM (Dialect Definition Mechanism) support for the B3 language, providing parser and pretty-printer functionality. - -## Files - -### Parse.lean -Defines the B3 dialect using DDM syntax. This includes: -- Type declarations (bool, int, string) -- Expression operators (binary, unary, logical) -- Statement operators (assign, check, assume, assert, etc.) -- Control flow constructs (if, loop, exit, return) - -The dialect definition uses DDM's declarative syntax to specify: -- Operator precedence and associativity -- Pretty-printing format -- Parsing rules - -### Translate.lean -Provides translation from DDM's concrete syntax tree to B3's abstract syntax tree. This includes: -- Expression translation (literals, operators, variables) -- Statement translation (assignments, assertions, control flow) -- Type translation -- Binding management for scoped variables - -## Usage - -The DDM dialect can be used with `#strata` blocks (similar to Boogie) to parse B3 programs directly in Lean files. - -## Comparison with Boogie - -This implementation follows the same pattern as `Strata/Languages/Boogie/DDMTransform/`: -- `Parse.lean` defines the dialect syntax -- `Translate.lean` converts DDM AST to language-specific AST -- The structure is simplified for B3's smaller feature set - -## Current Limitations - -The current implementation provides a minimal working dialect with: -- Basic expression operators -- Core statement types -- Simple control flow - -Additional features from B3 (quantifiers, patterns, procedure calls, etc.) can be added incrementally by extending both Parse.lean and Translate.lean. diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index cb11abedc..47cb33633 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -23,7 +23,7 @@ Strata.B3CST.Expression.natLit : {α : Type} → α → Nat → Expression α Strata.B3CST.Expression.strLit : {α : Type} → α → String → Expression α Strata.B3CST.Expression.btrue : {α : Type} → α → Expression α Strata.B3CST.Expression.bfalse : {α : Type} → α → Expression α -Strata.B3CST.Expression.old_id : {α : Type} → α → String → Expression α +Strata.B3CST.Expression.old_id : {α : Type} → α → Ann String α → Expression α Strata.B3CST.Expression.id : {α : Type} → α → String → Expression α Strata.B3CST.Expression.letExpr : {α : Type} → α → Ann String α → Expression α → Expression α → Expression α Strata.B3CST.Expression.labeledExpr : {α : Type} → α → Ann String α → Expression α → Expression α From ee92f2777ee482d304af8f781f75904708dd9b38 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Thu, 18 Dec 2025 09:25:06 -0600 Subject: [PATCH 12/24] Remove unnecessary B3AnnFromCST methods for 1:1 metadata mappings - Remove annForId and annForIdValue from B3AnnFromCST typeclass - Use ann directly for .id case instead of calling annForId - B3AnnFromCST should only be used to extract multiple metadata from one, or combine multiple into one, not for 1:1 passthrough cases - Update typeclass documentation to clarify purpose --- .../Languages/B3/DDMTransform/Conversion.lean | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 680d076f1..9175fcaf8 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -32,19 +32,14 @@ open Strata.B3AST /-- Typeclass for creating annotations when converting CST → AST. -Methods are named specifically for where they're used. Each should be used exactly once. +Methods are used to extract multiple metadata from a single CST metadata, +or to combine multiple CST metadata into fewer AST metadata. -/ class B3AnnFromCST (α : Type) where /-- Used in: literal cases (.natLit, .strLit, .btrue, .bfalse) for .literal wrapper -/ annForLiteral : α → α /-- Used in: literal cases for the specific literal type (.intLit, .stringLit, .boolLit) -/ annForLiteralType : α → α - /-- Used in: literal cases for Ann wrapping the value -/ - annForLiteralValue : α → α - /-- Used in: .id case for .id wrapper -/ - annForId : α → α - /-- Used in: .id case for Ann wrapping the looked-up index -/ - annForIdValue : α → α /-- Used in: unary op cases (.not, .neg) for .unaryOp wrapper -/ annForUnaryOp : α → α /-- Used in: unary op cases for the op type (.not, .neg) -/ @@ -87,9 +82,6 @@ class B3AnnFromCST (α : Type) where instance : B3AnnFromCST Unit where annForLiteral _ := () annForLiteralType _ := () - annForLiteralValue _ := () - annForId _ := () - annForIdValue _ := () annForUnaryOp _ := () annForUnaryOpType _ := () annForBinaryOp _ := () @@ -113,9 +105,6 @@ instance : B3AnnFromCST Unit where instance : B3AnnFromCST M where annForLiteral := id annForLiteralType := id - annForLiteralValue := id - annForId := id - annForIdValue := id annForUnaryOp := id annForUnaryOpType := id annForBinaryOp := id @@ -427,8 +416,8 @@ partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTConte | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s) | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) - | .id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookup name) - | .old_id ann name => .id (B3AnnFromCST.annForId ann) (ctx.lookupLast name.val) + | .id ann name => .id ann (ctx.lookup name) + | .old_id ann name => .id ann (ctx.lookupLast name.val) | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) From 72b18958ad951e01cf7a558b95256c72c6f849c6 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Thu, 18 Dec 2025 09:48:50 -0600 Subject: [PATCH 13/24] Improve B3AnnFromCST documentation with specific metadata transformations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Document exact CST → AST metadata count for each method - Show which metadata are being extracted (1→2, 1→3, 1→5) - Make it clear why each method exists (AST needs more metadata than CST has) - Example: 'CST: .natLit ann n (1 metadata) → AST: .literal m (.intLit m2 n) (2 metadata)' --- .../Languages/B3/DDMTransform/Conversion.lean | 45 +++++++++---------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 9175fcaf8..6b1a35d55 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -32,51 +32,50 @@ open Strata.B3AST /-- Typeclass for creating annotations when converting CST → AST. -Methods are used to extract multiple metadata from a single CST metadata, -or to combine multiple CST metadata into fewer AST metadata. +Methods extract multiple metadata from a single CST metadata when AST needs more. -/ class B3AnnFromCST (α : Type) where - /-- Used in: literal cases (.natLit, .strLit, .btrue, .bfalse) for .literal wrapper -/ + /-- CST: `.natLit ann n` (1 metadata) → AST: `.literal m (.intLit m2 n)` (2 metadata). Extract for .literal wrapper. -/ annForLiteral : α → α - /-- Used in: literal cases for the specific literal type (.intLit, .stringLit, .boolLit) -/ + /-- CST: `.natLit ann n` (1 metadata) → AST: `.literal m (.intLit m2 n)` (2 metadata). Extract for .intLit/.stringLit/.boolLit. -/ annForLiteralType : α → α - /-- Used in: unary op cases (.not, .neg) for .unaryOp wrapper -/ + /-- CST: `.not ann arg` (1 metadata) → AST: `.unaryOp m (.not m2) arg` (2 metadata). Extract for .unaryOp wrapper. -/ annForUnaryOp : α → α - /-- Used in: unary op cases for the op type (.not, .neg) -/ + /-- CST: `.not ann arg` (1 metadata) → AST: `.unaryOp m (.not m2) arg` (2 metadata). Extract for .not/.neg. -/ annForUnaryOpType : α → α - /-- Used in: binary op cases for .binaryOp wrapper -/ + /-- CST: `.add ann lhs rhs` (1 metadata) → AST: `.binaryOp m (.add m2) lhs rhs` (2 metadata). Extract for .binaryOp wrapper. -/ annForBinaryOp : α → α - /-- Used in: binary op cases for the op type -/ + /-- CST: `.add ann lhs rhs` (1 metadata) → AST: `.binaryOp m (.add m2) lhs rhs` (2 metadata). Extract for .add/.sub/etc. -/ annForBinaryOpType : α → α - /-- Used in: .functionCall for wrapper -/ + /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for wrapper. -/ annForFunctionCall : α → α - /-- Used in: .functionCall for Ann wrapping function name -/ + /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for fn Ann. -/ annForFunctionCallName : α → α - /-- Used in: .functionCall for Ann wrapping args array -/ + /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for args Ann. -/ annForFunctionCallArgs : α → α - /-- Used in: .labeledExpr for wrapper -/ + /-- CST: `.labeledExpr ann label expr` (1 metadata) → AST: `.labeledExpr m ⟨m2, label⟩ expr` (2 metadata). Extract for wrapper. -/ annForLabeledExpr : α → α - /-- Used in: .labeledExpr for Ann wrapping label -/ + /-- CST: `.labeledExpr ann label expr` (1 metadata) → AST: `.labeledExpr m ⟨m2, label⟩ expr` (2 metadata). Extract for label Ann. -/ annForLabeledExprLabel : α → α - /-- Used in: .letExpr for wrapper -/ + /-- CST: `.letExpr ann var value body` (1 metadata) → AST: `.letExpr m ⟨m2, var⟩ value body` (2 metadata). Extract for wrapper. -/ annForLetExpr : α → α - /-- Used in: .letExpr for Ann wrapping var name -/ + /-- CST: `.letExpr ann var value body` (1 metadata) → AST: `.letExpr m ⟨m2, var⟩ value body` (2 metadata). Extract for var Ann. -/ annForLetExprVar : α → α - /-- Used in: .ite for wrapper -/ + /-- CST: `.ite ann cond thn els` (1 metadata) → AST: `.ite m cond thn els` (1 metadata). Passthrough (no extraction needed). -/ annForIte : α → α - /-- Used in: quantifier cases for .quantifierExpr wrapper -/ + /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for wrapper. -/ annForQuantifierExpr : α → α - /-- Used in: quantifier cases for quantifier kind (.forall, .exists) -/ + /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for .forall/.exists. -/ annForQuantifierKind : α → α - /-- Used in: quantifier cases for Ann wrapping var name -/ + /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for var Ann. -/ annForQuantifierVar : α → α - /-- Used in: quantifier cases for Ann wrapping type -/ + /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for ty Ann. -/ annForQuantifierType : α → α - /-- Used in: quantifier cases for Ann wrapping patterns array -/ + /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for patterns Ann. -/ annForQuantifierPatterns : α → α - /-- Used in: pattern case for .pattern wrapper -/ + /-- CST: `.pattern pann exprs` (1 metadata) → AST: `.pattern m ⟨m2, exprs⟩` (2 metadata). Extract for wrapper. -/ annForPattern : α → α - /-- Used in: pattern case for Ann wrapping expressions array -/ + /-- CST: `.pattern pann exprs` (1 metadata) → AST: `.pattern m ⟨m2, exprs⟩` (2 metadata). Extract for exprs Ann. -/ annForPatternExprs : α → α instance : B3AnnFromCST Unit where From d2a137e1ec2edc58e385b03d42c339bd0fd6e416 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Thu, 18 Dec 2025 09:51:20 -0600 Subject: [PATCH 14/24] Simplify B3AnnFromCST comments to be more concise MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Replace verbose CST→AST examples with short explanations - Focus on why: 'AST needs one extra metadata for X' - Group related methods with section comments - Much easier to read and understand at a glance --- .../Languages/B3/DDMTransform/Conversion.lean | 33 +++++++------------ 1 file changed, 12 insertions(+), 21 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 6b1a35d55..43dd6bd78 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -35,47 +35,38 @@ Typeclass for creating annotations when converting CST → AST. Methods extract multiple metadata from a single CST metadata when AST needs more. -/ class B3AnnFromCST (α : Type) where - /-- CST: `.natLit ann n` (1 metadata) → AST: `.literal m (.intLit m2 n)` (2 metadata). Extract for .literal wrapper. -/ + -- Literals: AST needs one extra metadata for the literal wrapper annForLiteral : α → α - /-- CST: `.natLit ann n` (1 metadata) → AST: `.literal m (.intLit m2 n)` (2 metadata). Extract for .intLit/.stringLit/.boolLit. -/ + -- Literals: AST needs one extra metadata for the literal type (.intLit/.stringLit/.boolLit) annForLiteralType : α → α - /-- CST: `.not ann arg` (1 metadata) → AST: `.unaryOp m (.not m2) arg` (2 metadata). Extract for .unaryOp wrapper. -/ + -- Unary ops: AST needs one extra metadata for the .unaryOp wrapper annForUnaryOp : α → α - /-- CST: `.not ann arg` (1 metadata) → AST: `.unaryOp m (.not m2) arg` (2 metadata). Extract for .not/.neg. -/ + -- Unary ops: AST needs one extra metadata for the op type (.not/.neg) annForUnaryOpType : α → α - /-- CST: `.add ann lhs rhs` (1 metadata) → AST: `.binaryOp m (.add m2) lhs rhs` (2 metadata). Extract for .binaryOp wrapper. -/ + -- Binary ops: AST needs one extra metadata for the .binaryOp wrapper annForBinaryOp : α → α - /-- CST: `.add ann lhs rhs` (1 metadata) → AST: `.binaryOp m (.add m2) lhs rhs` (2 metadata). Extract for .add/.sub/etc. -/ + -- Binary ops: AST needs one extra metadata for the op type (.add/.sub/etc) annForBinaryOpType : α → α - /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for wrapper. -/ + -- Function calls: AST needs two extra metadata for fn and args Anns annForFunctionCall : α → α - /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for fn Ann. -/ annForFunctionCallName : α → α - /-- CST: `.functionCall ann fn args` (1 metadata) → AST: `.functionCall m ⟨m2, fn⟩ ⟨m3, args⟩` (3 metadata). Extract for args Ann. -/ annForFunctionCallArgs : α → α - /-- CST: `.labeledExpr ann label expr` (1 metadata) → AST: `.labeledExpr m ⟨m2, label⟩ expr` (2 metadata). Extract for wrapper. -/ + -- Labeled expressions: AST needs one extra metadata for the label Ann annForLabeledExpr : α → α - /-- CST: `.labeledExpr ann label expr` (1 metadata) → AST: `.labeledExpr m ⟨m2, label⟩ expr` (2 metadata). Extract for label Ann. -/ annForLabeledExprLabel : α → α - /-- CST: `.letExpr ann var value body` (1 metadata) → AST: `.letExpr m ⟨m2, var⟩ value body` (2 metadata). Extract for wrapper. -/ + -- Let expressions: AST needs one extra metadata for the var Ann annForLetExpr : α → α - /-- CST: `.letExpr ann var value body` (1 metadata) → AST: `.letExpr m ⟨m2, var⟩ value body` (2 metadata). Extract for var Ann. -/ annForLetExprVar : α → α - /-- CST: `.ite ann cond thn els` (1 metadata) → AST: `.ite m cond thn els` (1 metadata). Passthrough (no extraction needed). -/ + -- If-then-else: AST has same metadata count (passthrough) annForIte : α → α - /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for wrapper. -/ + -- Quantifiers: AST needs four extra metadata for kind, var, ty, and patterns Anns annForQuantifierExpr : α → α - /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for .forall/.exists. -/ annForQuantifierKind : α → α - /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for var Ann. -/ annForQuantifierVar : α → α - /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for ty Ann. -/ annForQuantifierType : α → α - /-- CST: `.forall_expr ann var ty patterns body` (1 metadata) → AST: `.quantifierExpr m (.forall m2) ⟨m3, var⟩ ⟨m4, ty⟩ ⟨m5, patterns⟩ body` (5 metadata). Extract for patterns Ann. -/ annForQuantifierPatterns : α → α - /-- CST: `.pattern pann exprs` (1 metadata) → AST: `.pattern m ⟨m2, exprs⟩` (2 metadata). Extract for wrapper. -/ + -- Patterns: AST needs one extra metadata for the exprs Ann annForPattern : α → α - /-- CST: `.pattern pann exprs` (1 metadata) → AST: `.pattern m ⟨m2, exprs⟩` (2 metadata). Extract for exprs Ann. -/ annForPatternExprs : α → α instance : B3AnnFromCST Unit where From 124ef5cb1b96eff5ffb840a25b6fee1e76e59808 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 23 Dec 2025 08:38:56 -0600 Subject: [PATCH 15/24] feat(DDM): Support dots in identifiers - Add custom identifier character classification to allow dots - Include ? and ! suffixes for Lean naming conventions - Maintain compatibility with precedence annotations (:) - Add comprehensive tests for single and consecutive dots - Verify AST preservation and round-trip formatting --- Strata/DDM/Format.lean | 4 ++-- Strata/DDM/Parser.lean | 16 +++++++++++--- StrataTest/DDM/PipeIdent.lean | 39 +++++++++++++++++++++++++++++++++++ 3 files changed, 54 insertions(+), 5 deletions(-) diff --git a/Strata/DDM/Format.lean b/Strata/DDM/Format.lean index 7a62d4ebc..bf8ff4e90 100644 --- a/Strata/DDM/Format.lean +++ b/Strata/DDM/Format.lean @@ -24,10 +24,10 @@ private def isIdBegin (c : Char) : Bool := /-- Check if a character is valid for continuing a regular identifier. -Regular identifiers can contain letters, digits, underscores, and apostrophes. +Regular identifiers can contain letters, digits, underscores, apostrophes, dots, and Lean-style suffixes (? and !). -/ private def isIdContinue (c : Char) : Bool := - c.isAlphanum || c == '_' || c == '\'' + c.isAlphanum || c == '_' || c == '\'' || c == '.' || c == '?' || c == '!' /-- Check if a string needs pipe delimiters when formatted as an identifier. diff --git a/Strata/DDM/Parser.lean b/Strata/DDM/Parser.lean index e94b952d0..b21db7a56 100644 --- a/Strata/DDM/Parser.lean +++ b/Strata/DDM/Parser.lean @@ -122,8 +122,18 @@ def stringInputContext (fileName : System.FilePath) (contents : String) : InputC fileName := fileName.toString fileMap := FileMap.ofString contents +-- Custom identifier character classification for Strata DDM +-- Allows dots in identifiers (unlike Lean's default) +-- But excludes colons to preserve precedence syntax (e.g., "arg:40") +-- Includes ? and ! to match Lean's identifier conventions +private def strataIsIdFirst (c : Char) : Bool := + c.isAlpha || c == '_' + +private def strataIsIdRest (c : Char) : Bool := + c.isAlphanum || c == '_' || c == '\'' || c == '.' || c == '?' || c == '!' + private def isIdFirstOrBeginEscape (c : Char) : Bool := - isIdFirst c || isIdBeginEscape c + strataIsIdFirst c || isIdBeginEscape c private def isToken (idStartPos idStopPos : String.Pos.Raw) (tk : Option Token) : Bool := match tk with @@ -385,9 +395,9 @@ def identFnAux (startPos : String.Pos.Raw) (tk : Option Token) : ParserFn := fun let stopPart := s.pos let s := s.next' c s.pos h mkIdResult startPos tk startPart stopPart c s - else if isIdFirst curr then + else if strataIsIdFirst curr then let startPart := i - let s := takeWhileFn isIdRest c (s.next c i) + let s := takeWhileFn strataIsIdRest c (s.next c i) let stopPart := s.pos mkIdResult startPos tk startPart stopPart c s else diff --git a/StrataTest/DDM/PipeIdent.lean b/StrataTest/DDM/PipeIdent.lean index 2b95bd55c..e25764126 100644 --- a/StrataTest/DDM/PipeIdent.lean +++ b/StrataTest/DDM/PipeIdent.lean @@ -87,6 +87,28 @@ program PipeIdent; result := |x-value| | |y-value| | regularVar; #end).format +-- Identifiers with dots don't require pipe delimiters +/-- +info: program PipeIdent; +result := qualified.name + another.dotted.identifier + x.y; +-/ +#guard_msgs in +#eval (#strata +program PipeIdent; +result := qualified.name + another.dotted.identifier + x.y; +#end).format + +-- Identifiers with consecutive dots +/-- +info: program PipeIdent; +result := a..b + x...y + trailing..end; +-/ +#guard_msgs in +#eval (#strata +program PipeIdent; +result := a..b + x...y + trailing..end; +#end).format + -- Verify escape sequences are unescaped in AST (not just round-trip) def testEscapeAST := #strata program PipeIdent; @@ -109,6 +131,23 @@ def getRHSIdent (op : Operation) : String := -- Verify: \\ is unescaped to single \ in AST (stored with Lean's «» notation) #guard (getRHSIdent testEscapeAST.commands[1]!) == "«path\\to\\file»" +-- Verify dots are preserved in AST +def testDotIdent := #strata +program PipeIdent; +x := qualified.name; +y := another.dotted.identifier; +z := a..b; +w := x...y; +v := trailing..end; +#end + +-- Verify: dots are preserved in identifier names in AST (stored with Lean's «» notation) +#guard (getRHSIdent testDotIdent.commands[0]!) == "«qualified.name»" +#guard (getRHSIdent testDotIdent.commands[1]!) == "«another.dotted.identifier»" +#guard (getRHSIdent testDotIdent.commands[2]!) == "«a..b»" +#guard (getRHSIdent testDotIdent.commands[3]!) == "«x...y»" +#guard (getRHSIdent testDotIdent.commands[4]!) == "«trailing..end»" + -- Test dialect with | operator that has NO spaces in syntax definition #dialect dialect PipeIdentNoSpace; From 8c957720be205cc9bf68f0699a1627522379ce02 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 23 Dec 2025 09:34:46 -0600 Subject: [PATCH 16/24] Remove excessive comments --- Strata/DDM/Format.lean | 1 - Strata/DDM/Parser.lean | 4 ---- 2 files changed, 5 deletions(-) diff --git a/Strata/DDM/Format.lean b/Strata/DDM/Format.lean index bf8ff4e90..416a87fd7 100644 --- a/Strata/DDM/Format.lean +++ b/Strata/DDM/Format.lean @@ -24,7 +24,6 @@ private def isIdBegin (c : Char) : Bool := /-- Check if a character is valid for continuing a regular identifier. -Regular identifiers can contain letters, digits, underscores, apostrophes, dots, and Lean-style suffixes (? and !). -/ private def isIdContinue (c : Char) : Bool := c.isAlphanum || c == '_' || c == '\'' || c == '.' || c == '?' || c == '!' diff --git a/Strata/DDM/Parser.lean b/Strata/DDM/Parser.lean index b21db7a56..e60cafd91 100644 --- a/Strata/DDM/Parser.lean +++ b/Strata/DDM/Parser.lean @@ -122,10 +122,6 @@ def stringInputContext (fileName : System.FilePath) (contents : String) : InputC fileName := fileName.toString fileMap := FileMap.ofString contents --- Custom identifier character classification for Strata DDM --- Allows dots in identifiers (unlike Lean's default) --- But excludes colons to preserve precedence syntax (e.g., "arg:40") --- Includes ? and ! to match Lean's identifier conventions private def strataIsIdFirst (c : Char) : Bool := c.isAlpha || c == '_' From 569b509d0ecb1f58fd012931f6e89d8ed96f3ab4 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 23 Dec 2025 16:38:09 -0600 Subject: [PATCH 17/24] Refactor B3 conversion functions to eliminate code duplication - Updated all conversion functions to return (result, errors) tuples directly - Removed duplicate WithErrors wrapper functions (expressionFromCSTWithErrors, expressionToCSTWithErrors, programFromCSTWithErrors, programToCSTWithErrors) - Integrated error tracking into FromCSTContext.lookup and ToCSTContext.lookup - Updated all helper functions (callArgFromCST, stmtFromCST, declFromCST, etc.) to thread errors - Fixed bug: ToCSTContext.push now preserves inProcedure flag - Fixed bug: Old values in procedure contexts now correctly supported without errors - Fixed bug: Variable autoinv expressions now evaluated with variable in scope - Added ToString and ToFormat instances for error types - Updated format tests to display conversion errors in output - Fixed String.mk deprecation warnings (replaced with String.ofList) - Added DDMConversionErrorTests.lean for error tracking validation --- .../Languages/B3/DDMTransform/Conversion.lean | 818 +++++++++++++----- .../Languages/B3/DDMConversionErrorTests.lean | 117 +++ .../B3/DDMFormatDeclarationsTests.lean | 39 +- .../B3/DDMFormatExpressionsTests.lean | 24 +- .../B3/DDMFormatStatementsTests.lean | 18 +- StrataTest/Languages/B3/DDMFormatTests.lean | 10 +- 6 files changed, 786 insertions(+), 240 deletions(-) create mode 100644 StrataTest/Languages/B3/DDMConversionErrorTests.lean diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 43dd6bd78..b3ed72676 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -30,6 +30,74 @@ open Strata open Strata.B3CST open Strata.B3AST +--------------------------------------------------------------------- +-- Helper Instances +--------------------------------------------------------------------- + +instance : ToString SourceRange where + toString _sr := "" + +--------------------------------------------------------------------- +-- Conversion Errors +--------------------------------------------------------------------- + +/-- Errors that can occur during CST→AST conversion (parsing) -/ +inductive CSTToASTError (M : Type) where + | unresolvedIdentifier (name : String) (metadata : M) : CSTToASTError M + deriving Inhabited + +namespace CSTToASTError + +def toString [ToString M] : CSTToASTError M → String + | unresolvedIdentifier name _m => s!"Unresolved identifier '{name}'" + +instance [ToString M] : ToString (CSTToASTError M) where + toString := CSTToASTError.toString + +def toFormat [ToString M] : CSTToASTError M → Std.Format + | unresolvedIdentifier name _m => f!"Unresolved identifier '{name}'" + +instance [ToString M] : Std.ToFormat (CSTToASTError M) where + format := CSTToASTError.toFormat + +end CSTToASTError + +/-- Errors that can occur during AST→CST conversion (formatting) -/ +inductive ASTToCSTError (M : Type) where + | variableOutOfBounds (index : Nat) (contextSize : Nat) (metadata : M) : ASTToCSTError M + | unsupportedVariableReference (index : Nat) (metadata : M) : ASTToCSTError M + deriving Inhabited + +namespace ASTToCSTError + +def toString [ToString M] : ASTToCSTError M → String + | variableOutOfBounds idx size _m => + s!"Variable index @{idx} is out of bounds (context has {size} variables)" + | unsupportedVariableReference idx _m => + s!"Variable reference @{idx} not yet supported in concrete syntax. " ++ + s!"B3 concrete syntax currently only supports referencing the most recent variable " ++ + s!"or 'old' values in procedure contexts." + +instance [ToString M] : ToString (ASTToCSTError M) where + toString := ASTToCSTError.toString + +def toFormat [ToString M] : ASTToCSTError M → Std.Format + | variableOutOfBounds idx size _m => + f!"Variable index @{idx} is out of bounds (context has {size} variables)" + | unsupportedVariableReference idx _m => + f!"Variable reference @{idx} not yet supported in concrete syntax. " ++ + f!"B3 concrete syntax currently only supports referencing the most recent variable " ++ + f!"or 'old' values in procedure contexts." + +instance [ToString M] : Std.ToFormat (ASTToCSTError M) where + format := ASTToCSTError.toFormat + +end ASTToCSTError + +--------------------------------------------------------------------- +-- B3AnnFromCST Typeclass +--------------------------------------------------------------------- + /-- Typeclass for creating annotations when converting CST → AST. Methods extract multiple metadata from a single CST metadata when AST needs more. @@ -127,45 +195,90 @@ section ToCST structure ToCSTContext where vars : List String + inProcedure : Bool := false -- Track if we're in a procedure context (for "old" value support) namespace ToCSTContext -def lookup (ctx : ToCSTContext) (idx : Nat): String × Bool := +/-- +Check if a variable reference is supported in concrete syntax. +Supported cases: +- Index 0 (most recent variable) +- Variables with unique names (appear only once in context) +- Last occurrence of a variable (for "old" values in inout parameters) +NOT supported: +- Middle occurrences of shadowed variables +- "old" references outside procedure context (not yet implemented in B3) +-/ +def isSupported (ctx : ToCSTContext) (idx : Nat) : Bool := match ctx.vars[idx]? with + | .none => false | .some name => - if name == "" then (s!"@{idx}", false) else - -- Determine if this is an old value: first occurrence with shadowing - let isOld := - -- Check if there's a later occurrence (lower index) with the same name - ctx.vars.take idx |>.any (· == name) - -- For old values, just return the name without disambiguation - -- For current values, check for ambiguity (excluding the old value entry) - if isOld then - (name, true) + if idx == 0 then true -- Most recent variable always supported + else if name == "" then false -- Anonymous variable else - -- We need to resolve ambiguities for non-old values - let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := - let default := fun _: Unit => if pastIndex == 0 then - name -- No ambiguity - else - s!"name@{pastIndex}" - if idx == 0 then - default () + -- Check if this is the last (oldest) occurrence of the name + let isLastOccurrence := !(ctx.vars.drop (idx + 1)).any (· == name) + -- Check if this is a middle occurrence (has both earlier and later occurrences) + let hasEarlierOccurrence := (ctx.vars.take idx).any (· == name) + + if hasEarlierOccurrence && !isLastOccurrence then + false -- Middle occurrence - not supported + else if isLastOccurrence && hasEarlierOccurrence then + ctx.inProcedure -- Last occurrence with shadowing - supported only in procedure context + else + true -- Unique name - supported + +/-- Helper to resolve variable name disambiguation -/ +private def resolveVarName (vars : List String) (name : String) (idx : Nat) : String := + let rec go (vars: List String) (pastIndex: Nat) (idx: Nat): String := + let default := fun _: Unit => if pastIndex == 0 then + name -- No ambiguity + else + s!"name@{pastIndex}" + if idx == 0 then + default () + else + match vars with + | [] => default () + | otherName :: tail => + if name == otherName then + go tail (pastIndex + 1) (idx - 1) + else + go tail pastIndex (idx - 1) + go vars 0 idx + +def lookup (ctx : ToCSTContext) (idx : Nat) (m : M) : String × Bool × List (ASTToCSTError M) := + -- First check if index is out of bounds + if idx >= ctx.vars.length then + (s!"@{idx}", false, [.variableOutOfBounds idx ctx.vars.length m]) + else + match ctx.vars[idx]? with + | .some name => + if name == "" then (s!"@{idx}", false, []) else + -- Determine if this is an old value: first occurrence with shadowing + let isOld := + -- Check if there's a later occurrence (lower index) with the same name + ctx.vars.take idx |>.any (· == name) + -- Old values in procedure contexts are always supported + if isOld && ctx.inProcedure then + (name, true, []) + else + -- Check if this reference is supported in concrete syntax + if !ctx.isSupported idx then + -- Not supported - return error + let resolvedName := if isOld then name else resolveVarName ctx.vars name idx + (resolvedName, isOld, [.unsupportedVariableReference idx m]) else - match vars with - | [] => default () - | otherName :: tail => - if name == otherName then - go tail (pastIndex + 1) (idx - 1) - else - go tail pastIndex (idx - 1) - - (go ctx.vars 0 idx, false) - | .none => - (s!"@{idx}", false) + -- Supported - return without error + if isOld then + (name, true, []) + else + (resolveVarName ctx.vars name idx, false, []) + | .none => + (s!"@{idx}", false, [.variableOutOfBounds idx ctx.vars.length m]) def push (ctx : ToCSTContext) (name : String) : ToCSTContext := - { vars := name :: ctx.vars } + { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } def empty : ToCSTContext := { vars := [] } @@ -202,107 +315,183 @@ partial def literalToCST [Inhabited (B3CST.Expression M)] : B3AST.Literal M → | .boolLit m b => if b then B3CST.Expression.btrue m else B3CST.Expression.bfalse m | .stringLit m s => B3CST.Expression.strLit m s -partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : B3AST.Expression M → B3CST.Expression M +partial def expressionToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : B3AST.Expression M → B3CST.Expression M × List (ASTToCSTError M) | .literal _m lit => - literalToCST lit + (literalToCST lit, []) | .id m idx => - let (name, isOld) := ctx.lookup idx - if isOld then + let (name, isOld, errors) := ctx.lookup idx m + let cstExpr := if isOld then B3CST.Expression.old_id m (mkAnn m name) else B3CST.Expression.id m name + (cstExpr, errors) | .ite m cond thn els => - B3CST.Expression.ite m (expressionToCST ctx cond) (expressionToCST ctx thn) (expressionToCST ctx els) + let (cond', e1) := expressionToCST ctx cond + let (thn', e2) := expressionToCST ctx thn + let (els', e3) := expressionToCST ctx els + (B3CST.Expression.ite m cond' thn' els', e1 ++ e2 ++ e3) | .binaryOp m op lhs rhs => - (binaryOpToCST op) m (expressionToCST ctx lhs) (expressionToCST ctx rhs) + let (lhs', e1) := expressionToCST ctx lhs + let (rhs', e2) := expressionToCST ctx rhs + ((binaryOpToCST op) m lhs' rhs', e1 ++ e2) | .unaryOp m op arg => - (unaryOpToCST op) m (expressionToCST ctx arg) + let (arg', errs) := expressionToCST ctx arg + ((unaryOpToCST op) m arg', errs) | .functionCall m fnName args => - B3CST.Expression.functionCall m (mapAnn (fun x => x) fnName) (mapAnn (fun arr => arr.map (expressionToCST ctx)) args) + let (argsConverted, errors) := args.val.toList.foldl (fun (acc, errs) arg => + let (arg', e) := expressionToCST ctx arg + (acc ++ [arg'], errs ++ e) + ) ([], []) + (B3CST.Expression.functionCall m (mapAnn (fun x => x) fnName) (mapAnn (fun _ => argsConverted.toArray) args), errors) | .labeledExpr m label expr => - B3CST.Expression.labeledExpr m (mapAnn (fun x => x) label) (expressionToCST ctx expr) + let (expr', errs) := expressionToCST ctx expr + (B3CST.Expression.labeledExpr m (mapAnn (fun x => x) label) expr', errs) | .letExpr m var value body => let ctx' := ctx.push var.val - B3CST.Expression.letExpr m (mapAnn (fun x => x) var) (expressionToCST ctx value) (expressionToCST ctx' body) + let (value', e1) := expressionToCST ctx value + let (body', e2) := expressionToCST ctx' body + (B3CST.Expression.letExpr m (mapAnn (fun x => x) var) value' body', e1 ++ e2) | .quantifierExpr m qkind var ty patterns body => let ctx' := ctx.push var.val - let convertPattern (p : Strata.B3AST.Pattern M) : B3CST.Pattern M := + let convertPattern (p : Strata.B3AST.Pattern M) : B3CST.Pattern M × List (ASTToCSTError M) := match p with | .pattern pm exprs => - let exprsCST := exprs.val.map (expressionToCST ctx') - B3CST.Pattern.pattern pm (mkAnn pm exprsCST) - let patternsDDM := match patterns.val.toList with + let (exprsConverted, errors) := exprs.val.toList.foldl (fun (acc, errs) e => + let (e', err) := expressionToCST ctx' e + (acc ++ [e'], errs ++ err) + ) ([], []) + (B3CST.Pattern.pattern pm (mkAnn pm exprsConverted.toArray), errors) + let (patternsConverted, patternErrors) := patterns.val.toList.foldl (fun (acc, errs) p => + let (p', e) := convertPattern p + (acc ++ [p'], errs ++ e) + ) ([], []) + let patternsDDM := match patternsConverted with | [] => none - | [p] => some (Patterns.patterns_single m (convertPattern p)) + | [p] => some (Patterns.patterns_single m p) | p :: ps => - some (ps.foldl (init := Patterns.patterns_single m (convertPattern p)) fun acc p => - Patterns.patterns_cons m (convertPattern p) acc) - match qkind with + some (ps.foldl (init := Patterns.patterns_single m p) fun acc p => + Patterns.patterns_cons m p acc) + let (body', bodyErrs) := expressionToCST ctx' body + let result := match qkind with | .forall _qm => match patternsDDM with - | none => B3CST.Expression.forall_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (expressionToCST ctx' body) - | some pats => B3CST.Expression.forall_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats (expressionToCST ctx' body) + | none => B3CST.Expression.forall_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) body' + | some pats => B3CST.Expression.forall_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats body' | .exists _qm => match patternsDDM with - | none => B3CST.Expression.exists_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (expressionToCST ctx' body) - | some pats => B3CST.Expression.exists_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats (expressionToCST ctx' body) + | none => B3CST.Expression.exists_expr_no_patterns m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) body' + | some pats => B3CST.Expression.exists_expr m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) pats body' + (result, patternErrors ++ bodyErrs) -partial def callArgToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M - | .callArgExpr m e => B3CST.CallArg.call_arg_expr m (expressionToCST ctx e) - | .callArgOut m id => B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id) - | .callArgInout m id => B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id) +partial def callArgToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.CallArg M → B3CST.CallArg M × List (ASTToCSTError M) + | .callArgExpr m e => + let (e', errs) := expressionToCST ctx e + (B3CST.CallArg.call_arg_expr m e', errs) + | .callArgOut m id => (B3CST.CallArg.call_arg_out m (mapAnn (fun x => x) id), []) + | .callArgInout m id => (B3CST.CallArg.call_arg_inout m (mapAnn (fun x => x) id), []) partial def buildChoiceBranches [Inhabited (B3CST.Expression M)] : M → List (B3CST.ChoiceBranch M) → B3CST.ChoiceBranches M | m, [] => ChoiceBranches.choiceAtom m (ChoiceBranch.choice_branch m (B3CST.Statement.return_statement m)) | m, [b] => ChoiceBranches.choiceAtom m b | m, b :: bs => ChoiceBranches.choicePush m (buildChoiceBranches m bs) b -partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Statement M → B3CST.Statement M +partial def stmtToCST [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Statement M → B3CST.Statement M × List (ASTToCSTError M) | .varDecl m name ty autoinv init => let ctx' := ctx.push name.val match ty.val, autoinv.val, init.val with - | some t, some ai, some i => B3CST.Statement.var_decl_full m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' ai) (expressionToCST ctx' i) - | some t, some ai, none => B3CST.Statement.var_decl_with_autoinv m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' ai) - | some t, none, some i => B3CST.Statement.var_decl_with_init m (mapAnn (fun x => x) name) (mkAnn m t.val) (expressionToCST ctx' i) - | some t, none, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val) - | none, _, some i => B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) (expressionToCST ctx' i) - | none, _, none => B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown") - | .assign m lhs rhs => B3CST.Statement.assign m (mkAnn m (ctx.lookup lhs.val).1) (expressionToCST ctx rhs) - | .reinit m idx => B3CST.Statement.reinit_statement m (mkAnn m (ctx.lookup idx.val).1) + | some t, some ai, some i => + let (ai', e1) := expressionToCST ctx' ai + let (i', e2) := expressionToCST ctx' i + (B3CST.Statement.var_decl_full m (mapAnn (fun x => x) name) (mkAnn m t.val) ai' i', e1 ++ e2) + | some t, some ai, none => + let (ai', errs) := expressionToCST ctx' ai + (B3CST.Statement.var_decl_with_autoinv m (mapAnn (fun x => x) name) (mkAnn m t.val) ai', errs) + | some t, none, some i => + let (i', errs) := expressionToCST ctx' i + (B3CST.Statement.var_decl_with_init m (mapAnn (fun x => x) name) (mkAnn m t.val) i', errs) + | some t, none, none => + (B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m t.val), []) + | none, _, some i => + let (i', errs) := expressionToCST ctx' i + (B3CST.Statement.var_decl_inferred m (mapAnn (fun x => x) name) i', errs) + | none, _, none => + (B3CST.Statement.var_decl_typed m (mapAnn (fun x => x) name) (mkAnn m "unknown"), []) + | .assign m lhs rhs => + let (name, _, e1) := ctx.lookup lhs.val m + let (rhs', e2) := expressionToCST ctx rhs + (B3CST.Statement.assign m (mkAnn m name) rhs', e1 ++ e2) + | .reinit m idx => + let (name, _, errs) := ctx.lookup idx.val m + (B3CST.Statement.reinit_statement m (mkAnn m name), errs) | .blockStmt m stmts => - let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtToCST ctx stmt + let (stmts', _, errors) := stmts.val.toList.foldl (fun (acc, ctx, errs) stmt => + let (stmt', e) := stmtToCST ctx stmt let ctx' := match stmt with | .varDecl _ name _ _ _ => ctx.push name.val | _ => ctx - (acc ++ [stmt'], ctx') - ) ([], ctx) - B3CST.Statement.block m (mkAnn m stmts'.toArray) - | .call m procName args => B3CST.Statement.call_statement m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgToCST ctx) |>.toArray) args) - | .check m expr => B3CST.Statement.check m (expressionToCST ctx expr) - | .assume m expr => B3CST.Statement.assume m (expressionToCST ctx expr) - | .reach m expr => B3CST.Statement.reach m (expressionToCST ctx expr) - | .assert m expr => B3CST.Statement.assert m (expressionToCST ctx expr) + (acc ++ [stmt'], ctx', errs ++ e) + ) ([], ctx, []) + (B3CST.Statement.block m (mkAnn m stmts'.toArray), errors) + | .call m procName args => + let (argsConverted, errors) := args.val.toList.foldl (fun (acc, errs) arg => + let (arg', e) := callArgToCST ctx arg + (acc ++ [arg'], errs ++ e) + ) ([], []) + (B3CST.Statement.call_statement m (mapAnn (fun x => x) procName) (mapAnn (fun _ => argsConverted.toArray) args), errors) + | .check m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Statement.check m expr', errs) + | .assume m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Statement.assume m expr', errs) + | .reach m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Statement.reach m expr', errs) + | .assert m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Statement.assert m expr', errs) | .aForall m var ty body => let ctx' := ctx.push var.val - B3CST.Statement.aForall_statement m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtToCST ctx' body) + let (body', errs) := stmtToCST ctx' body + (B3CST.Statement.aForall_statement m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) body', errs) | .choose m branches => - let choiceBranches := branches.val.toList.map (fun s => ChoiceBranch.choice_branch m (stmtToCST ctx s)) - B3CST.Statement.choose_statement m (buildChoiceBranches m choiceBranches) + let (choiceBranches, errors) := branches.val.toList.foldl (fun (acc, errs) s => + let (s', e) := stmtToCST ctx s + (acc ++ [ChoiceBranch.choice_branch m s'], errs ++ e) + ) ([], []) + (B3CST.Statement.choose_statement m (buildChoiceBranches m choiceBranches), errors) | .ifStmt m cond thenB elseB => - let elseCST := mapAnn (fun opt => opt.map (fun e => Else.else_some m (stmtToCST ctx e))) elseB - B3CST.Statement.if_statement m (expressionToCST ctx cond) (stmtToCST ctx thenB) elseCST + let (cond', e1) := expressionToCST ctx cond + let (then', e2) := stmtToCST ctx thenB + let (elseBranch, e3) := match elseB.val with + | some e => + let (e', err) := stmtToCST ctx e + (some (Else.else_some m e'), err) + | none => (none, []) + (B3CST.Statement.if_statement m cond' then' (mapAnn (fun _ => elseBranch) elseB), e1 ++ e2 ++ e3) | .ifCase m cases => - B3CST.Statement.if_case_statement m (mapAnn (fun arr => arr.toList.map (fun c => + let (casesConverted, errors) := cases.val.toList.foldl (fun (acc, errs) c => match c with - | .oneIfCase cm cond body => IfCaseBranch.if_case_branch cm (expressionToCST ctx cond) (stmtToCST ctx body)) |>.toArray) cases) + | .oneIfCase cm cond body => + let (cond', e1) := expressionToCST ctx cond + let (body', e2) := stmtToCST ctx body + (acc ++ [IfCaseBranch.if_case_branch cm cond' body'], errs ++ e1 ++ e2) + ) ([], []) + (B3CST.Statement.if_case_statement m (mapAnn (fun _ => casesConverted.toArray) cases), errors) | .loop m invariants body => - B3CST.Statement.loop_statement m (mapAnn (fun arr => arr.toList.map (fun e => Invariant.invariant m (expressionToCST ctx e)) |>.toArray) invariants) (stmtToCST ctx body) - | .labeledStmt m label stmt => B3CST.Statement.labeled_statement m (mapAnn (fun x => x) label) (stmtToCST ctx stmt) + let (invs, invErrors) := invariants.val.toList.foldl (fun (acc, errs) e => + let (e', err) := expressionToCST ctx e + (acc ++ [Invariant.invariant m e'], errs ++ err) + ) ([], []) + let (body', bodyErrs) := stmtToCST ctx body + (B3CST.Statement.loop_statement m (mkAnn m invs.toArray) body', invErrors ++ bodyErrs) + | .labeledStmt m label stmt => + let (stmt', errs) := stmtToCST ctx stmt + (B3CST.Statement.labeled_statement m (mapAnn (fun x => x) label) stmt', errs) | .exit m label => - B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => l)) label) - | .returnStmt m => B3CST.Statement.return_statement m - | .probe m label => B3CST.Statement.probe m (mapAnn (fun x => x) label) + (B3CST.Statement.exit_statement m (mapAnn (fun opt => opt.map (fun l => l)) label), []) + | .returnStmt m => (B3CST.Statement.return_statement m, []) + | .probe m label => (B3CST.Statement.probe m (mapAnn (fun x => x) label), []) end @@ -311,41 +500,55 @@ def fParameterToCST : Strata.B3AST.FParameter M → B3CST.FParam M let inj := mapAnn (fun b => if b then some (B3CST.Injective.injective_some m) else none) injective B3CST.FParam.fparam m inj (mkAnn m name.val) (mkAnn m ty.val) -def pParameterToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.PParameter M → B3CST.PParam M +def pParameterToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.PParameter M → B3CST.PParam M × List (ASTToCSTError M) | .pParameter m mode name ty autoinv => let modeCST := match mode with | .paramModeIn _ => mkAnn m none | .paramModeOut _ => mkAnn m (some (B3CST.PParamMode.pmode_out m)) | .paramModeInout _ => mkAnn m (some (B3CST.PParamMode.pmode_inout m)) match autoinv.val with - | some ai => B3CST.PParam.pparam_with_autoinv m modeCST (mkAnn m name.val) (mkAnn m ty.val) (expressionToCST ctx ai) - | none => B3CST.PParam.pparam m modeCST (mkAnn m name.val) (mkAnn m ty.val) - -def specToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.Spec M → B3CST.Spec M - | .specRequires m expr => B3CST.Spec.spec_requires m (expressionToCST ctx expr) - | .specEnsures m expr => B3CST.Spec.spec_ensures m (expressionToCST ctx expr) - -def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Decl M → B3CST.Decl M + | some ai => + let (ai', errs) := expressionToCST ctx ai + (B3CST.PParam.pparam_with_autoinv m modeCST (mkAnn m name.val) (mkAnn m ty.val) ai', errs) + | none => (B3CST.PParam.pparam m modeCST (mkAnn m name.val) (mkAnn m ty.val), []) + +def specToCST [Inhabited (B3CST.Expression M)] (ctx : ToCSTContext) : Strata.B3AST.Spec M → B3CST.Spec M × List (ASTToCSTError M) + | .specRequires m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Spec.spec_requires m expr', errs) + | .specEnsures m expr => + let (expr', errs) := expressionToCST ctx expr + (B3CST.Spec.spec_ensures m expr', errs) + +def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Decl M → B3CST.Decl M × List (ASTToCSTError M) | .typeDecl m name => - B3CST.Decl.type_decl m (mkAnn m name.val) + (B3CST.Decl.type_decl m (mkAnn m name.val), []) | .tagger m name forType => - B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val) + (B3CST.Decl.tagger_decl m (mkAnn m name.val) (mkAnn m forType.val), []) | .function m name params resultType tag body => let paramNames := params.val.toList.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx let paramsCST := mkAnn m (params.val.toList.map fParameterToCST |>.toArray) let tagClause := mapAnn (fun opt => opt.map (fun t => B3CST.TagClause.tag_some m (mkAnn m t.val))) tag - let bodyCST := mapAnn (fun opt => opt.map (fun b => match b with - | .functionBody bm whens expr => - let whensCST := whens.val.toList.map (fun w => match w with | .when wm e => B3CST.WhenClause.when_clause wm (expressionToCST ctx' e)) - B3CST.FunctionBody.function_body_some bm (mkAnn bm whensCST.toArray) (expressionToCST ctx' expr))) body - B3CST.Decl.function_decl m (mkAnn m name.val) paramsCST (mkAnn m resultType.val) tagClause bodyCST + let (bodyCST, errors) := match body.val with + | some (.functionBody bm whens expr) => + let (whensConverted, whenErrors) := whens.val.toList.foldl (fun (acc, errs) w => + match w with + | .when wm e => + let (e', err) := expressionToCST ctx' e + (acc ++ [B3CST.WhenClause.when_clause wm e'], errs ++ err) + ) ([], []) + let (expr', exprErrs) := expressionToCST ctx' expr + (some (B3CST.FunctionBody.function_body_some bm (mkAnn bm whensConverted.toArray) expr'), whenErrors ++ exprErrs) + | none => (none, []) + (B3CST.Decl.function_decl m (mkAnn m name.val) paramsCST (mkAnn m resultType.val) tagClause (mapAnn (fun _ => bodyCST) body), errors) | .axiom m explains expr => let explainsCST := mkAnn m (explains.val.toList.map (fun id => mkAnn m id.val) |>.toArray) + let (expr', errs) := expressionToCST ctx expr if explains.val.isEmpty then - B3CST.Decl.axiom_decl m (B3CST.AxiomBody.axiom m (expressionToCST ctx expr)) + (B3CST.Decl.axiom_decl m (B3CST.AxiomBody.axiom m expr'), errs) else - B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST (expressionToCST ctx expr)) + (B3CST.Decl.axiom_decl m (B3CST.AxiomBody.explain_axiom m explainsCST expr'), errs) | .procedure m name params specs body => -- Build context: inout parameters need two entries (old and current) let ctx' := params.val.toList.foldl (fun acc p => @@ -354,14 +557,29 @@ def declToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.S match mode with | .paramModeInout _ => acc.push pname.val |>.push pname.val -- Push twice for inout | _ => acc.push pname.val - ) ctx - let paramsCST := mkAnn m (params.val.toList.map (pParameterToCST ctx') |>.toArray) - let specsCST := specs.val.toList.map (specToCST ctx') - let bodyCST := mapAnn (fun opt => opt.map (fun s => B3CST.ProcBody.proc_body_some m (stmtToCST ctx' s))) body - B3CST.Decl.procedure_decl m (mkAnn m name.val) paramsCST (mkAnn m specsCST.toArray) bodyCST - -def programToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Program M → B3CST.Program M - | .program m decls => .program m (mkAnn m (decls.val.toList.map (declToCST ctx) |>.toArray)) + ) {ctx with inProcedure := true} -- Set inProcedure flag for procedure context + let (paramsConverted, paramErrors) := params.val.toList.foldl (fun (acc, errs) p => + let (p', e) := pParameterToCST ctx' p + (acc ++ [p'], errs ++ e) + ) ([], []) + let (specsConverted, specErrors) := specs.val.toList.foldl (fun (acc, errs) s => + let (s', e) := specToCST ctx' s + (acc ++ [s'], errs ++ e) + ) ([], []) + let (bodyCST, bodyErrors) := match body.val with + | some s => + let (s', e) := stmtToCST ctx' s + (some (B3CST.ProcBody.proc_body_some m s'), e) + | none => (none, []) + (B3CST.Decl.procedure_decl m (mkAnn m name.val) (mkAnn m paramsConverted.toArray) (mkAnn m specsConverted.toArray) (mapAnn (fun _ => bodyCST) body), paramErrors ++ specErrors ++ bodyErrors) + +def programToCST [Inhabited M] [Inhabited (B3CST.Expression M)] [Inhabited (B3CST.Statement M)] (ctx : ToCSTContext) : Strata.B3AST.Program M → B3CST.Program M × List (ASTToCSTError M) + | .program m decls => + let (declsConverted, errors) := decls.val.toList.foldl (fun (acc, errs) d => + let (d', e) := declToCST ctx d + (acc ++ [d'], errs ++ e) + ) ([], []) + (.program m (mkAnn m declsConverted.toArray), errors) end ToCST @@ -376,10 +594,14 @@ structure FromCSTContext where namespace FromCSTContext -def lookup (ctx : FromCSTContext) (name : String) : Nat := - ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length +def lookup (ctx : FromCSTContext) (name : String) (m : M) : Nat × List (CSTToASTError M) := + let idx := ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length + if idx >= ctx.vars.length then + (idx, [.unresolvedIdentifier name m]) + else + (idx, []) -def lookupLast (ctx : FromCSTContext) (name : String) : Nat := +def lookupLast (ctx : FromCSTContext) (name : String) (m : M) : Nat × List (CSTToASTError M) := -- Find the last occurrence by searching from the end let rec findLast (vars : List String) (idx : Nat) : Option Nat := match vars with @@ -388,7 +610,11 @@ def lookupLast (ctx : FromCSTContext) (name : String) : Nat := match findLast vs (idx + 1) with | some found => some found | none => if v == name then some idx else none - findLast ctx.vars 0 |>.getD ctx.vars.length + let idx := findLast ctx.vars 0 |>.getD ctx.vars.length + if idx >= ctx.vars.length then + (idx, [.unresolvedIdentifier name m]) + else + (idx, []) def push (ctx : FromCSTContext) (name : String) : FromCSTContext := { vars := name :: ctx.vars } @@ -401,63 +627,154 @@ partial def patternsToArray [Inhabited M] : B3CST.Patterns M → Array (B3CST.Pa | .patterns_single _ p => #[p] | .patterns_cons _ p ps => patternsToArray ps |>.push p -partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Expression M → Strata.B3AST.Expression M - | .natLit ann n => .literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n) - | .strLit ann s => .literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s) - | .btrue ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true) - | .bfalse ann => .literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false) - | .id ann name => .id ann (ctx.lookup name) - | .old_id ann name => .id ann (ctx.lookupLast name.val) - | .not ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) - | .neg ann arg => .unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) (expressionFromCST ctx arg) - | .iff ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .implies ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.implies (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .impliedBy ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.impliedBy (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .and ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.and (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .or ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.or (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.eq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .not_equal ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.neq (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .lt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.lt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .le ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.le (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .ge ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.ge (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .gt ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.gt (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .add ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.add (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .sub ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.sub (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .mul ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mul (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .div ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.div (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .mod ann lhs rhs => .binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mod (B3AnnFromCST.annForBinaryOpType ann)) (expressionFromCST ctx lhs) (expressionFromCST ctx rhs) - | .functionCall ann fn args => .functionCall (B3AnnFromCST.annForFunctionCall ann) ⟨B3AnnFromCST.annForFunctionCallName ann, fn.val⟩ ⟨B3AnnFromCST.annForFunctionCallArgs ann, args.val.map (expressionFromCST ctx)⟩ - | .labeledExpr ann label expr => .labeledExpr (B3AnnFromCST.annForLabeledExpr ann) ⟨B3AnnFromCST.annForLabeledExprLabel ann, label.val⟩ (expressionFromCST ctx expr) +partial def expressionFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Expression M → Strata.B3AST.Expression M × List (CSTToASTError M) + | .natLit ann n => (.literal (B3AnnFromCST.annForLiteral ann) (.intLit (B3AnnFromCST.annForLiteralType ann) n), []) + | .strLit ann s => (.literal (B3AnnFromCST.annForLiteral ann) (.stringLit (B3AnnFromCST.annForLiteralType ann) s), []) + | .btrue ann => (.literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) true), []) + | .bfalse ann => (.literal (B3AnnFromCST.annForLiteral ann) (.boolLit (B3AnnFromCST.annForLiteralType ann) false), []) + | .id ann name => + let (idx, errs) := ctx.lookup name ann + (.id ann idx, errs) + | .old_id ann name => + let (idx, errs) := ctx.lookupLast name.val ann + (.id ann idx, errs) + | .not ann arg => + let (arg', errs) := expressionFromCST ctx arg + (.unaryOp (B3AnnFromCST.annForUnaryOp ann) (.not (B3AnnFromCST.annForUnaryOpType ann)) arg', errs) + | .neg ann arg => + let (arg', errs) := expressionFromCST ctx arg + (.unaryOp (B3AnnFromCST.annForUnaryOp ann) (.neg (B3AnnFromCST.annForUnaryOpType ann)) arg', errs) + | .iff ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.iff (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .implies ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.implies (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .impliedBy ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.impliedBy (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .and ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.and (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .or ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.or (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .equal ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.eq (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .not_equal ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.neq (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .lt ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.lt (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .le ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.le (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .ge ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.ge (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .gt ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.gt (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .add ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.add (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .sub ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.sub (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .mul ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mul (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .div ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.div (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .mod ann lhs rhs => + let (lhs', e1) := expressionFromCST ctx lhs + let (rhs', e2) := expressionFromCST ctx rhs + (.binaryOp (B3AnnFromCST.annForBinaryOp ann) (.mod (B3AnnFromCST.annForBinaryOpType ann)) lhs' rhs', e1 ++ e2) + | .functionCall ann fn args => + let (argsExprs, errors) := args.val.toList.foldl (fun (acc, errs) arg => + let (arg', e) := expressionFromCST ctx arg + (acc ++ [arg'], errs ++ e) + ) ([], []) + (.functionCall (B3AnnFromCST.annForFunctionCall ann) ⟨B3AnnFromCST.annForFunctionCallName ann, fn.val⟩ ⟨B3AnnFromCST.annForFunctionCallArgs ann, argsExprs.toArray⟩, errors) + | .labeledExpr ann label expr => + let (expr', errs) := expressionFromCST ctx expr + (.labeledExpr (B3AnnFromCST.annForLabeledExpr ann) ⟨B3AnnFromCST.annForLabeledExprLabel ann, label.val⟩ expr', errs) | .letExpr ann var value body => let ctx' := ctx.push var.val - .letExpr (B3AnnFromCST.annForLetExpr ann) ⟨B3AnnFromCST.annForLetExprVar ann, var.val⟩ (expressionFromCST ctx value) (expressionFromCST ctx' body) - | .ite ann cond thenExpr elseExpr => .ite (B3AnnFromCST.annForIte ann) (expressionFromCST ctx cond) (expressionFromCST ctx thenExpr) (expressionFromCST ctx elseExpr) + let (value', e1) := expressionFromCST ctx value + let (body', e2) := expressionFromCST ctx' body + (.letExpr (B3AnnFromCST.annForLetExpr ann) ⟨B3AnnFromCST.annForLetExprVar ann, var.val⟩ value' body', e1 ++ e2) + | .ite ann cond thenExpr elseExpr => + let (cond', e1) := expressionFromCST ctx cond + let (then', e2) := expressionFromCST ctx thenExpr + let (else', e3) := expressionFromCST ctx elseExpr + (.ite (B3AnnFromCST.annForIte ann) cond' then' else', e1 ++ e2 ++ e3) | .forall_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromCST ctx' body) + let (body', errs) := expressionFromCST ctx' body + (.quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ body', errs) | .forall_expr ann var ty patterns body => let ctx' := ctx.push var.val - let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M × List (CSTToASTError M) := match p with - | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromCST ctx')⟩ - let patternsArray := patternsToArray patterns |>.map convertPattern - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromCST ctx' body) + | .pattern pann exprs => + let (exprsConverted, errors) := exprs.val.toList.foldl (fun (acc, errs) e => + let (e', err) := expressionFromCST ctx' e + (acc ++ [e'], errs ++ err) + ) ([], []) + (.pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprsConverted.toArray⟩, errors) + let (patternsConverted, patternErrors) := (patternsToArray patterns).toList.foldl (fun (acc, errs) p => + let (p', e) := convertPattern p + (acc ++ [p'], errs ++ e) + ) ([], []) + let (body', bodyErrs) := expressionFromCST ctx' body + (.quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.forall (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsConverted.toArray⟩ body', patternErrors ++ bodyErrs) | .exists_expr_no_patterns ann var ty body => let ctx' := ctx.push var.val - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ (expressionFromCST ctx' body) + let (body', errs) := expressionFromCST ctx' body + (.quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, #[]⟩ body', errs) | .exists_expr ann var ty patterns body => let ctx' := ctx.push var.val - let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M := + let convertPattern (p : B3CST.Pattern M) : Strata.B3AST.Pattern M × List (CSTToASTError M) := match p with - | .pattern pann exprs => .pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprs.val.map (expressionFromCST ctx')⟩ - let patternsArray := patternsToArray patterns |>.map convertPattern - .quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsArray⟩ (expressionFromCST ctx' body) + | .pattern pann exprs => + let (exprsConverted, errors) := exprs.val.toList.foldl (fun (acc, errs) e => + let (e', err) := expressionFromCST ctx' e + (acc ++ [e'], errs ++ err) + ) ([], []) + (.pattern (B3AnnFromCST.annForPattern pann) ⟨B3AnnFromCST.annForPatternExprs pann, exprsConverted.toArray⟩, errors) + let (patternsConverted, patternErrors) := (patternsToArray patterns).toList.foldl (fun (acc, errs) p => + let (p', e) := convertPattern p + (acc ++ [p'], errs ++ e) + ) ([], []) + let (body', bodyErrs) := expressionFromCST ctx' body + (.quantifierExpr (B3AnnFromCST.annForQuantifierExpr ann) (.exists (B3AnnFromCST.annForQuantifierKind ann)) ⟨B3AnnFromCST.annForQuantifierVar ann, var.val⟩ ⟨B3AnnFromCST.annForQuantifierType ann, ty.val⟩ ⟨B3AnnFromCST.annForQuantifierPatterns ann, patternsConverted.toArray⟩ body', patternErrors ++ bodyErrs) | .paren _ expr => expressionFromCST ctx expr -partial def callArgFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.CallArg M → Strata.B3AST.CallArg M - | .call_arg_expr m expr => .callArgExpr m (expressionFromCST ctx expr) - | .call_arg_out m id => .callArgOut m (mapAnn (fun x => x) id) - | .call_arg_inout m id => .callArgInout m (mapAnn (fun x => x) id) +partial def callArgFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.CallArg M → Strata.B3AST.CallArg M × List (CSTToASTError M) + | .call_arg_expr m expr => + let (expr', errs) := expressionFromCST ctx expr + (.callArgExpr m expr', errs) + | .call_arg_out m id => (.callArgOut m (mapAnn (fun x => x) id), []) + | .call_arg_inout m id => (.callArgInout m (mapAnn (fun x => x) id), []) partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List (B3CST.Statement M) | .choiceAtom _ branch => @@ -467,43 +784,58 @@ partial def choiceBranchesToList [Inhabited M] : B3CST.ChoiceBranches M → List match branch with | .choice_branch _ stmt => stmt :: choiceBranchesToList branches -partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Statement M → Strata.B3AST.Statement M +partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Statement M → Strata.B3AST.Statement M × List (CSTToASTError M) | .var_decl_full m name ty autoinv init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) (mkAnn m (some (expressionFromCST ctx' init))) + let (autoinv', e1) := expressionFromCST ctx' autoinv + let (init', e2) := expressionFromCST ctx' init + (.varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some autoinv')) (mkAnn m (some init')), e1 ++ e2) | .var_decl_with_autoinv m name ty autoinv => - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) (mkAnn m none) + let ctx' := ctx.push name.val + let (autoinv', errs) := expressionFromCST ctx' autoinv + (.varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m (some autoinv')) (mkAnn m none), errs) | .var_decl_with_init m name ty init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) + let (init', errs) := expressionFromCST ctx' init + (.varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some init')), errs) | .var_decl_typed m name ty => - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m none) + (.varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m none), []) | .var_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) + let (init', errs) := expressionFromCST ctx' init + (.varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some init')), errs) | .val_decl m name ty init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) + let (init', errs) := expressionFromCST ctx' init + (.varDecl m (mapAnn (fun x => x) name) (mapAnn (fun t => some (mkAnn m t)) ty) (mkAnn m none) (mkAnn m (some init')), errs) | .val_decl_inferred m name init => let ctx' := ctx.push name.val - .varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some (expressionFromCST ctx' init))) + let (init', errs) := expressionFromCST ctx' init + (.varDecl m (mapAnn (fun x => x) name) (mkAnn m none) (mkAnn m none) (mkAnn m (some init')), errs) | .assign m lhs rhs => - .assign m (mkAnn m (ctx.lookup lhs.val)) (expressionFromCST ctx rhs) + let (idx, e1) := ctx.lookup lhs.val m + let (rhs', e2) := expressionFromCST ctx rhs + (.assign m (mkAnn m idx) rhs', e1 ++ e2) | .reinit_statement m v => - .reinit m (mkAnn m (ctx.lookup v.val)) + let (idx, errs) := ctx.lookup v.val m + (.reinit m (mkAnn m idx), errs) | .check m expr => - .check m (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.check m expr', errs) | .assume m expr => - .assume m (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.assume m expr', errs) | .reach m expr => - .reach m (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.reach m expr', errs) | .assert m expr => - .assert m (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.assert m expr', errs) | .return_statement m => - .returnStmt m + (.returnStmt m, []) | .block m stmts => - let (stmts', _) := stmts.val.toList.foldl (fun (acc, ctx) stmt => - let stmt' := stmtFromCST ctx stmt + let (stmts', _, errors) := stmts.val.toList.foldl (fun (acc, ctx, errs) stmt => + let (stmt', e) := stmtFromCST ctx stmt let ctx' := match stmt with | .var_decl_full _ name _ _ _ => ctx.push name.val | .var_decl_with_autoinv _ name _ _ => ctx.push name.val @@ -513,34 +845,59 @@ partial def stmtFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : | .val_decl _ name _ _ => ctx.push name.val | .val_decl_inferred _ name _ => ctx.push name.val | _ => ctx - (acc ++ [stmt'], ctx') - ) ([], ctx) - .blockStmt m (mkAnn m stmts'.toArray) + (acc ++ [stmt'], ctx', errs ++ e) + ) ([], ctx, []) + (.blockStmt m (mkAnn m stmts'.toArray), errors) | .if_statement m cond thenB elseB => - let elseBranch := mapAnn (fun opt => opt.map (fun e => match e with | .else_some _ stmt => stmtFromCST ctx stmt)) elseB - .ifStmt m (expressionFromCST ctx cond) (stmtFromCST ctx thenB) elseBranch + let (cond', e1) := expressionFromCST ctx cond + let (then', e2) := stmtFromCST ctx thenB + let (elseBranch, e3) := match elseB.val with + | some (.else_some _ stmt) => + let (stmt', e) := stmtFromCST ctx stmt + (some stmt', e) + | none => (none, []) + (.ifStmt m cond' then' (mapAnn (fun _ => elseBranch) elseB), e1 ++ e2 ++ e3) | .loop_statement m invs body => - let invariants := invs.val.toList.map fun inv => + let (invariants, invErrors) := invs.val.toList.foldl (fun (acc, errs) inv => match inv with - | .invariant _ expr => expressionFromCST ctx expr - .loop m (mkAnn m invariants.toArray) (stmtFromCST ctx body) + | .invariant _ expr => + let (expr', e) := expressionFromCST ctx expr + (acc ++ [expr'], errs ++ e) + ) ([], []) + let (body', bodyErrs) := stmtFromCST ctx body + (.loop m (mkAnn m invariants.toArray) body', invErrors ++ bodyErrs) | .exit_statement m label => - .exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label) + (.exit m (mapAnn (fun opt => opt.map (fun l => mkAnn m l.val)) label), []) | .labeled_statement m label stmt => - .labeledStmt m (mapAnn (fun x => x) label) (stmtFromCST ctx stmt) + let (stmt', errs) := stmtFromCST ctx stmt + (.labeledStmt m (mapAnn (fun x => x) label) stmt', errs) | .probe m label => - .probe m (mapAnn (fun x => x) label) + (.probe m (mapAnn (fun x => x) label), []) | .aForall_statement m var ty body => let ctx' := ctx.push var.val - .aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) (stmtFromCST ctx' body) + let (body', errs) := stmtFromCST ctx' body + (.aForall m (mapAnn (fun x => x) var) (mapAnn (fun x => x) ty) body', errs) | .choose_statement m branches => - .choose m (mkAnn m (choiceBranchesToList branches |>.map (stmtFromCST ctx)).toArray) + let (stmts, errors) := (choiceBranchesToList branches).foldl (fun (acc, errs) stmt => + let (stmt', e) := stmtFromCST ctx stmt + (acc ++ [stmt'], errs ++ e) + ) ([], []) + (.choose m (mkAnn m stmts.toArray), errors) | .if_case_statement m cases => - .ifCase m (mapAnn (fun arr => arr.toList.map (fun case => + let (casesConverted, errors) := cases.val.toList.foldl (fun (acc, errs) case => match case with - | .if_case_branch cm cond stmt => .oneIfCase cm (expressionFromCST ctx cond) (stmtFromCST ctx stmt)) |>.toArray) cases) + | .if_case_branch cm cond stmt => + let (cond', e1) := expressionFromCST ctx cond + let (stmt', e2) := stmtFromCST ctx stmt + (acc ++ [.oneIfCase cm cond' stmt'], errs ++ e1 ++ e2) + ) ([], []) + (.ifCase m (mapAnn (fun _ => casesConverted.toArray) cases), errors) | .call_statement m procName args => - .call m (mapAnn (fun x => x) procName) (mapAnn (fun arr => arr.toList.map (callArgFromCST ctx) |>.toArray) args) + let (argsConverted, errors) := args.val.toList.foldl (fun (acc, errs) arg => + let (arg', e) := callArgFromCST ctx arg + (acc ++ [arg'], errs ++ e) + ) ([], []) + (.call m (mapAnn (fun x => x) procName) (mapAnn (fun _ => argsConverted.toArray) args), errors) def paramModeFromCST [Inhabited M] : Ann (Option (B3CST.PParamMode M)) M → Strata.B3AST.ParamMode M | ⟨m, none⟩ => .paramModeIn m @@ -554,41 +911,55 @@ def fParameterFromCST [Inhabited M] : B3CST.FParam M → Strata.B3AST.FParameter | none => false .fParameter m (mkAnn m inj) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) -def pParameterFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.PParam M → Strata.B3AST.PParameter M +def pParameterFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.PParam M → Strata.B3AST.PParameter M × List (CSTToASTError M) | .pparam m mode name ty => - .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m none) + (.pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m none), []) | .pparam_with_autoinv m mode name ty autoinv => - .pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m (some (expressionFromCST ctx autoinv))) + let (autoinv', errs) := expressionFromCST ctx autoinv + (.pParameter m (paramModeFromCST mode) (mapAnn (fun x => x) name) (mapAnn (fun x => x) ty) (mkAnn m (some autoinv')), errs) -def specFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Spec M → Strata.B3AST.Spec M - | .spec_requires m expr => .specRequires m (expressionFromCST ctx expr) - | .spec_ensures m expr => .specEnsures m (expressionFromCST ctx expr) +def specFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Spec M → Strata.B3AST.Spec M × List (CSTToASTError M) + | .spec_requires m expr => + let (expr', errs) := expressionFromCST ctx expr + (.specRequires m expr', errs) + | .spec_ensures m expr => + let (expr', errs) := expressionFromCST ctx expr + (.specEnsures m expr', errs) def fparamsToList : Ann (Array (B3CST.FParam M)) M → List (B3CST.FParam M) | ⟨_, arr⟩ => arr.toList -def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Decl M → Strata.B3AST.Decl M +def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Decl M → Strata.B3AST.Decl M × List (CSTToASTError M) | .type_decl m name => - .typeDecl m (mapAnn (fun x => x) name) + (.typeDecl m (mapAnn (fun x => x) name), []) | .tagger_decl m name forType => - .tagger m (mapAnn (fun x => x) name) (mapAnn (fun x => x) forType) + (.tagger m (mapAnn (fun x => x) name) (mapAnn (fun x => x) forType), []) | .function_decl m name params resultType tag body => let paramsAST := fparamsToList params |>.map fParameterFromCST let paramNames := paramsAST.map (fun p => match p with | .fParameter _ _ n _ => n.val) let ctx' := paramNames.foldl (fun acc n => acc.push n) ctx let tagAST := tag.val.map (fun t => match t with | .tag_some _ id => mkAnn m id.val) - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with - | .function_body_some bm whens expr => - let whensAST := whens.val.toList.map (fun w => match w with | .when_clause wm e => B3AST.When.when wm (expressionFromCST ctx' e)) - B3AST.FunctionBody.functionBody bm (mkAnn bm whensAST.toArray) (expressionFromCST ctx' expr))) body - .function m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mapAnn (fun x => x) resultType) (mkAnn m tagAST) bodyAST + let (bodyAST, errors) := match body.val with + | some (.function_body_some bm whens expr) => + let (whensConverted, whenErrors) := whens.val.toList.foldl (fun (acc, errs) w => + match w with + | .when_clause wm e => + let (e', err) := expressionFromCST ctx' e + (acc ++ [B3AST.When.when wm e'], errs ++ err) + ) ([], []) + let (expr', exprErrs) := expressionFromCST ctx' expr + (some (B3AST.FunctionBody.functionBody bm (mkAnn bm whensConverted.toArray) expr'), whenErrors ++ exprErrs) + | none => (none, []) + (.function m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mapAnn (fun x => x) resultType) (mkAnn m tagAST) (mapAnn (fun _ => bodyAST) body), errors) | .axiom_decl m axiomBody => match axiomBody with | .axiom _ expr => - .axiom m (mkAnn m #[]) (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.axiom m (mkAnn m #[]) expr', errs) | .explain_axiom _ names expr => let namesAST := names.val.toList.map (fun n => mkAnn m n.val) - .axiom m (mkAnn m namesAST.toArray) (expressionFromCST ctx expr) + let (expr', errs) := expressionFromCST ctx expr + (.axiom m (mkAnn m namesAST.toArray) expr', errs) | .procedure_decl m name params specs body => -- Build context for parameters: inout parameters need two entries (old and current) let ctx' := params.val.toList.foldl (fun acc p => @@ -600,13 +971,28 @@ def declFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.De | _ => acc.push pname -- Push once for in/out parameters ) ctx -- Now convert all parameters with the full context (so autoinv can reference all params) - let paramsAST := params.val.toList.map (pParameterFromCST ctx') - let specsAST := specs.val.toList.map (specFromCST ctx') - let bodyAST := mapAnn (fun opt => opt.map (fun b => match b with | .proc_body_some _ s => stmtFromCST ctx' s)) body - .procedure m (mapAnn (fun x => x) name) (mkAnn m paramsAST.toArray) (mkAnn m specsAST.toArray) bodyAST - -def programFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Program M → Strata.B3AST.Program M - | .program m decls => .program m (mkAnn m (decls.val.toList.map (declFromCST ctx) |>.toArray)) + let (paramsConverted, paramErrors) := params.val.toList.foldl (fun (acc, errs) p => + let (p', e) := pParameterFromCST ctx' p + (acc ++ [p'], errs ++ e) + ) ([], []) + let (specsConverted, specErrors) := specs.val.toList.foldl (fun (acc, errs) s => + let (s', e) := specFromCST ctx' s + (acc ++ [s'], errs ++ e) + ) ([], []) + let (bodyAST, bodyErrors) := match body.val with + | some (.proc_body_some _ s) => + let (s', e) := stmtFromCST ctx' s + (some s', e) + | none => (none, []) + (.procedure m (mapAnn (fun x => x) name) (mkAnn m paramsConverted.toArray) (mkAnn m specsConverted.toArray) (mapAnn (fun _ => bodyAST) body), paramErrors ++ specErrors ++ bodyErrors) + +def programFromCST [Inhabited M] [B3AnnFromCST M] (ctx : FromCSTContext) : B3CST.Program M → Strata.B3AST.Program M × List (CSTToASTError M) + | .program m decls => + let (declsConverted, errors) := decls.val.toList.foldl (fun (acc, errs) d => + let (d', e) := declFromCST ctx d + (acc ++ [d'], errs ++ e) + ) ([], []) + (.program m (mkAnn m declsConverted.toArray), errors) end FromCST diff --git a/StrataTest/Languages/B3/DDMConversionErrorTests.lean b/StrataTest/Languages/B3/DDMConversionErrorTests.lean new file mode 100644 index 000000000..4536e3e95 --- /dev/null +++ b/StrataTest/Languages/B3/DDMConversionErrorTests.lean @@ -0,0 +1,117 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.Conversion + +/-! +# B3 Conversion Error Tests + +Tests for error handling in CST↔AST conversion. +-/ + +namespace StrataTest.B3.ConversionErrors + +open Strata +open Strata.B3CST +open Strata.B3AST + +/-- Convert CST expression to AST and return formatted error messages -/ +def checkCSTToASTErrors (expr : B3CST.Expression Nat) : IO Unit := do + let ctx := B3.FromCSTContext.empty + let (_ast, errors) := B3.expressionFromCST ctx expr + + if errors.isEmpty then + IO.println "No errors" + else + for err in errors do + match err with + | .unresolvedIdentifier name _metadata => + IO.println s!"Unresolved identifier '{name}'" + +/-- Create a ToCSTContext from a list of variable names (in declaration order) -/ +def mkContext (vars : List String) (inProcedure : Bool := false) : B3.ToCSTContext := + { vars := vars.reverse, inProcedure := inProcedure } + +/-- Convert AST expression to CST and return formatted error messages -/ +def checkASTToCSTErrors (ctx : B3.ToCSTContext) (expr : B3AST.Expression Nat) : IO Unit := do + let (_cst, errors) := B3.expressionToCST ctx expr + + if errors.isEmpty then + IO.println "No errors" + else + for err in errors do + match err with + | .variableOutOfBounds idx size _metadata => + IO.println s!"Variable @{idx} out of bounds (context size: {size})" + | .unsupportedVariableReference idx _metadata => + IO.println s!"Variable @{idx} not supported in concrete syntax" + +/-- +info: Unresolved identifier 'undefinedVar' +-/ +#guard_msgs in +#eval checkCSTToASTErrors (.id 42 "undefinedVar") + +/-- +info: Unresolved identifier 'foo' +Unresolved identifier 'bar' +-/ +#guard_msgs in +#eval checkCSTToASTErrors (.add 5 (.id 10 "foo") (.id 20 "bar")) + +/-- +info: Unresolved identifier 'x' +Unresolved identifier 'y' +Unresolved identifier 'z' +-/ +#guard_msgs in +#eval checkCSTToASTErrors (.add 0 (.mul 0 (.id 1 "x") (.id 2 "y")) (.id 3 "z")) + +/-- +info: No errors +-/ +#guard_msgs in +#eval checkCSTToASTErrors (.natLit 100 42) + +/-- +info: No errors +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "y", "z"]) (.id 100 2) + +/-- +info: Variable @1 not supported in concrete syntax +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "x"]) (.id 120 1) + +/-- +info: No errors +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "x"] (inProcedure := true)) (.id 125 1) + +/-- +info: Variable @1 not supported in concrete syntax +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "x", "x"]) (.id 130 1) + +/-- +info: Variable @5 out of bounds (context size: 3) +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "y", "z"]) (.id 200 5) + +/-- +info: Variable @1 not supported in concrete syntax +Variable @1 not supported in concrete syntax +-/ +#guard_msgs in +#eval checkASTToCSTErrors (mkContext ["x", "x", "x"]) + (.binaryOp 0 (.add 0) (.id 10 1) (.id 20 1)) + +end StrataTest.B3.ConversionErrors diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 6eebc0c35..959ae3872 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -16,13 +16,23 @@ open Strata.B3CST partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Decl.ofAst decl with | .ok cstDecl => - let b3Decl := B3.declFromCST B3.FromCSTContext.empty cstDecl - let b3DeclUnit := b3Decl.toUnit + let (b3Decl, cstToAstErrors) := B3.declFromCST B3.FromCSTContext.empty cstDecl + let (cstDecl', astToCstErrors) := B3.declToCST B3.ToCSTContext.empty b3Decl + -- Convert to Unit metadata for repr + let b3DeclUnit := B3AST.Decl.mapMetadata (fun _ => ()) b3Decl let reprStr := (repr b3DeclUnit).pretty let reprStr := cleanupDeclRepr reprStr let reprStr := cleanupUnitRepr reprStr - dbg_trace f!"B3: {reprStr}" - let cstDecl' := B3.declToCST B3.ToCSTContext.empty b3Decl + let errorStr := if cstToAstErrors.isEmpty && astToCstErrors.isEmpty then "" + else + let cstErrs := cstToAstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let astErrs := astToCstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let parts := [ + if cstToAstErrors.isEmpty then "" else s!"\nCST→AST Errors:\n {cstErrs}", + if astToCstErrors.isEmpty then "" else s!"\nAST→CST Errors:\n {astErrs}" + ] + String.join parts + dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstDecl'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" @@ -30,17 +40,26 @@ partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) (printIntermediate: Bool := true) : Format := match B3CST.Program.ofAst prog with | .ok cstProg => - let b3Prog := B3.programFromCST B3.FromCSTContext.empty cstProg + let (b3Prog, cstToAstErrors) := B3.programFromCST B3.FromCSTContext.empty cstProg + let (cstProg', astToCstErrors) := B3.programToCST B3.ToCSTContext.empty b3Prog + let errorStr := if cstToAstErrors.isEmpty && astToCstErrors.isEmpty then "" + else + let cstErrs := cstToAstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let astErrs := astToCstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let parts := [ + if cstToAstErrors.isEmpty then "" else s!"\nCST→AST Errors:\n {cstErrs}", + if astToCstErrors.isEmpty then "" else s!"\nAST→CST Errors:\n {astErrs}" + ] + String.join parts dbg_trace (if printIntermediate then - let b3ProgUnit := b3Prog.toUnit + -- Convert to Unit metadata for repr + let b3ProgUnit := B3AST.Program.mapMetadata (fun _ => ()) b3Prog let reprStr := (repr b3ProgUnit).pretty let reprStr := cleanupDeclRepr reprStr let reprStr := cleanupUnitRepr reprStr - f!"B3: {reprStr}" + f!"B3: {reprStr}{errorStr}" else - f!"") - - let cstProg' := B3.programToCST B3.ToCSTContext.empty b3Prog + f!"{errorStr}") let cstAst := cstProg'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index 5f21e9b0f..5f85d2cfc 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -18,13 +18,23 @@ open Strata.B3CST partial def doRoundtrip (e : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Expression.ofAst e with | .ok cstExpr => - let b3Expr := B3.expressionFromCST B3.FromCSTContext.empty cstExpr - let b3ExprUnit := b3Expr.toUnit + let (b3Expr, cstToAstErrors) := B3.expressionFromCST B3.FromCSTContext.empty cstExpr + let (cstExpr', astToCstErrors) := B3.expressionToCST B3.ToCSTContext.empty b3Expr + -- Convert to Unit metadata for repr + let b3ExprUnit := B3AST.Expression.mapMetadata (fun _ => ()) b3Expr let reprStr := (repr b3ExprUnit).pretty let reprStr := cleanupExprRepr reprStr let reprStr := cleanupUnitRepr reprStr - dbg_trace f!"B3: {reprStr}" - let cstExpr' := B3.expressionToCST B3.ToCSTContext.empty b3Expr + let errorStr := if cstToAstErrors.isEmpty && astToCstErrors.isEmpty then "" + else + let cstErrs := cstToAstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let astErrs := astToCstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let parts := [ + if cstToAstErrors.isEmpty then "" else s!"\nCST→AST Errors:\n {cstErrs}", + if astToCstErrors.isEmpty then "" else s!"\nAST→CST Errors:\n {astErrs}" + ] + String.join parts + dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstExpr'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" @@ -71,8 +81,12 @@ section ExpressionRoundtripTests -- We are loosing the context so this is why it's printing that way. /-- info: B3: .id () 0 +CST→AST Errors: + Unresolved identifier 'x' +AST→CST Errors: + Variable index @0 is out of bounds (context has 0 variables) --- -info: @0 +info: |@0| -/ #guard_msgs in #eval roundtripExpr $ #strata program B3CST; check x #end diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index ecdf8894c..1d8356f10 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -18,13 +18,23 @@ open Strata.B3CST partial def doRoundtripStmt (stmt : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) : Format := match B3CST.Statement.ofAst stmt with | .ok cstStmt => - let b3Stmt := B3.stmtFromCST B3.FromCSTContext.empty cstStmt - let b3StmtUnit := b3Stmt.toUnit + let (b3Stmt, cstToAstErrors) := B3.stmtFromCST B3.FromCSTContext.empty cstStmt + let (cstStmt', astToCstErrors) := B3.stmtToCST B3.ToCSTContext.empty b3Stmt + -- Convert to Unit metadata for repr + let b3StmtUnit := B3AST.Statement.mapMetadata (fun _ => ()) b3Stmt let reprStr := (repr b3StmtUnit).pretty let reprStr := cleanupStmtRepr reprStr let reprStr := cleanupUnitRepr reprStr - dbg_trace f!"B3: {reprStr}" - let cstStmt' := B3.stmtToCST B3.ToCSTContext.empty b3Stmt + let errorStr := if cstToAstErrors.isEmpty && astToCstErrors.isEmpty then "" + else + let cstErrs := cstToAstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let astErrs := astToCstErrors.map Std.format |> List.map (·.pretty) |> String.intercalate "\n " + let parts := [ + if cstToAstErrors.isEmpty then "" else s!"\nCST→AST Errors:\n {cstErrs}", + if astToCstErrors.isEmpty then "" else s!"\nAST→CST Errors:\n {astErrs}" + ] + String.join parts + dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstStmt'.toAst cformat (ArgF.op cstAst) ctx state | .error msg => s!"Parse error: {msg}" diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index 47cb33633..f2bfd2b63 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -166,7 +166,7 @@ partial def cleanupUnitRepr (s : String) : String := else findClose (d :: rest) (depth - 1) (c :: acc) else findClose (d :: rest) depth (c :: acc) match findClose (chars.drop 1) 0 [] with - | none => removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) + | none => removeAnnStructs (chars.drop 1) (acc ++ String.ofList [chars.head!]) | some (innerChars, afterClose) => -- innerChars contains everything between { and }, like "ann := (),\n val := X" or "ann := (), val := X" -- Find "val := " and extract everything after it @@ -182,10 +182,10 @@ partial def cleanupUnitRepr (s : String) : String := | [] => none | _ :: rest => findValStart rest match findValStart innerChars with - | none => removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) - | some valueOnly => removeAnnStructs afterClose (acc ++ "u " ++ String.mk valueOnly) + | none => removeAnnStructs (chars.drop 1) (acc ++ String.ofList [chars.head!]) + | some valueOnly => removeAnnStructs afterClose (acc ++ "u " ++ String.ofList valueOnly) else - removeAnnStructs (chars.drop 1) (acc ++ String.mk [chars.head!]) + removeAnnStructs (chars.drop 1) (acc ++ String.ofList [chars.head!]) -- Apply removal 10 times to handle nested structures up to depth 10 let rec applyNTimes (n : Nat) (str : String) : String := @@ -229,7 +229,7 @@ partial def cleanupUnitRepr (s : String) : String := popUntil indentStack -- New indent is (stack depth - 1) * 2 let newIndent := (newStack.length - 1) * 2 - let newLine := String.mk (List.replicate newIndent ' ') ++ content + let newLine := String.ofList (List.replicate newIndent ' ') ++ content processLines rest newStack (newLine :: acc) String.intercalate "\n" (processLines lines [] []) From a192855b39671830b0a1d2b3a7e2384ee5f19cf0 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 23 Dec 2025 16:48:47 -0600 Subject: [PATCH 18/24] Update DDMFormatProgramsTests to pass with refactored conversion API --- .../Languages/B3/DDMFormatProgramsTests.lean | 42 +++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean index eda14cc5a..222557054 100644 --- a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -163,28 +163,28 @@ procedure Print(a : string, b : string, c : string) // } // } // -// Note that B3 identifiers may contain "." characters. B3 uses "TODODotDot" as part of the +// Note that B3 identifiers may contain "." characters. B3 uses ".." as part of the // name when it generates functions (for example, the function names generated as a result // of declaring a parameter to be "injective"). procedure Good(out result: XResult) { var cresult: CResult - CreateClient(TODOVerticalBarIdentifiers, out cresult) + CreateClient(|myFileSystemName: string|, out cresult) if !CIsSuccess(cresult) { - result := XFailure(CFailureTODODotDotmsg(cresult)) + result := XFailure(CFailure..msg(cresult)) return } - var fileSystem := CSuccessTODODotDotvalue(cresult) + var fileSystem := CSuccess..value(cresult) var aresult: AResult ListBuckets(fileSystem, out aresult) if !AIsSuccess(aresult) { - result := XFailure(AFailureTODODotDotmsg(aresult)) + result := XFailure(AFailure..msg(aresult)) return } - var aresponse := ASuccessTODODotDotvalue(aresult) + var aresponse := ASuccess..value(aresult) - var buckets := AResponseTODODotDotbuckets(aresponse) + var buckets := AResponse..buckets(aresponse) var i := 0 loop @@ -197,22 +197,22 @@ procedure Good(out result: XResult) { check 0 <= i && i < length(buckets) var bucket := select(buckets, i) - var bucketName := BucketTODODotDotname(bucket) + var bucketName := Bucket..name(bucket) var bresult: BResult GetPublicAccessBlock(fileSystem, bucketName, out bresult) if !BIsSuccess(bresult) { - result := XFailure(BFailureTODODotDotmsg(bresult)) + result := XFailure(BFailure..msg(bresult)) return } - var bresponse := BSuccessTODODotDotvalue(bresult) + var bresponse := BSuccess..value(bresult) - var isBlocked := GetAttributeValue(BResponseTODODotDotgetConfig(bresponse), TODOBarIdentifierBlockPublicAcls) + var isBlocked := GetAttributeValue(BResponse..getConfig(bresponse), |BlockPublicAcls: string|) if isBlocked { - Print(TODOBarIdentifierbucket, bucketName, TODOBarIdentifier) + Print(|bucket: string|, bucketName, |is-blocked: string|) } else { - Print(TODOBarIdentifierbucket, bucketName, TODOBarIdentifierIsNotBlocked) + Print(|bucket: string|, bucketName, |is-not-blocked: string|) } i := i + 1 @@ -238,10 +238,10 @@ type Client procedure ListBuckets(c: Client, out aresult: AResult) ensures AIsSuccess(aresult) ==> forall bucket: Bucket - pattern BucketTODODotDotname(bucket) - pattern in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) - in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) ==> - UserOwnsBucket(BucketTODODotDotname(bucket)) + pattern Bucket..name(bucket) + pattern in(bucket, AResponse..buckets(ASuccess..value(aresult))) + in(bucket, AResponse..buckets(ASuccess..value(aresult))) ==> + UserOwnsBucket(Bucket..name(bucket)) procedure GetPublicAccessBlock(c: Client, Bucket: string, out result: BResult) requires UserOwnsBucket(Bucket) @@ -301,7 +301,7 @@ tagger XResultTag for XResult function XSuccess(injective value: X): XResult tag XResultTag function XFailure(injective msg: string): XResult tag XResultTag function XIsSuccess(r: XResult): bool { - XResultTag(r) == XSuccessTODODotDottag() + XResultTag(r) == XSuccess..tag() } type CResult // Result @@ -309,7 +309,7 @@ tagger CResultTag for CResult function CSuccess(injective value: Client): CResult tag CResultTag function CFailure(injective msg: string): CResult tag CResultTag function CIsSuccess(r: CResult): bool { - CResultTag(r) == CSuccessTODODotDottag() + CResultTag(r) == CSuccess..tag() } type AResult // Result @@ -317,7 +317,7 @@ tagger AResultTag for AResult function ASuccess(injective value: AResponse): AResult tag AResultTag function AFailure(injective msg: string): AResult tag AResultTag function AIsSuccess(r: AResult): bool { - AResultTag(r) == ASuccessTODODotDottag() + AResultTag(r) == ASuccess..tag() } type BResult // Result @@ -325,7 +325,7 @@ tagger BResultTag for BResult function BSuccess(injective value: BResponse): BResult tag BResultTag function BFailure(injective msg: string): BResult tag BResultTag function BIsSuccess(r: BResult): bool { - BResultTag(r) == BSuccessTODODotDottag() + BResultTag(r) == BSuccess..tag() } // -------------------------------------------------------------------- From e2a8fe81aa56f43d9e7d1f69cca1d305d194fc2e Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 23 Dec 2025 17:09:30 -0600 Subject: [PATCH 19/24] Update DDMFormatProgramsTests with error messages in expected output --- .../Languages/B3/DDMFormatProgramsTests.lean | 48 ++++++++++++------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean index 222557054..82eeac4ef 100644 --- a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -30,27 +30,41 @@ section ProgramRoundtripTests -- Type declaration /-- info: +CST→AST Errors: + Unresolved identifier '«myFileSystemName: string»' + Unresolved identifier '«BlockPublicAcls: string»' + Unresolved identifier '«bucket: string»' + Unresolved identifier '«is-blocked: string»' + Unresolved identifier '«bucket: string»' + Unresolved identifier '«is-not-blocked: string»' +AST→CST Errors: + Variable index @2 is out of bounds (context has 2 variables) + Variable index @12 is out of bounds (context has 12 variables) + Variable index @12 is out of bounds (context has 12 variables) + Variable index @12 is out of bounds (context has 12 variables) + Variable index @12 is out of bounds (context has 12 variables) + Variable index @12 is out of bounds (context has 12 variables) --- info: procedure Good(out result : XResult) { var cresult : CResult - CreateClient(@2, out cresult) + CreateClient(|@2|, out cresult) if !CIsSuccess(cresult) ⏎ { - result := XFailure(CFailureTODODotDotmsg(cresult)) + result := XFailure(CFailure..msg(cresult)) return } - var fileSystem := CSuccessTODODotDotvalue(cresult) + var fileSystem := CSuccess..value(cresult) var aresult : AResult ListBuckets(fileSystem, out aresult) if !AIsSuccess(aresult) ⏎ { - result := XFailure(AFailureTODODotDotmsg(aresult)) + result := XFailure(AFailure..msg(aresult)) return } - var aresponse := ASuccessTODODotDotvalue(aresult) - var buckets := AResponseTODODotDotbuckets(aresponse) + var aresponse := ASuccess..value(aresult) + var buckets := AResponse..buckets(aresponse) var i := 0 loop invariant 0 <= i && i <= length(buckets) ⏎ @@ -61,23 +75,23 @@ procedure Good(out result : XResult) } check 0 <= i && i < length(buckets) var bucket := select(buckets, i) - var bucketName := BucketTODODotDotname(bucket) + var bucketName := Bucket..name(bucket) var bresult : BResult GetPublicAccessBlock(fileSystem, bucketName, out bresult) if !BIsSuccess(bresult) ⏎ { - result := XFailure(BFailureTODODotDotmsg(bresult)) + result := XFailure(BFailure..msg(bresult)) return } - var bresponse := BSuccessTODODotDotvalue(bresult) - var isBlocked := GetAttributeValue(BResponseTODODotDotgetConfig(bresponse), @12) + var bresponse := BSuccess..value(bresult) + var isBlocked := GetAttributeValue(BResponse..getConfig(bresponse), |@12|) if isBlocked ⏎ { - Print(@12, bucketName, @12) + Print(|@12|, bucketName, |@12|) } else ⏎ { - Print(@12, bucketName, @12) + Print(|@12|, bucketName, |@12|) } i := i + 1 } @@ -88,7 +102,7 @@ procedure CreateClient(name : string, out result : CResult) function UserOwnsBucket(name : string) : bool type Client procedure ListBuckets(c : Client, out aresult : AResult) - ensures AIsSuccess(aresult) ==> (forall bucket : Bucket pattern BucketTODODotDotname(bucket) pattern in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) in(bucket, AResponseTODODotDotbuckets(ASuccessTODODotDotvalue(aresult))) ==> UserOwnsBucket(BucketTODODotDotname(bucket))) + ensures AIsSuccess(aresult) ==> (forall bucket : Bucket pattern Bucket..name(bucket) pattern in(bucket, AResponse..buckets(ASuccess..value(aresult))) in(bucket, AResponse..buckets(ASuccess..value(aresult))) ==> UserOwnsBucket(Bucket..name(bucket))) procedure GetPublicAccessBlock(c : Client, Bucket : string, out result : BResult) requires UserOwnsBucket(Bucket) type AResponse @@ -105,28 +119,28 @@ tagger XResultTag for XResult function XSuccess(injective value : X) : XResult tag XResultTag function XFailure(injective msg : string) : XResult tag XResultTag function XIsSuccess(r : XResult) : bool { - XResultTag(r) == XSuccessTODODotDottag() + XResultTag(r) == XSuccess..tag() } type CResult tagger CResultTag for CResult function CSuccess(injective value : Client) : CResult tag CResultTag function CFailure(injective msg : string) : CResult tag CResultTag function CIsSuccess(r : CResult) : bool { - CResultTag(r) == CSuccessTODODotDottag() + CResultTag(r) == CSuccess..tag() } type AResult tagger AResultTag for AResult function ASuccess(injective value : AResponse) : AResult tag AResultTag function AFailure(injective msg : string) : AResult tag AResultTag function AIsSuccess(r : AResult) : bool { - AResultTag(r) == ASuccessTODODotDottag() + AResultTag(r) == ASuccess..tag() } type BResult tagger BResultTag for BResult function BSuccess(injective value : BResponse) : BResult tag BResultTag function BFailure(injective msg : string) : BResult tag BResultTag function BIsSuccess(r : BResult) : bool { - BResultTag(r) == BSuccessTODODotDottag() + BResultTag(r) == BSuccess..tag() } type BucketSeq function select(s : BucketSeq, i : int) : Bucket From 0b4e5fa19800484a91d9a92aa90e1028dae28269 Mon Sep 17 00:00:00 2001 From: Josh Cohen Date: Mon, 29 Dec 2025 17:38:27 -0500 Subject: [PATCH 20/24] Prove termination for B3 metadata transformation --- .../B3/DDMTransform/DefinitionAST.lean | 87 ++++++++++++------- 1 file changed, 55 insertions(+), 32 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/DefinitionAST.lean b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean index 47e7da1b1..1a0e062fc 100644 --- a/Strata/Languages/B3/DDMTransform/DefinitionAST.lean +++ b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean @@ -188,14 +188,12 @@ open Strata.B3AST private def mapAnn {α M N : Type} (f : M → N) (a : Ann α M) : Ann α N := ⟨f a.ann, a.val⟩ -mutual - -partial def Literal.mapMetadata [Inhabited N] (f : M → N) : Literal M → Literal N +def Literal.mapMetadata [Inhabited N] (f : M → N) : Literal M → Literal N | .intLit m n => .intLit (f m) n | .boolLit m b => .boolLit (f m) b | .stringLit m s => .stringLit (f m) s -partial def BinaryOp.mapMetadata [Inhabited N] (f : M → N) : BinaryOp M → BinaryOp N +def BinaryOp.mapMetadata [Inhabited N] (f : M → N) : BinaryOp M → BinaryOp N | .iff m => .iff (f m) | .implies m => .implies (f m) | .impliedBy m => .impliedBy (f m) @@ -213,15 +211,18 @@ partial def BinaryOp.mapMetadata [Inhabited N] (f : M → N) : BinaryOp M → Bi | .div m => .div (f m) | .mod m => .mod (f m) -partial def UnaryOp.mapMetadata [Inhabited N] (f : M → N) : UnaryOp M → UnaryOp N +def UnaryOp.mapMetadata [Inhabited N] (f : M → N) : UnaryOp M → UnaryOp N | .not m => .not (f m) | .neg m => .neg (f m) -partial def QuantifierKind.mapMetadata [Inhabited N] (f : M → N) : QuantifierKind M → QuantifierKind N +def QuantifierKind.mapMetadata [Inhabited N] (f : M → N) : QuantifierKind M → QuantifierKind N | .forall m => .forall (f m) | .exists m => .exists (f m) -partial def Expression.mapMetadata [Inhabited N] (f : M → N) : Expression M → Expression N +mutual + +def Expression.mapMetadata [Inhabited N] (f : M → N) (e: Expression M) :Expression N := + match e with | .literal m lit => .literal (f m) (Literal.mapMetadata f lit) | .id m idx => .id (f m) idx | .ite m cond thn els => .ite (f m) (Expression.mapMetadata f cond) (Expression.mapMetadata f thn) (Expression.mapMetadata f els) @@ -232,20 +233,28 @@ partial def Expression.mapMetadata [Inhabited N] (f : M → N) : Expression M | .letExpr m var value body => .letExpr (f m) (mapAnn f var) (Expression.mapMetadata f value) (Expression.mapMetadata f body) | .quantifierExpr m qkind var ty patterns body => .quantifierExpr (f m) (QuantifierKind.mapMetadata f qkind) (mapAnn f var) (mapAnn f ty) - ⟨f patterns.ann, patterns.val.map (Pattern.mapMetadata f)⟩ (Expression.mapMetadata f body) - -partial def Pattern.mapMetadata [Inhabited N] (f : M → N) : Pattern M → Pattern N - | .pattern m exprs => .pattern (f m) ⟨f exprs.ann, exprs.val.map (Expression.mapMetadata f)⟩ - -partial def CallArg.mapMetadata [Inhabited N] (f : M → N) : CallArg M → CallArg N + ⟨f patterns.ann, patterns.val.map (fun p => + match hp: p with + | .pattern m exprs => .pattern (f m) ⟨f exprs.ann, exprs.val.map (Expression.mapMetadata f)⟩)⟩ + (Expression.mapMetadata f body) + termination_by SizeOf.sizeOf e + decreasing_by + all_goals (simp_wf <;> try omega) + . cases args ; simp_all + rename_i h; have := Array.sizeOf_lt_of_mem h; omega + . cases exprs; cases patterns; simp_all; subst_vars + rename_i h1 h2 + have := Array.sizeOf_lt_of_mem h1 + have Hpsz := Array.sizeOf_lt_of_mem h2 + simp at Hpsz; omega + +def CallArg.mapMetadata [Inhabited N] (f : M → N) : CallArg M → CallArg N | .callArgExpr m e => .callArgExpr (f m) (Expression.mapMetadata f e) | .callArgOut m id => .callArgOut (f m) (mapAnn f id) | .callArgInout m id => .callArgInout (f m) (mapAnn f id) -partial def OneIfCase.mapMetadata [Inhabited N] (f : M → N) : OneIfCase M → OneIfCase N - | .oneIfCase m cond body => .oneIfCase (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f body) - -partial def Statement.mapMetadata [Inhabited N] (f : M → N) : Statement M → Statement N +def Statement.mapMetadata [Inhabited N] (f : M → N) (s: Statement M) : Statement N := + match s with | .varDecl m name ty autoinv init => .varDecl (f m) (mapAnn f name) ⟨f ty.ann, ty.val.map (mapAnn f)⟩ @@ -263,40 +272,54 @@ partial def Statement.mapMetadata [Inhabited N] (f : M → N) : Statement M → | .choose m branches => .choose (f m) ⟨f branches.ann, branches.val.map (Statement.mapMetadata f)⟩ | .ifStmt m cond thenB elseB => .ifStmt (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f thenB) - ⟨f elseB.ann, elseB.val.map (Statement.mapMetadata f)⟩ - | .ifCase m cases => .ifCase (f m) ⟨f cases.ann, cases.val.map (OneIfCase.mapMetadata f)⟩ + -- Unlike List and Array, Option.map does not use `attach` by default for wf proofs + ⟨f elseB.ann, elseB.val.attach.map (fun x => Statement.mapMetadata f x.1)⟩ + | .ifCase m cases => .ifCase (f m) ⟨f cases.ann, cases.val.map (fun o => + match ho: o with + | .oneIfCase m cond body => .oneIfCase (f m) (Expression.mapMetadata f cond) (Statement.mapMetadata f body))⟩ | .loop m invariants body => .loop (f m) ⟨f invariants.ann, invariants.val.map (Expression.mapMetadata f)⟩ (Statement.mapMetadata f body) | .labeledStmt m label stmt => .labeledStmt (f m) (mapAnn f label) (Statement.mapMetadata f stmt) | .exit m label => .exit (f m) ⟨f label.ann, label.val.map (mapAnn f)⟩ | .returnStmt m => .returnStmt (f m) | .probe m label => .probe (f m) (mapAnn f label) - -partial def ParamMode.mapMetadata [Inhabited N] (f : M → N) : ParamMode M → ParamMode N + decreasing_by + all_goals (simp_wf; try omega) + . cases stmts; simp_all; subst_vars + rename_i h; have :=Array.sizeOf_lt_of_mem h; omega + . cases branches; simp_all; subst_vars + rename_i h; have :=Array.sizeOf_lt_of_mem h; omega + . cases elseB; cases x + case mk x xin => + simp_all; subst_vars; simp; omega + . cases cases; simp_all; subst_vars + rename_i h; have :=Array.sizeOf_lt_of_mem h; simp_all; omega + +def ParamMode.mapMetadata [Inhabited N] (f : M → N) : ParamMode M → ParamMode N | .paramModeIn m => .paramModeIn (f m) | .paramModeOut m => .paramModeOut (f m) | .paramModeInout m => .paramModeInout (f m) -partial def FParameter.mapMetadata [Inhabited N] (f : M → N) : FParameter M → FParameter N +def FParameter.mapMetadata [Inhabited N] (f : M → N) : FParameter M → FParameter N | .fParameter m injective name ty => .fParameter (f m) (mapAnn f injective) (mapAnn f name) (mapAnn f ty) -partial def PParameter.mapMetadata [Inhabited N] (f : M → N) : PParameter M → PParameter N +def PParameter.mapMetadata [Inhabited N] (f : M → N) : PParameter M → PParameter N | .pParameter m mode name ty autoinv => .pParameter (f m) (ParamMode.mapMetadata f mode) (mapAnn f name) (mapAnn f ty) ⟨f autoinv.ann, autoinv.val.map (Expression.mapMetadata f)⟩ -partial def Spec.mapMetadata [Inhabited N] (f : M → N) : Spec M → Spec N +def Spec.mapMetadata [Inhabited N] (f : M → N) : Spec M → Spec N | .specRequires m expr => .specRequires (f m) (Expression.mapMetadata f expr) | .specEnsures m expr => .specEnsures (f m) (Expression.mapMetadata f expr) -partial def When.mapMetadata [Inhabited N] (f : M → N) : When M → When N +def When.mapMetadata [Inhabited N] (f : M → N) : When M → When N | .when m cond => .when (f m) (Expression.mapMetadata f cond) -partial def FunctionBody.mapMetadata [Inhabited N] (f : M → N) : FunctionBody M → FunctionBody N +def FunctionBody.mapMetadata [Inhabited N] (f : M → N) : FunctionBody M → FunctionBody N | .functionBody m whens body => .functionBody (f m) ⟨f whens.ann, whens.val.map (When.mapMetadata f)⟩ (Expression.mapMetadata f body) -partial def Decl.mapMetadata [Inhabited N] (f : M → N) : Decl M → Decl N +def Decl.mapMetadata [Inhabited N] (f : M → N) : Decl M → Decl N | .typeDecl m name => .typeDecl (f m) (mapAnn f name) | .tagger m name forType => .tagger (f m) (mapAnn f name) (mapAnn f forType) | .function m name params resultType tag body => @@ -310,21 +333,21 @@ partial def Decl.mapMetadata [Inhabited N] (f : M → N) : Decl M → Decl N ⟨f specs.ann, specs.val.map (Spec.mapMetadata f)⟩ ⟨f body.ann, body.val.map (Statement.mapMetadata f)⟩ -partial def Program.mapMetadata [Inhabited N] (f : M → N) : Program M → Program N +def Program.mapMetadata [Inhabited N] (f : M → N) : Program M → Program N | .program m decls => .program (f m) ⟨f decls.ann, decls.val.map (Decl.mapMetadata f)⟩ end -partial def Expression.toUnit [Inhabited (Expression Unit)] (e : Expression M) : Expression Unit := +def Expression.toUnit [Inhabited (Expression Unit)] (e : Expression M) : Expression Unit := e.mapMetadata (fun _ => ()) -partial def Statement.toUnit [Inhabited (Expression Unit)] (s : Statement M) : Statement Unit := +def Statement.toUnit [Inhabited (Expression Unit)] (s : Statement M) : Statement Unit := s.mapMetadata (fun _ => ()) -partial def Decl.toUnit [Inhabited (Expression Unit)] (d : Decl M) : Decl Unit := +def Decl.toUnit [Inhabited (Expression Unit)] (d : Decl M) : Decl Unit := d.mapMetadata (fun _ => ()) -partial def Program.toUnit [Inhabited (Expression Unit)] (p : Program M) : Program Unit := +def Program.toUnit [Inhabited (Expression Unit)] (p : Program M) : Program Unit := p.mapMetadata (fun _ => ()) end B3AST From deca6333a003478d8689c64f1fa890ed98f7a0c2 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 30 Dec 2025 10:12:20 -0600 Subject: [PATCH 21/24] refactor(B3): Simplify variable lookup logic and improve error handling - Simplify lookup function by removing redundant bounds check - Refactor lookupLast to use accumulator pattern for finding last occurrence - Use record update syntax in FromCSTContext.push - Improve code readability and maintainability --- .../Languages/B3/DDMTransform/Conversion.lean | 76 +++++++++---------- .../Languages/B3/DDMTransform/ParseCST.lean | 7 +- .../B3/DDMFormatExpressionsTests.lean | 2 +- 3 files changed, 41 insertions(+), 44 deletions(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index b3ed72676..5891421b3 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -248,34 +248,30 @@ private def resolveVarName (vars : List String) (name : String) (idx : Nat) : St go vars 0 idx def lookup (ctx : ToCSTContext) (idx : Nat) (m : M) : String × Bool × List (ASTToCSTError M) := - -- First check if index is out of bounds - if idx >= ctx.vars.length then - (s!"@{idx}", false, [.variableOutOfBounds idx ctx.vars.length m]) - else - match ctx.vars[idx]? with - | .some name => - if name == "" then (s!"@{idx}", false, []) else - -- Determine if this is an old value: first occurrence with shadowing - let isOld := - -- Check if there's a later occurrence (lower index) with the same name - ctx.vars.take idx |>.any (· == name) - -- Old values in procedure contexts are always supported - if isOld && ctx.inProcedure then - (name, true, []) + match ctx.vars[idx]? with + | .some name => + if name == "" then (s!"@{idx}", false, []) else + -- Determine if this is an old value: first occurrence with shadowing + let isOld := + -- Check if there's a later occurrence (lower index) with the same name + ctx.vars.take idx |>.any (· == name) + -- Old values in procedure contexts are always supported + if isOld && ctx.inProcedure then + (name, true, []) + else + -- Check if this reference is supported in concrete syntax + if !ctx.isSupported idx then + -- Not supported - return error + let resolvedName := if isOld then name else resolveVarName ctx.vars name idx + (resolvedName, isOld, [.unsupportedVariableReference idx m]) else - -- Check if this reference is supported in concrete syntax - if !ctx.isSupported idx then - -- Not supported - return error - let resolvedName := if isOld then name else resolveVarName ctx.vars name idx - (resolvedName, isOld, [.unsupportedVariableReference idx m]) + -- Supported - return without error + if isOld then + (name, true, []) else - -- Supported - return without error - if isOld then - (name, true, []) - else - (resolveVarName ctx.vars name idx, false, []) - | .none => - (s!"@{idx}", false, [.variableOutOfBounds idx ctx.vars.length m]) + (resolveVarName ctx.vars name idx, false, []) + | .none => + (s!"@{idx}", false, [.variableOutOfBounds idx ctx.vars.length m]) def push (ctx : ToCSTContext) (name : String) : ToCSTContext := { vars := name :: ctx.vars, inProcedure := ctx.inProcedure } @@ -595,29 +591,25 @@ structure FromCSTContext where namespace FromCSTContext def lookup (ctx : FromCSTContext) (name : String) (m : M) : Nat × List (CSTToASTError M) := - let idx := ctx.vars.findIdx? (· == name) |>.getD ctx.vars.length - if idx >= ctx.vars.length then - (idx, [.unresolvedIdentifier name m]) - else + match ctx.vars.findIdx? (· == name) with + | .some idx => (idx, []) + | .none => + (ctx.vars.length, [.unresolvedIdentifier name m]) def lookupLast (ctx : FromCSTContext) (name : String) (m : M) : Nat × List (CSTToASTError M) := - -- Find the last occurrence by searching from the end - let rec findLast (vars : List String) (idx : Nat) : Option Nat := + let rec findLast (vars : List String) (idx : Nat) (acc : Option Nat) : Option Nat := match vars with - | [] => none + | [] => acc | v :: vs => - match findLast vs (idx + 1) with - | some found => some found - | none => if v == name then some idx else none - let idx := findLast ctx.vars 0 |>.getD ctx.vars.length - if idx >= ctx.vars.length then - (idx, [.unresolvedIdentifier name m]) - else - (idx, []) + let newAcc := if v == name then some idx else acc + findLast vs (idx + 1) newAcc + match findLast ctx.vars 0 none with + | some idx => (idx, []) + | none => (ctx.vars.length, [.unresolvedIdentifier name m]) def push (ctx : FromCSTContext) (name : String) : FromCSTContext := - { vars := name :: ctx.vars } + { ctx with vars := name :: ctx.vars } def empty : FromCSTContext := { vars := [] } diff --git a/Strata/Languages/B3/DDMTransform/ParseCST.lean b/Strata/Languages/B3/DDMTransform/ParseCST.lean index 0803f823e..bc4302670 100644 --- a/Strata/Languages/B3/DDMTransform/ParseCST.lean +++ b/Strata/Languages/B3/DDMTransform/ParseCST.lean @@ -12,7 +12,12 @@ import Strata.DDM.Util.Format namespace Strata --------------------------------------------------------------------- --- B3AST DDM Dialect for Abstract Syntax Tree +-- B3CST DDM Dialect for Concrete Syntax Tree +--------------------------------------------------------------------- +-- B3CST represents the concrete syntax with named identifiers (e.g., "x", "y"). +-- Used for parsing user-written code and formatting/pretty-printing. +-- Variables are referenced by name, which must be resolved to indices. +-- Supports "old x" syntax for referencing previous values of inout parameters. --------------------------------------------------------------------- #dialect diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index 5f85d2cfc..6df15a226 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -78,7 +78,7 @@ def roundtripExpr (p : Program) : Format := section ExpressionRoundtripTests --- We are loosing the context so this is why it's printing that way. +-- We are losing the context so this is why it's printing that way. /-- info: B3: .id () 0 CST→AST Errors: From 4202956d651206ae7d6463933ae4b3d3430c93d1 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 30 Dec 2025 10:29:01 -0600 Subject: [PATCH 22/24] docs(B3): Add comment explaining AST vs CST differences Address review feedback by documenting how the B3 AST differs from the CST: - AST uses de Bruijn indices instead of identifier names - AST has unified constructs where CST has multiple syntactic forms - Note that conversions can return error lists Also fix unused variable warning in pattern match. --- .../B3/DDMTransform/DefinitionAST.lean | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/B3/DDMTransform/DefinitionAST.lean b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean index 1a0e062fc..5622cb5b5 100644 --- a/Strata/Languages/B3/DDMTransform/DefinitionAST.lean +++ b/Strata/Languages/B3/DDMTransform/DefinitionAST.lean @@ -15,6 +15,22 @@ namespace Strata -- B3AST DDM Dialect for Abstract Syntax Tree --------------------------------------------------------------------- +/-! +# B3 Abstract Syntax Tree (AST) + +The B3 AST differs from the B3 CST in two ways. First, the AST uses de Bruijn indices for +variable references instead of identifier names. Where the CST parses `i` and `old i` as +distinct identifiers, the AST represents both as de Bruijn bound variables. Second, where +the CST has multiple syntactic forms for the same semantic construct, the AST has a single +canonical representation. + +The CST is suitable for parsing and pretty-printing the B3 language, while the AST is +suitable as a target for encoding Strata Core. The bidirectional conversion in +`Conversion.lean` handles name resolution, de Bruijn index assignment, and special cases +like shadowed variables and `inout` parameters (modeled as two context values). Conversions +return a list of errors for issues like unresolved identifiers or out-of-bounds references. +-/ + #dialect dialect B3AST; @@ -234,7 +250,7 @@ def Expression.mapMetadata [Inhabited N] (f : M → N) (e: Expression M) :Expres | .quantifierExpr m qkind var ty patterns body => .quantifierExpr (f m) (QuantifierKind.mapMetadata f qkind) (mapAnn f var) (mapAnn f ty) ⟨f patterns.ann, patterns.val.map (fun p => - match hp: p with + match _: p with | .pattern m exprs => .pattern (f m) ⟨f exprs.ann, exprs.val.map (Expression.mapMetadata f)⟩)⟩ (Expression.mapMetadata f body) termination_by SizeOf.sizeOf e From 5c7498a1fd322049db95d7017042a82bfc138635 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Tue, 30 Dec 2025 14:31:18 -0600 Subject: [PATCH 23/24] fix(B3): Update tests for DDM formatting API changes Adapt B3 test files to work with the new DDM formatting API introduced in PR #287: - Replace private 'cformat' with 'mformat(...).format' - Replace private 'formatContext' with 'FormatContext.ofDialects' - Replace private 'formatState' with manual FormatState construction The DDM module refactoring made these methods private, requiring tests to use the public API directly. --- StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean | 8 ++++---- StrataTest/Languages/B3/DDMFormatExpressionsTests.lean | 6 +++--- StrataTest/Languages/B3/DDMFormatProgramsTests.lean | 4 ++-- StrataTest/Languages/B3/DDMFormatStatementsTests.lean | 6 +++--- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 959ae3872..44cc58dd0 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -34,7 +34,7 @@ partial def doRoundtripDecl (decl : OperationF SourceRange) (ctx : FormatContext String.join parts dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstDecl'.toAst - cformat (ArgF.op cstAst) ctx state + (mformat (ArgF.op cstAst) ctx state).format | .error msg => s!"Parse error: {msg}" partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatContext) (state : FormatState) (printIntermediate: Bool := true) : Format := @@ -61,12 +61,12 @@ partial def doRoundtripProgram (prog : OperationF SourceRange) (ctx : FormatCont else f!"{errorStr}") let cstAst := cstProg'.toAst - cformat (ArgF.op cstAst) ctx state + (mformat (ArgF.op cstAst) ctx state).format | .error msg => s!"Parse error: {msg}" def roundtripDecl (p : Program) : Format := - let ctx := p.formatContext {} - let state := p.formatState + let ctx := FormatContext.ofDialects p.dialects p.globalContext {} + let state : FormatState := { openDialects := p.dialects.toList.foldl (init := {}) fun a d => a.insert d.name } match p.commands.toList with | [op] => if op.name.name == "command_program" then diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index 6df15a226..e49a2518a 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -36,13 +36,13 @@ partial def doRoundtrip (e : OperationF SourceRange) (ctx : FormatContext) (stat String.join parts dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstExpr'.toAst - cformat (ArgF.op cstAst) ctx state + (mformat (ArgF.op cstAst) ctx state).format | .error msg => s!"Parse error: {msg}" -- Helper to extract expression from a program and apply round-trip transformation def roundtripExpr (p : Program) : Format := - let ctx := p.formatContext {} - let state := p.formatState + let ctx := FormatContext.ofDialects p.dialects p.globalContext {} + let state : FormatState := { openDialects := p.dialects.toList.foldl (init := {}) fun a d => a.insert d.name } match p.commands.toList with | [op] => if op.name.name == "command_stmt" then diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean index 82eeac4ef..e5d855092 100644 --- a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -14,8 +14,8 @@ open Strata open Strata.B3CST def roundtripProgram (p : Program) : Format := - let ctx := p.formatContext {} - let state := p.formatState + let ctx := FormatContext.ofDialects p.dialects p.globalContext {} + let state : FormatState := { openDialects := p.dialects.toList.foldl (init := {}) fun a d => a.insert d.name } match p.commands.toList with | [op] => if op.name.name == "command_program" then diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index 1d8356f10..5c48127c3 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -36,13 +36,13 @@ partial def doRoundtripStmt (stmt : OperationF SourceRange) (ctx : FormatContext String.join parts dbg_trace f!"B3: {reprStr}{errorStr}" let cstAst := cstStmt'.toAst - cformat (ArgF.op cstAst) ctx state + (mformat (ArgF.op cstAst) ctx state).format | .error msg => s!"Parse error: {msg}" -- Helper to extract statement from a program and apply round-trip transformation def roundtripStmt (p : Program) : Format := - let ctx := p.formatContext {} - let state := p.formatState + let ctx := FormatContext.ofDialects p.dialects p.globalContext {} + let state : FormatState := { openDialects := p.dialects.toList.foldl (init := {}) fun a d => a.insert d.name } match p.commands.toList with | [op] => if op.name.name == "command_stmt" then From dc85d0827e5aad55dd01aa83da3695ce7462f834 Mon Sep 17 00:00:00 2001 From: Mikael Mayer Date: Wed, 31 Dec 2025 09:41:36 -0600 Subject: [PATCH 24/24] Review comments --- Strata/Languages/B3/DDMTransform/Conversion.lean | 2 +- .../Languages/B3/DDMFormatDeclarationsTests.lean | 7 +++++++ .../Languages/B3/DDMFormatExpressionsTests.lean | 15 +++++++++++++++ .../Languages/B3/DDMFormatProgramsTests.lean | 7 +++++++ .../Languages/B3/DDMFormatStatementsTests.lean | 7 +++++++ StrataTest/Languages/B3/DDMFormatTests.lean | 7 +++++++ 6 files changed, 44 insertions(+), 1 deletion(-) diff --git a/Strata/Languages/B3/DDMTransform/Conversion.lean b/Strata/Languages/B3/DDMTransform/Conversion.lean index 5891421b3..990a7cc6e 100644 --- a/Strata/Languages/B3/DDMTransform/Conversion.lean +++ b/Strata/Languages/B3/DDMTransform/Conversion.lean @@ -10,7 +10,7 @@ import Strata.Languages.B3.DDMTransform.DefinitionAST /-! # B3 ↔ DDM Bidirectional Conversion -This module provides bidirectional conversion between B3 AST types and DDM AST types. +This module provides bidirectional conversion between B3 AST types and B3 CST types. ## B3AST → B3CST Conversion Converts abstract syntax (de Bruijn indices) to concrete syntax (named identifiers). diff --git a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean index 44cc58dd0..6e8971574 100644 --- a/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatDeclarationsTests.lean @@ -7,6 +7,13 @@ import StrataTest.Languages.B3.DDMFormatTests import Strata.Languages.B3.DDMTransform.Conversion +/-! +# B3 Declaration Formatting Tests + +Tests for round-trip conversion and formatting of B3 declarations (types, functions, axioms, procedures). +Verifies that DDM AST → B3 AST → B3 CST → formatted output preserves structure and catches conversion errors. +-/ + namespace B3 open Std (Format) diff --git a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean index e49a2518a..3c975a6af 100644 --- a/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatExpressionsTests.lean @@ -7,6 +7,21 @@ import StrataTest.Languages.B3.DDMFormatTests import Strata.Languages.B3.DDMTransform.Conversion +/-! +# B3 Expression Formatting Tests + +Tests for round-trip conversion and formatting of B3 expressions. +Verifies that DDM AST → B3 AST → B3 CST → formatted output preserves structure and catches conversion errors. + +## Note on Test Syntax + +Expressions are wrapped in `check` statements (e.g., `check 5 + 3`) because: +- our encoding of the B3 grammar doesn't allow bare expressions at the top level. +- Commands can only contain statements and declarations, not expressions +- The test extracts only the expression from the `check` statement for round-trip testing +- The `check` wrapper itself is not part of the tested AST - only the expression `5 + 3` is tested +-/ + namespace B3 open Std (Format) diff --git a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean index e5d855092..7bf2f21fc 100644 --- a/StrataTest/Languages/B3/DDMFormatProgramsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatProgramsTests.lean @@ -7,6 +7,13 @@ import StrataTest.Languages.B3.DDMFormatDeclarationsTests import Strata.Languages.B3.DDMTransform.Conversion +/-! +# B3 Program Formatting Tests + +Tests for round-trip conversion and formatting of complete B3 programs. +Verifies that DDM AST → B3 AST → B3 CST → formatted output preserves structure and catches conversion errors. +-/ + namespace B3 open Std (Format) diff --git a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean index 5c48127c3..3286fb100 100644 --- a/StrataTest/Languages/B3/DDMFormatStatementsTests.lean +++ b/StrataTest/Languages/B3/DDMFormatStatementsTests.lean @@ -7,6 +7,13 @@ import StrataTest.Languages.B3.DDMFormatTests import Strata.Languages.B3.DDMTransform.Conversion +/-! +# B3 Statement Formatting Tests + +Tests for round-trip conversion and formatting of B3 statements. +Verifies that DDM AST → B3 AST → B3 CST → formatted output preserves structure and catches conversion errors. +-/ + namespace B3 open Std (Format) diff --git a/StrataTest/Languages/B3/DDMFormatTests.lean b/StrataTest/Languages/B3/DDMFormatTests.lean index f2bfd2b63..22c448b23 100644 --- a/StrataTest/Languages/B3/DDMFormatTests.lean +++ b/StrataTest/Languages/B3/DDMFormatTests.lean @@ -8,6 +8,13 @@ import Strata.Languages.B3.DDMTransform.ParseCST import Strata.Languages.B3.DDMTransform.DefinitionAST import Strata.Languages.B3.DDMTransform.Conversion +/-! +# B3 DDM Formatting Test Utilities + +Common utilities and helper functions for B3 formatting tests. +Provides string cleanup functions and shared formatting infrastructure used across expression, statement, declaration, and program formatting tests. +-/ + namespace B3 open Std (Format)