diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0285403a6..8741ff2da 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -108,6 +108,7 @@ jobs: run: | ./run_py_analyze.sh ./run_py_analyze.sh laurel + ./run_py_analyze.sh --incremental laurel python run_py_analyze_sarif.py python run_py_analyze_sarif.py --laurel - name: Run regex differential tests diff --git a/Strata/Backends/CBMC/CoreToCBMC.lean b/Strata/Backends/CBMC/CoreToCBMC.lean index 987c190b7..54d2bb250 100644 --- a/Strata/Backends/CBMC/CoreToCBMC.lean +++ b/Strata/Backends/CBMC/CoreToCBMC.lean @@ -208,7 +208,8 @@ end def listToExpr (l: ListMap CoreLabel Core.Procedure.Check) : Core.Expression.Expr := match l with - | _ => .true () + -- CBMC does not track source locations; SourceRange.none is used for synthesized expressions. + | _ => .true Strata.SourceRange.none def createContractSymbolFromAST (func : Core.Procedure) : Except String CBMCSymbol := do let location : Location := { diff --git a/Strata/DDM/Util/SourceRange.lean b/Strata/DDM/Util/SourceRange.lean index f64a65b03..dbb0dbf9e 100644 --- a/Strata/DDM/Util/SourceRange.lean +++ b/Strata/DDM/Util/SourceRange.lean @@ -25,7 +25,12 @@ structure SourceRange where start : String.Pos.Raw /-- One past the end of the range. -/ stop : String.Pos.Raw -deriving DecidableEq, Inhabited, Repr +deriving DecidableEq, Inhabited + +/-- Compact repr: always displays as `()` to keep debug output readable. + Source location info is available via `SourceRange.format`. -/ +instance : Repr SourceRange where + reprPrec _ _ := "()" namespace SourceRange @@ -33,6 +38,11 @@ def none : SourceRange := { start := 0, stop := 0 } def isNone (loc : SourceRange) : Bool := loc.start = 0 ∧ loc.stop = 0 +/-- info: "()" -/ +#guard_msgs in #eval toString (reprPrec (none : SourceRange) 0) +/-- info: "()" -/ +#guard_msgs in #eval toString (reprPrec ({ start := ⟨5⟩, stop := ⟨10⟩ } : SourceRange) 0) + instance : Std.ToFormat SourceRange where format fr := f!"{fr.start}-{fr.stop}" diff --git a/Strata/DL/Lambda/LExpr.lean b/Strata/DL/Lambda/LExpr.lean index 983a0f489..8dd92a3ae 100644 --- a/Strata/DL/Lambda/LExpr.lean +++ b/Strata/DL/Lambda/LExpr.lean @@ -618,6 +618,7 @@ open Lean Elab Meta meta class MkLExprParams (T: LExprParams) where elabIdent : Lean.Syntax → MetaM Expr toExpr : Expr + defaultMetadata : MetaM Expr := mkAppM ``Unit.unit #[] declare_syntax_cat lidentmono @@ -644,30 +645,30 @@ meta def mkNegLit (n: NumLit) := Expr.app (.const ``Int.neg []) (mkIntLit n) meta def elabLConstMono [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lconstmono| #$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] let intVal := mkIntLit n let lconstVal ← mkAppM ``LConst.intConst #[intVal] return mkAppN (.const ``LExpr.const []) #[tMono, metadata, lconstVal] | `(lconstmono| #-$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] let intVal := mkNegLit n let lconstVal ← mkAppM ``LConst.intConst #[intVal] return mkAppN (.const ``LExpr.const []) #[tMono, metadata, lconstVal] | `(lconstmono| #true) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] let lconstVal ← mkAppM ``LConst.boolConst #[toExpr true] return mkAppN (.const ``LExpr.const []) #[tMono, metadata, lconstVal] | `(lconstmono| #false) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] let lconstVal ← mkAppM ``LConst.boolConst #[toExpr false] return mkAppN (.const ``LExpr.const []) #[tMono, metadata, lconstVal] | `(lconstmono| #$s:ident) => do let s := toString s.getId - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] let lconstVal ← mkAppM ``LConst.strConst #[mkStrLit s] return mkAppN (.const ``LExpr.const []) #[tMono, metadata, lconstVal] @@ -681,13 +682,13 @@ scoped syntax lopmono : lexprmono meta def elabLOpMono [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lopmono| ~$s:lidentmono) => do let none ← mkNone (mkConst ``LMonoTy) - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.op []) #[tMono, metadata, ← MkLExprParams.elabIdent T s, none] | `(lopmono| (~$s:lidentmono : $ty:lmonoty)) => do let lmonoty ← Lambda.LTy.Syntax.elabLMonoTy ty let lmonoty ← mkSome (mkConst ``LMonoTy) lmonoty - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.op []) #[tMono, metadata, ← MkLExprParams.elabIdent T s, lmonoty] | _ => throwUnsupportedSyntax @@ -696,7 +697,7 @@ declare_syntax_cat lbvarmono scoped syntax "%" noWs num : lbvarmono meta def elabLBVarMono [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lbvarmono| %$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.bvar []) #[tMono, metadata, mkNatLit n.getNat] | _ => throwUnsupportedSyntax @@ -709,13 +710,13 @@ scoped syntax "(" lidentmono ":" lmonoty ")" : lfvarmono meta def elabLFVarMono [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lfvarmono| $i:lidentmono) => do let none ← mkNone (mkConst ``LMonoTy) - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.fvar []) #[tMono, metadata, ← MkLExprParams.elabIdent T i, none] | `(lfvarmono| ($i:lidentmono : $ty:lmonoty)) => do let lmonoty ← Lambda.LTy.Syntax.elabLMonoTy ty let lmonoty ← mkSome (mkConst ``LMonoTy) lmonoty - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.fvar []) #[tMono, metadata, ← MkLExprParams.elabIdent T i, lmonoty] | _ => throwUnsupportedSyntax @@ -766,32 +767,32 @@ meta partial def elabLExprMono [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lexprmono| λ $e:lexprmono) => do let e' ← elabLExprMono (T:=T) e let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T return mkAppN (.const ``LExpr.absUntyped []) #[tMono, metadata, e'] | `(lexprmono| λ ($mty:lmonoty): $e:lexprmono) => do let lmonoty ← Lambda.LTy.Syntax.elabLMonoTy mty let lmonoty ← mkSome (mkConst ``LMonoTy) lmonoty let e' ← elabLExprMono (T:=T) e let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T return mkAppN (.const ``LExpr.abs []) #[tMono, metadata, mkStrLit "", lmonoty, e'] | `(lexprmono| ∀ $e:lexprmono) => do let e' ← elabLExprMono (T:=T) e let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T return mkAppN (.const ``LExpr.allUntyped []) #[tMono, metadata, e'] | `(lexprmono| ∀ {$tr}$e:lexprmono) => do let e' ← elabLExprMono (T:=T) e let tr' ← elabLExprMono (T:=T) tr let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T return mkAppN (.const ``LExpr.allUntypedTr []) #[tMono, metadata, tr', e'] | `(lexprmono| ∀ ($mty:lmonoty): $e:lexprmono) => do let lmonoty ← Lambda.LTy.Syntax.elabLMonoTy mty let lmonoty ← mkSome (mkConst ``LMonoTy) lmonoty let e' ← elabLExprMono (T:=T) e let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let emptyName := mkStrLit "" return mkAppN (.const ``LExpr.all []) #[tMono, metadata, emptyName, lmonoty, e'] | `(lexprmono| ∀ ($mty:lmonoty):{$tr} $e:lexprmono) => do @@ -800,7 +801,7 @@ meta partial def elabLExprMono [MkLExprParams T] : Lean.Syntax → MetaM Expr let e' ← elabLExprMono (T:=T) e let tr' ← elabLExprMono (T:=T) tr let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let emptyName := mkStrLit "" return mkAppN (.const ``LExpr.allTr []) #[tMono, metadata, emptyName, lmonoty, tr', e'] | `(lexprmono| ∃ ($mty:lmonoty): $e:lexprmono) => do @@ -808,7 +809,7 @@ meta partial def elabLExprMono [MkLExprParams T] : Lean.Syntax → MetaM Expr let lmonoty ← mkSome (mkConst ``LMonoTy) lmonoty let e' ← elabLExprMono (T:=T) e let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let emptyName := mkStrLit "" return mkAppN (.const ``LExpr.exist []) #[tMono, metadata, emptyName, lmonoty, e'] | `(lexprmono| ∃ ($mty:lmonoty):{$tr} $e:lexprmono) => do @@ -817,37 +818,37 @@ meta partial def elabLExprMono [MkLExprParams T] : Lean.Syntax → MetaM Expr let e' ← elabLExprMono (T:=T) e let tr' ← elabLExprMono (T:=T) tr let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let emptyName := mkStrLit "" return mkAppN (.const ``LExpr.existTr []) #[tMono, metadata, emptyName, lmonoty, tr', e'] | `(lexprmono| ∃ $e:lexprmono) => do let e' ← elabLExprMono (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.existUntyped []) #[tMono, metadata, e'] | `(lexprmono| ∃{$tr} $e:lexprmono) => do let e' ← elabLExprMono (T:=T) e let tr' ← elabLExprMono (T:=T) tr - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.existUntypedTr []) #[tMono, metadata, tr', e'] | `(lexprmono| ($e1:lexprmono $e2:lexprmono)) => do let e1' ← elabLExprMono (T:=T) e1 let e2' ← elabLExprMono (T:=T) e2 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.app []) #[tMono, metadata, e1', e2'] | `(lexprmono| $e1:lexprmono == $e2:lexprmono) => do let e1' ← elabLExprMono (T:=T) e1 let e2' ← elabLExprMono (T:=T) e2 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.eq []) #[tMono, metadata, e1', e2'] | `(lexprmono| if $e1:lexprmono then $e2:lexprmono else $e3:lexprmono) => do let e1' ← elabLExprMono (T:=T) e1 let e2' ← elabLExprMono (T:=T) e2 let e3' ← elabLExprMono (T:=T) e3 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let tMono ← mkAppM ``LExprParams.mono #[MkLExprParams.toExpr T] return mkAppN (.const ``LExpr.ite []) #[tMono, metadata, e1', e2', e3'] | `(lexprmono| ($e:lexprmono)) => elabLExprMono (T:=T) e @@ -886,6 +887,7 @@ open Lean Elab Meta meta class MkLExprParams (T: LExprParams) where elabIdent : Lean.Syntax → MetaM Expr toExpr : Expr + defaultMetadata : MetaM Expr := mkAppM ``Unit.unit #[] declare_syntax_cat lident @@ -912,30 +914,30 @@ meta def mkNegLit (n: NumLit) := Expr.app (.const ``Int.neg []) (mkIntLit n) meta def elabLConst [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lconst| #$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let lconstVal ← mkAppM ``LConst.intConst #[mkIntLit n] return mkAppN (.const ``LExpr.const []) #[tParams, metadata, lconstVal] | `(lconst| #-$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let lconstVal ← mkAppM ``LConst.intConst #[mkNegLit n] return mkAppN (.const ``LExpr.const []) #[tParams, metadata, lconstVal] | `(lconst| #true) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.boolConst []) #[tParams, metadata, toExpr true] | `(lconst| #false) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.boolConst []) #[tParams, metadata, toExpr false] | `(lconst| #$s:ident) => do let s := toString s.getId - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.const []) #[tParams, metadata, mkStrLit s] @@ -950,14 +952,14 @@ meta def elabLOp [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lop| ~$s:lident) => do let none ← mkNone (mkConst ``LTy) let ident ← MkLExprParams.elabIdent T s - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.op []) #[tParams, metadata, ident, none] | `(lop| (~$s:lident : $ty:lty)) => do let lty ← Lambda.LTy.Syntax.elabLTy ty let lty ← mkSome (mkConst ``LTy) lty - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.op []) #[tParams, metadata, ← MkLExprParams.elabIdent T s, lty] @@ -968,7 +970,7 @@ scoped syntax "%" noWs num : lbvar meta def elabLBVar [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lbvar| %$n:num) => do - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.bvar []) #[tParams, metadata, mkNatLit n.getNat] @@ -982,14 +984,14 @@ scoped syntax "(" lident ":" lty ")" : lfvar meta def elabLFVar [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lfvar| $i:lident) => do let none ← mkNone (mkConst ``LTy) - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.fvar []) #[tParams, metadata, ← MkLExprParams.elabIdent T i, none] | `(lfvar| ($i:lident : $ty:lty)) => do let lty ← Lambda.LTy.Syntax.elabLTy ty let lty ← mkSome (mkConst ``LTy) lty - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.fvar []) #[tParams, metadata, ← MkLExprParams.elabIdent T i, lty] @@ -1039,7 +1041,7 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr | `(lexpr| $f:lfvar) => elabLFVar (T:=T) f | `(lexpr| λ $e:lexpr) => do let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.absUntyped []) #[tParams, metadata, e'] @@ -1047,20 +1049,20 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let lty ← Lambda.LTy.Syntax.elabLTy mty let lty ← mkSome (mkConst ``LTy) lty let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.abs []) #[tParams, metadata, mkStrLit "", lty, e'] | `(lexpr| ∀ $e:lexpr) => do let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.allUntyped []) #[tParams, metadata, e'] | `(lexpr| ∀{$tr}$e:lexpr) => do let e' ← elabLExpr (T:=T) e let tr' ← elabLExpr (T:=T) tr - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.allUntypedTr []) #[tParams, metadata, tr', e'] @@ -1068,7 +1070,7 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let lty ← Lambda.LTy.Syntax.elabLTy mty let lty ← mkSome (mkConst ``LTy) lty let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let emptyName := mkStrLit "" @@ -1078,7 +1080,7 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let lty ← mkSome (mkConst ``LTy) lty let e' ← elabLExpr (T:=T) e let tr' ← elabLExpr (T:=T) tr - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let emptyName := mkStrLit "" @@ -1087,7 +1089,7 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let lty ← Lambda.LTy.Syntax.elabLTy mty let lty ← mkSome (mkConst ``LTy) lty let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let emptyName := mkStrLit "" @@ -1097,35 +1099,35 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let lty ← mkSome (mkConst ``LTy) lty let e' ← elabLExpr (T:=T) e let tr' ← elabLExpr (T:=T) tr - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) let emptyName := mkStrLit "" return mkAppN (.const ``LExpr.existTr []) #[tParams, metadata, emptyName, lty, tr', e'] | `(lexpr| ∃ $e:lexpr) => do let e' ← elabLExpr (T:=T) e - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.existUntyped []) #[tParams, metadata, e'] | `(lexpr| ∃ {$tr} $e:lexpr) => do let e' ← elabLExpr (T:=T) e let tr' ← elabLExpr (T:=T) tr - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.existUntypedTr []) #[tParams, metadata, tr', e'] | `(lexpr| ($e1:lexpr $e2:lexpr)) => do let e1' ← elabLExpr (T:=T) e1 let e2' ← elabLExpr (T:=T) e2 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.app []) #[tParams, metadata, e1', e2'] | `(lexpr| $e1:lexpr == $e2:lexpr) => do let e1' ← elabLExpr (T:=T) e1 let e2' ← elabLExpr (T:=T) e2 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.eq []) #[tParams, metadata, e1', e2'] @@ -1133,7 +1135,7 @@ meta partial def elabLExpr [MkLExprParams T] : Lean.Syntax → MetaM Expr let e1' ← elabLExpr (T:=T) e1 let e2' ← elabLExpr (T:=T) e2 let e3' ← elabLExpr (T:=T) e3 - let metadata ← mkAppM ``Unit.unit #[] + let metadata ← MkLExprParams.defaultMetadata T let baseParams := MkLExprParams.toExpr T let tParams := mkApp2 (mkConst ``LExprParamsT.mk) baseParams (mkConst ``LTy) return mkAppN (.const ``LExpr.ite []) #[tParams, metadata, e1', e2', e3'] diff --git a/Strata/DL/SMT/SolverInterface.lean b/Strata/DL/SMT/SolverInterface.lean new file mode 100644 index 000000000..e2b8a5ba2 --- /dev/null +++ b/Strata/DL/SMT/SolverInterface.lean @@ -0,0 +1,110 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.SMT.Solver +import Strata.DL.SMT.Term +import Strata.DL.SMT.TermType +import Strata.DL.SMT.DDMTransform.Translate +import Strata.Languages.Core.Options + +/-! +# SMT Solver Interface + +Abstract interface for SMT solvers using `Strata.SMT.Term` and `Strata.SMT.TermType`. +Converts to SMT-LIB strings via `SMTDDM.toString` when communicating with solvers. + +The interface is a structure (not a type class) to allow runtime selection of +different solver backends. +-/ + +namespace Strata.SMT + +open Strata.SMT + +/-- Abstract interface for SMT solvers. + Uses Strata.SMT.Term which can be converted to SMT-LIB strings via SMTDDM.toString -/ +structure SolverInterface where + /-- Push a new scope onto the solver stack -/ + push : IO Unit + /-- Pop the top scope from the solver stack -/ + pop : IO Unit + /-- Declare an uninterpreted sort -/ + declareSort : String → Nat → IO Unit + /-- Declare an uninterpreted function -/ + declareFun : String → List TermType → TermType → IO Unit + /-- Define a function with a body -/ + defineFun : String → List (String × TermType) → TermType → Term → IO Unit + /-- Assert a term -/ + assert : Term → IO Unit + /-- Check satisfiability -/ + checkSat : IO Decision + /-- Check satisfiability with assumptions (check-sat-assuming) -/ + checkSatAssuming : List Term → IO Decision + /-- Get model values for variables -/ + getModel : List String → IO (List (String × String)) + /-- Reset the solver state -/ + reset : IO Unit + +/-- Helper to convert Term to SMT-LIB string -/ +private def termToString (t : Term) : Except String String := + Strata.SMTDDM.termToString t + +/-- Helper to create an SMTSolverInterface from an initialized Solver -/ +def mkSolverInterfaceFromSolver (solver : Solver) : IO SolverInterface := do + let solverRef ← IO.mkRef solver + return { + push := do + let s ← solverRef.get + s.smtLibInput.putStr "(push 1)\n" + s.smtLibInput.flush + pop := do + let s ← solverRef.get + s.smtLibInput.putStr "(pop 1)\n" + s.smtLibInput.flush + declareSort := fun name arity => do + let _ ← (Solver.declareSort name arity).run (← solverRef.get) + declareFun := fun name argTypes retType => do + let _ ← (Solver.declareFun name argTypes retType).run (← solverRef.get) + defineFun := fun name args retType body => do + let _ ← (Solver.defineFunTerm name args retType body).run (← solverRef.get) + assert := fun term => do + let _ ← (Solver.assert term).run (← solverRef.get) + checkSat := do + (Solver.checkSat []).run (← solverRef.get) >>= fun (d, _) => pure d + checkSatAssuming := fun assumptions => do + let s ← solverRef.get + let assumptionStrs ← assumptions.mapM fun a => + match termToString a with + | .ok str => pure str + | .error e => throw (IO.userError s!"Failed to convert term to string: {e}") + let assumptionsStr := String.intercalate " " assumptionStrs + s.smtLibInput.putStr s!"(check-sat-assuming ({assumptionsStr}))\n" + s.smtLibInput.flush + match s.smtLibOutput with + | .some stdout => + let result := (← stdout.getLine).trimAscii.toString + match result with + | "sat" => return .sat + | "unsat" => return .unsat + | "unknown" => return .unknown + | other => throw (IO.userError s!"Unrecognized solver output: {other}") + | .none => return .unsat -- Buffer solver: assume proved (no diagnosis) + getModel := fun vars => do + let s ← solverRef.get + let varsStr := String.intercalate " " vars + s.smtLibInput.putStr s!"(get-value ({varsStr}))\n" + s.smtLibInput.flush + match s.smtLibOutput with + | .some stdout => + let response ← stdout.getLine + return vars.map fun v => (v, response) + | .none => return [] + reset := do + let _ ← (Solver.reset).run (← solverRef.get) + let _ ← (Solver.setLogic "ALL").run (← solverRef.get) + : SolverInterface } + +end Strata.SMT diff --git a/Strata/DL/SMT/State.lean b/Strata/DL/SMT/State.lean new file mode 100644 index 000000000..3f3e5fa14 --- /dev/null +++ b/Strata/DL/SMT/State.lean @@ -0,0 +1,76 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.SMT.SolverInterface +import Strata.Languages.Core.Expressions + +/-! +# SMT State and Context Management + +Defines the SMT solver state and context tracking. The state is returned from +verify calls to enable reuse across multiple verification sessions. +-/ + +namespace Strata.SMT + +open Strata.SMT + +/-- A context item represents something added to the SMT solver state -/ +inductive ContextItem where + /-- An assumed expression (as SMT term) -/ + | assumption : Term → ContextItem + /-- A declared sort (name, arity) -/ + | sortDecl : String → Nat → ContextItem + /-- A declared function (name, arg types, return type) -/ + | funcDecl : String → List TermType → TermType → ContextItem + /-- A defined function (name, args, return type, body) -/ + | funcDef : String → List (String × TermType) → TermType → Term → ContextItem + /-- A declared variable (name, type) -/ + | varDecl : String → TermType → ContextItem + /-- A defined variable (name, type, value) -/ + | varDef : String → TermType → Term → ContextItem + +/-- A scope is a list of context items added at the same push level -/ +abbrev ContextScope := List ContextItem + +/-- Context stack: a stack of scopes, where each scope corresponds to a push level. + The head of the list is the current (innermost) scope. -/ +abbrev ContextStack := List ContextScope + +/-- Verification state that can be reused across calls -/ +structure VerifierState where + /-- The SMT solver interface -/ + solver : SMT.SolverInterface + /-- Stack of context scopes (for push/pop support) -/ + contextStack : ContextStack + +/-- Create initial state from a solver interface -/ +def VerifierState.init (solver : SMT.SolverInterface) : VerifierState := + { solver, contextStack := [[]] } + +/-- Push a new scope onto the context stack -/ +def VerifierState.push (state : VerifierState) : IO VerifierState := do + state.solver.push + return { state with contextStack := [] :: state.contextStack } + +/-- Pop the top scope from the context stack -/ +def VerifierState.pop (state : VerifierState) : IO VerifierState := do + state.solver.pop + match state.contextStack with + | [] => return state + | _ :: rest => return { state with contextStack := rest } + +/-- Add an item to the current scope -/ +def VerifierState.addItem (state : VerifierState) (item : ContextItem) : VerifierState := + match state.contextStack with + | [] => { state with contextStack := [[item]] } + | scope :: rest => { state with contextStack := (item :: scope) :: rest } + +/-- Get all context items (flattened from all scopes) for error reporting -/ +def VerifierState.allContextItems (state : VerifierState) : List ContextItem := + state.contextStack.flatten + +end Strata.SMT diff --git a/Strata/Languages/B3/Format.lean b/Strata/Languages/B3/Format.lean new file mode 100644 index 000000000..5646186a6 --- /dev/null +++ b/Strata/Languages/B3/Format.lean @@ -0,0 +1,49 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.Conversion +import Strata.Languages.B3.DDMTransform.DefinitionAST + +/-! +# B3 Formatting Utilities + +Helper functions for formatting B3 AST nodes to strings using DDM. +-/ + +namespace B3 + +open Strata + +/-- Get metadata from B3 expression -/ +def getExpressionMetadata (expr : B3AST.Expression SourceRange) : SourceRange := + match expr with + | .literal m _ => m + | .id m _ => m + | .ite m _ _ _ => m + | .binaryOp m _ _ _ => m + | .unaryOp m _ _ => m + | .functionCall m _ _ => m + | .labeledExpr m _ _ => m + | .letExpr m _ _ _ => m + | .quantifierExpr m _ _ _ _ => m + +/-- Format a DDM operation AST node to string -/ +private def formatOp (prog : Program) (op : Operation) : String := + let fmtCtx := FormatContext.ofDialects prog.dialects prog.globalContext {} + let fmtState : FormatState := { openDialects := prog.dialects.toList.foldl (init := {}) fun a (dialect : Dialect) => a.insert dialect.name } + (mformat (ArgF.op op) fmtCtx fmtState).format.pretty.trimAscii.toString + +/-- Format B3 statement to string -/ +def formatStatement (prog : Program) (stmt : B3AST.Statement SourceRange) (ctx : ToCSTContext) : String := + let (cstStmt, _) := B3.stmtToCST ctx stmt + formatOp prog cstStmt.toAst + +/-- Format B3 expression to string -/ +def formatExpression (prog : Program) (expr : B3AST.Expression SourceRange) (ctx : ToCSTContext) : String := + let (cstExpr, _) := B3.expressionToCST ctx expr + formatOp prog cstExpr.toAst + +end B3 diff --git a/Strata/Languages/B3/FromCore.lean b/Strata/Languages/B3/FromCore.lean new file mode 100644 index 000000000..5ba213e8c --- /dev/null +++ b/Strata/Languages/B3/FromCore.lean @@ -0,0 +1,152 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.DefinitionAST +import Strata.Languages.Core.Expressions +import Strata.DDM.Util.SourceRange + +/-! +# Core to B3 Expression Conversion + +Converts Core expressions back to B3 expressions for display and diagnosis. +This is the inverse of the B3→Core translation in ToCore.lean. +-/ + +namespace Strata.B3.FromCore + +open Strata.B3AST +open Core +open Lambda + +/-- Convert Core type to B3 type string -/ +private def coreTypeToB3Type : LMonoTy → String + | .tcons "int" _ => "int" + | .tcons "bool" _ => "bool" + | .tcons "string" _ => "string" + | .tcons name _ => name + | _ => "int" + +/-- Conversion errors -/ +inductive ConversionError where + | unsupportedCoreExpr (expr : String) + | typeMismatch (expected : String) (got : String) + deriving Repr + +instance : ToString ConversionError where + toString e := match e with + | .unsupportedCoreExpr expr => s!"Unsupported Core expression: {expr}" + | .typeMismatch exp got => s!"Type mismatch: expected {exp}, got {got}" + +/-- Helper to convert constants -/ +def convertConst (sr : SourceRange) (c : Lambda.LConst) : Except ConversionError (B3AST.Expression SourceRange) := + match c with + | Lambda.LConst.boolConst b => Except.ok (.literal sr (.boolLit sr b)) + | Lambda.LConst.intConst i => + if i >= 0 then + Except.ok (.literal sr (.intLit sr i.natAbs)) + else + Except.ok (.unaryOp sr (.neg sr) (.literal sr (.intLit sr i.natAbs))) + | _ => Except.error (.unsupportedCoreExpr "unsupported constant") + +private def binaryOpMap : Std.HashMap String (SourceRange → B3AST.BinaryOp SourceRange) := + Std.HashMap.ofList [ + ("Int.Add", .add), ("Int.Sub", .sub), + ("Int.Mul", .mul), ("Int.Div", .div), + ("Int.Mod", .mod), ("Int.Lt", .lt), + ("Int.Le", .le), ("Int.Gt", .gt), + ("Int.Ge", .ge), ("Bool.And", .and), + ("Bool.Or", .or), ("Bool.Implies",.implies), + ("Eq", .eq), ("Neq", .neq) + ] + +private def unaryOpMap : Std.HashMap String (SourceRange → B3AST.UnaryOp SourceRange) := + Std.HashMap.ofList [("Bool.Not", .not), ("Int.Neg", .neg)] + +mutual + +/-- Helper to convert application expressions -/ +partial def convertApp (sr : SourceRange) (fn arg : Core.Expression.Expr) : Except ConversionError (B3AST.Expression SourceRange) := + match fn with + | Lambda.LExpr.app _ (Lambda.LExpr.op _ name _) lhs => + -- Binary operator + (exprFromCore lhs).bind fun lhsB3 => + (exprFromCore arg).bind fun rhsB3 => + match binaryOpMap.get? name.name with + | some mkOp => Except.ok (.binaryOp sr (mkOp sr) lhsB3 rhsB3) + | none => Except.error (.unsupportedCoreExpr s!"binary operator {name.name}") + | Lambda.LExpr.op _ name _ => + -- Unary operator + (exprFromCore arg).bind fun argB3 => + match unaryOpMap.get? name.name with + | some mkOp => Except.ok (.unaryOp sr (mkOp sr) argB3) + | none => Except.error (.unsupportedCoreExpr s!"unary operator {name.name}") + | Lambda.LExpr.fvar _ name _ => + -- Function call: f(arg) + (exprFromCore arg).bind fun argB3 => + Except.ok (.functionCall sr ⟨sr, name.name⟩ ⟨sr, #[argB3]⟩) + | Lambda.LExpr.app _ (Lambda.LExpr.fvar _ name _) firstArg => + -- Multi-arg function call: f(arg1, arg2, ...) + (exprFromCore firstArg).bind fun firstB3 => + (exprFromCore arg).bind fun argB3 => + Except.ok (.functionCall sr ⟨sr, name.name⟩ ⟨sr, #[firstB3, argB3]⟩) + | _ => Except.error (.unsupportedCoreExpr "unsupported function application") + +/-- Convert Core expression to B3 expression, preserving source locations from Core metadata -/ +partial def exprFromCore (e : Core.Expression.Expr) : Except ConversionError (B3AST.Expression SourceRange) := + match e with + | Lambda.LExpr.const m c => convertConst m c + | Lambda.LExpr.bvar m idx => Except.ok (.id m idx) + | Lambda.LExpr.app m fn arg => convertApp m fn arg + | Lambda.LExpr.ite m cond thn els => + (exprFromCore cond).bind fun condB3 => + (exprFromCore thn).bind fun thnB3 => + (exprFromCore els).bind fun elsB3 => + Except.ok (.ite m condB3 thnB3 elsB3) + | Lambda.LExpr.fvar m name _ => + -- Free variable reference - represent as 0-arg function call + Except.ok (.functionCall m ⟨m, name.name⟩ ⟨m, #[]⟩) + | Lambda.LExpr.eq m lhs rhs => + (exprFromCore lhs).bind fun lhsB3 => + (exprFromCore rhs).bind fun rhsB3 => + Except.ok (.binaryOp m (.eq m) lhsB3 rhsB3) + | Lambda.LExpr.quant m kind name tyOpt trigger body => + let qk := match kind with + | .all => B3AST.QuantifierKind.forall m + | .exist => B3AST.QuantifierKind.exists m + -- Collect all nested quantifiers of the same kind into a var list + let rec collectVars (e : Core.Expression.Expr) (idx : Nat) (acc : List (B3AST.VarDecl SourceRange)) : + List (B3AST.VarDecl SourceRange) × Core.Expression.Expr := + match e with + | Lambda.LExpr.quant (innerM : SourceRange) k innerName innerTyOpt _ innerBody => + if k == kind then + let tyStr := match innerTyOpt with + | some ty => coreTypeToB3Type ty + | none => "int" + let varName := if innerName.isEmpty then s!"x{idx}" else innerName + let varDecl := B3AST.VarDecl.quantVarDecl innerM ⟨innerM, varName⟩ ⟨innerM, tyStr⟩ + collectVars innerBody (idx + 1) (acc ++ [varDecl]) + else (acc, e) + | _ => (acc, e) + let tyStr := match tyOpt with + | some ty => coreTypeToB3Type ty + | none => "int" + let outerVarName := if name.isEmpty then "x0" else name + let outerVar := B3AST.VarDecl.quantVarDecl m ⟨m, outerVarName⟩ ⟨m, tyStr⟩ + let (allVars, innerBody) := collectVars body 1 [outerVar] + -- Convert trigger to patterns + let patterns := match trigger with + | Lambda.LExpr.boolConst _ true => #[] + | _ => + match exprFromCore trigger with + | .ok trigB3 => #[B3AST.Pattern.pattern m ⟨m, #[trigB3]⟩] + | .error _ => #[] + (exprFromCore innerBody).bind fun bodyB3 => + Except.ok (.quantifierExpr m qk ⟨m, allVars.toArray⟩ ⟨m, patterns⟩ bodyB3) + | _ => Except.error (.unsupportedCoreExpr "unsupported expression") + +end + +end Strata.B3.FromCore diff --git a/Strata/Languages/B3/ToCore.lean b/Strata/Languages/B3/ToCore.lean new file mode 100644 index 000000000..2b1fd94c7 --- /dev/null +++ b/Strata/Languages/B3/ToCore.lean @@ -0,0 +1,331 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.B3.DDMTransform.DefinitionAST +import Strata.Languages.Core.Statement +import Strata.Languages.Core.Factory + +/-! +# B3 to Core Conversion + +Converts B3 abstract syntax trees to Strata Core statements for the CoreSMT +verifier pipeline. B3 uses de Bruijn indices for variable references while +Core uses free variables, so the converter maintains a context mapping indices +to Core identifiers. + +## TODO: Architectural Improvements + +1. **B3 → Core.Decl instead of Core.Statement** + - Currently converts to `Imperative.Stmt.funcDecl` (statement) + - Should convert to `Core.Decl.func` (declaration) + - Then add a phase: Core.Decl → CoreSMT statements (subset validation) + - This separates parsing from verification subset validation + +2. **Procedure Support** + - Currently only supports parameterless procedures + - Should convert B3 procedures to `Core.Decl.proc` + - Verification of each procedure done via CoreSMT on statements only +-/ + +namespace Strata.B3.ToCore + +open Strata.B3AST +open Core +open Lambda + +/-- Conversion errors -/ +inductive ConversionError where + | unsupportedFeature (feature : String) (context : String) + deriving Repr + +instance : ToString ConversionError where + toString + | .unsupportedFeature feat ctx => s!"Unsupported feature '{feat}' in {ctx}" + +/-- Conversion result with error collection -/ +structure ConvResult (α : Type) where + value : α + errors : List ConversionError + deriving Repr + +def ConvResult.ok (value : α) : ConvResult α := { value, errors := [] } +def ConvResult.withError (value : α) (error : ConversionError) : ConvResult α := { value, errors := [error] } +def ConvResult.addErrors (result : ConvResult α) (newErrors : List ConversionError) : ConvResult α := + { result with errors := result.errors ++ newErrors } + +instance [Inhabited α] : Inhabited (ConvResult α) where + default := { value := default, errors := [] } + +/-- Conversion context: maps de Bruijn indices to Core identifiers. -/ +structure ConvContext where + vars : List (String × Lambda.LMonoTy) -- index 0 = head + funcs : List (String × List Lambda.LMonoTy × Lambda.LMonoTy) -- (name, argTypes, retType) + boundDepth : Nat := 0 -- number of enclosing quantifiers/abstractions + +def ConvContext.empty : ConvContext := { vars := [], funcs := [] } + +def ConvContext.push (ctx : ConvContext) (name : String) (ty : Lambda.LMonoTy) : ConvContext := + { ctx with vars := (name, ty) :: ctx.vars } + +/-- Push a bound variable (for quantifiers/abstractions) -/ +def ConvContext.pushBound (ctx : ConvContext) (name : String) (ty : Lambda.LMonoTy) : ConvContext := + { ctx with vars := (name, ty) :: ctx.vars, boundDepth := ctx.boundDepth + 1 } + +def ConvContext.addFunc (ctx : ConvContext) (name : String) (argTypes : List Lambda.LMonoTy) (retType : Lambda.LMonoTy) : ConvContext := + { ctx with funcs := (name, argTypes, retType) :: ctx.funcs } + +/-- Look up a function's type as an arrow type -/ +def ConvContext.lookupFuncType (ctx : ConvContext) (name : String) : Option Lambda.LMonoTy := + match ctx.funcs.find? (fun (n, _, _) => n == name) with + | some (_, argTypes, retType) => + some (argTypes.foldr (fun argTy acc => .arrow argTy acc) retType) + | none => none + +/-- Map B3 type name to Core monomorphic type. -/ +def b3TypeToCoreTy (typeName : String) : Lambda.LMonoTy := + match typeName with + | "int" => .tcons "int" [] + | "bool" => .tcons "bool" [] + | "real" => .tcons "real" [] + | "string" => .tcons "string" [] + | other => .tcons other [] + +/-- Map B3 type name to Core type scheme. -/ +def b3TypeToCoreLTy (typeName : String) : Lambda.LTy := + .forAll [] (b3TypeToCoreTy typeName) + + +/-- Convert B3 binary operator to a Core expression builder. + Uses factory operator expressions with proper type annotations. -/ +def convertBinaryOp (sr : SourceRange) (op : BinaryOp M) (lhs rhs : Core.Expression.Expr) : Core.Expression.Expr := + let mkBinApp (opExpr : Core.Expression.Expr) := + .app sr (.app sr opExpr lhs) rhs + match op with + | .eq _ => .eq sr lhs rhs + | .neq _ => .app sr Core.boolNotOp (.eq sr lhs rhs) + | .and _ => mkBinApp Core.boolAndOp + | .or _ => mkBinApp Core.boolOrOp + | .implies _ => mkBinApp Core.boolImpliesOp + | .iff _ => mkBinApp Core.boolEquivOp + | .impliedBy _ => + .app sr (.app sr Core.boolImpliesOp rhs) lhs + | .lt _ => mkBinApp Core.intLtOp + | .le _ => mkBinApp Core.intLeOp + | .gt _ => mkBinApp Core.intGtOp + | .ge _ => mkBinApp Core.intGeOp + | .add _ => mkBinApp Core.intAddOp + | .sub _ => mkBinApp Core.intSubOp + | .mul _ => mkBinApp Core.intMulOp + | .div _ => mkBinApp Core.intDivOp + | .mod _ => mkBinApp Core.intModOp + +/-- Convert B3 unary operator to a Core expression. -/ +def convertUnaryOp (sr : SourceRange) (op : UnaryOp M) (arg : Core.Expression.Expr) : Core.Expression.Expr := + let opExpr := match op with + | .not _ => Core.boolNotOp + | .neg _ => Core.intNegOp + .app sr opExpr arg + + +/-- Convert B3 expression to Core expression. + Uses de Bruijn indices from B3 AST, maps to free variables in Core. -/ +partial def convertExpr (ctx : ConvContext) : B3AST.Expression SourceRange → ConvResult Core.Expression.Expr + | .literal sr (.intLit _ n) => .ok (.intConst sr (Int.ofNat n)) + | .literal sr (.boolLit _ b) => .ok (.boolConst sr b) + | .literal sr (.stringLit _ s) => .ok (.strConst sr s) + | .id sr idx => + if idx < ctx.boundDepth then + .ok (.bvar sr idx) + else + match ctx.vars[idx]? with + | some (name, ty) => .ok (.fvar sr (⟨name, ()⟩) (some ty)) + | none => .withError (.intConst sr 0) (.unsupportedFeature s!"unbound variable at index {idx}" "expression") + | .binaryOp sr op lhs rhs => + let lhsResult := convertExpr ctx lhs + let rhsResult := convertExpr ctx rhs + { value := convertBinaryOp sr op lhsResult.value rhsResult.value, + errors := lhsResult.errors ++ rhsResult.errors } + | .unaryOp sr op arg => + let argResult := convertExpr ctx arg + { value := convertUnaryOp sr op argResult.value, errors := argResult.errors } + | .ite sr cond thn els => + let condResult := convertExpr ctx cond + let thnResult := convertExpr ctx thn + let elsResult := convertExpr ctx els + { value := .ite sr condResult.value thnResult.value elsResult.value, + errors := condResult.errors ++ thnResult.errors ++ elsResult.errors } + | .functionCall sr fnName args => + let fnTy := ctx.lookupFuncType fnName.val + let base : Core.Expression.Expr := .fvar sr (⟨fnName.val, ()⟩) fnTy + let argResults := args.val.toList.map (convertExpr ctx) + { value := argResults.foldl (fun acc argRes => .app sr acc argRes.value) base, + errors := argResults.flatMap (·.errors) } + | .letExpr sr varName value body => + let valTy := LMonoTy.tcons "int" [] + let valueResult := convertExpr ctx value + let bodyResult := convertExpr (ctx.pushBound varName.val valTy) body + { value := .app sr (.abs sr "" (some valTy) bodyResult.value) valueResult.value, + errors := valueResult.errors ++ bodyResult.errors } + | .quantifierExpr sr qk vars _patterns body => + let qkind : Lambda.QuantifierKind := match qk with + | .forall _ => .all + | .exists _ => .exist + let varList := vars.val.toList.filterMap fun v => + match v with + | .quantVarDecl _ name ty => some (name.val, b3TypeToCoreTy ty.val) + let ctx' := varList.foldl (fun c (name, ty) => c.pushBound name ty) ctx + let bodyResult := convertExpr ctx' body + { value := varList.foldr (fun (name, ty) acc => + .quant sr qkind name (some ty) (.noTrigger sr) acc + ) bodyResult.value, + errors := bodyResult.errors } + | .labeledExpr _ _label expr => convertExpr ctx expr + + +/-- Convert a B3 statement to a list of Core statements. -/ +partial def convertStmt (ctx : ConvContext) : B3AST.Statement SourceRange → String → ConvResult (List Core.Statement) + | .check sr expr, procName => + let exprResult := convertExpr ctx expr + let md : Imperative.MetaData Core.Expression := + #[{ fld := .label "fileRange", value := .fileRange { file := .file "", range := sr } }, + { fld := .label "stmtKind", value := .msg "check" }] + { value := [Core.Statement.assert procName exprResult.value md], errors := exprResult.errors } + | .assert sr expr, procName => + let exprResult := convertExpr ctx expr + let md : Imperative.MetaData Core.Expression := + #[{ fld := .label "fileRange", value := .fileRange { file := .file "", range := sr } }, + { fld := .label "stmtKind", value := .msg "assert" }] + { value := [Core.Statement.assert procName exprResult.value md, + Core.Statement.assume "assert-assume" exprResult.value .empty], errors := exprResult.errors } + | .assume _ expr, _ => + let exprResult := convertExpr ctx expr + { value := [Core.Statement.assume "assume" exprResult.value .empty], errors := exprResult.errors } + | .reach sr expr, procName => + let exprResult := convertExpr ctx expr + let md : Imperative.MetaData Core.Expression := + #[{ fld := .label "fileRange", value := .fileRange { file := .file "", range := sr } }] + { value := [Core.Statement.cover procName exprResult.value md], errors := exprResult.errors } + | .blockStmt _ stmts, procName => + let results := stmts.val.toList.map (convertStmt ctx · procName) + { value := [Imperative.Stmt.block "block" (results.flatMap (·.value)) .empty], + errors := results.flatMap (·.errors) } + | .varDecl _ name ty _autoinv init, _ => + let coreTy := match ty.val with + | some tyAnn => b3TypeToCoreLTy tyAnn.val + | none => b3TypeToCoreLTy "int" + match init.val with + | some initExpr => + let initResult := convertExpr ctx initExpr + { value := [Core.Statement.init (⟨name.val, ()⟩) coreTy (some initResult.value) .empty], + errors := initResult.errors } + | none => + .ok [Core.Statement.init (⟨name.val, ()⟩) coreTy none .empty] + | .assign _ lhs rhs, _ => + let rhsResult := convertExpr ctx rhs + match ctx.vars[lhs.val]? with + | some (name, _) => + { value := [Core.Statement.set (⟨name, ()⟩) rhsResult.value .empty], + errors := rhsResult.errors } + | none => + .withError [] (.unsupportedFeature s!"unbound variable at index {lhs.val}" "assignment") + | .ifStmt _ cond thenBranch elseBranch, procName => + let condResult := convertExpr ctx cond + let thenResult := convertStmt ctx thenBranch procName + let elseResult := match elseBranch.val with + | some s => convertStmt ctx s procName + | none => .ok [] + { value := [Imperative.Stmt.ite condResult.value thenResult.value elseResult.value .empty], + errors := condResult.errors ++ thenResult.errors ++ elseResult.errors } + | .loop sr invariants body, procName => + let guard : Core.Expression.Expr := .boolConst sr true + let invResults := invariants.val.toList.map (convertExpr ctx) + let invExprs := invResults.map (·.value) + let bodyResult := convertStmt ctx body procName + { value := [Imperative.Stmt.loop guard none invExprs bodyResult.value .empty], + errors := invResults.flatMap (·.errors) ++ bodyResult.errors } + | .choose _ branches, procName => + let results := branches.val.toList.map (convertStmt ctx · procName) + { value := [Imperative.Stmt.block "choose" (results.flatMap (·.value)) .empty], + errors := results.flatMap (·.errors) } + | .labeledStmt _ _label stmt, procName => convertStmt ctx stmt procName + | _, _ => .withError [] (.unsupportedFeature "unknown statement type" "statement") + + +/-- Convert a B3 function declaration to a Core funcDecl statement. -/ +def convertFuncDecl (ctx : ConvContext) : B3AST.Decl SourceRange → ConvResult (List Core.Statement) + | .function _ name params retType tag body => + -- Check for unsupported features + let errors := [] + let errors := if tag.val.isSome then + errors ++ [.unsupportedFeature "function tags" s!"function {name.val}"] + else errors + let errors := if params.val.toList.any (fun p => match p with | .fParameter _ inj _ _ => inj.val) then + errors ++ [.unsupportedFeature "injective parameters" s!"function {name.val}"] + else errors + let errors := if body.val.any (fun fb => match fb with | .functionBody _ whens _ => !whens.val.isEmpty) then + errors ++ [.unsupportedFeature "'when' clauses" s!"function {name.val}"] + else errors + + let inputs : ListMap CoreIdent Lambda.LTy := params.val.toList.map fun p => + match p with + | .fParameter _ _ pname pty => (⟨pname.val, ()⟩, b3TypeToCoreLTy pty.val) + let outputTy := b3TypeToCoreLTy retType.val + let bodyResult := body.val.bind fun fb => + match fb with + | .functionBody _ _ bodyExpr => + let paramCtx := params.val.toList.foldl (fun c p => + match p with + | .fParameter _ _ pname pty => c.push pname.val (b3TypeToCoreTy pty.val) + ) ctx + some (convertExpr paramCtx bodyExpr) + let (coreBody, bodyErrors) := match bodyResult with + | some res => (some res.value, res.errors) + | none => (none, []) + let decl : Imperative.PureFunc Core.Expression := { + name := ⟨name.val, ()⟩ + inputs := inputs + output := outputTy + body := coreBody + } + { value := [Imperative.Stmt.funcDecl decl .empty], errors := errors ++ bodyErrors } + | _ => .ok [] + +/-- Build a ConvContext with all function declarations from a B3 program. -/ +private def buildFuncContext (decls : List (B3AST.Decl SourceRange)) : ConvContext := + decls.foldl (fun ctx decl => + match decl with + | .function _ name params retType _ _ => + let argTypes := params.val.toList.map fun p => + match p with + | .fParameter _ _ _ pty => b3TypeToCoreTy pty.val + ctx.addFunc name.val argTypes (b3TypeToCoreTy retType.val) + | _ => ctx + ) ConvContext.empty + +/-- Convert a B3 program to a list of Core statements, collecting errors. -/ +def convertProgram : B3AST.Program SourceRange → ConvResult (List Core.Statement) + | .program _ decls => + let ctx := buildFuncContext decls.val.toList + let results := decls.val.toList.map fun decl => + match decl with + | .function _ _ _ _ _ _ => convertFuncDecl ctx decl + | .axiom _ _vars expr => + let exprResult := convertExpr ctx expr + { value := [Core.Statement.assume "axiom" exprResult.value .empty], errors := exprResult.errors } + | .procedure _ name params specs body => + let paramErrors := if params.val.isEmpty then [] + else [ConversionError.unsupportedFeature "procedure parameters" s!"procedure {name.val}"] + let specErrors := if specs.val.isEmpty then [] + else [ConversionError.unsupportedFeature "procedure specifications" s!"procedure {name.val}"] + match body.val with + | some bodyStmt => + let result := convertStmt ctx bodyStmt name.val + { result with errors := paramErrors ++ specErrors ++ result.errors } + | none => { value := [], errors := paramErrors ++ specErrors } + | _ => .withError [] (.unsupportedFeature "unknown declaration type" "program") + { value := results.flatMap (·.value), errors := results.flatMap (·.errors) } + +end Strata.B3.ToCore diff --git a/Strata/Languages/B3/Verifier.lean b/Strata/Languages/B3/Verifier.lean index c2ac8b2ce..928415f83 100644 --- a/Strata/Languages/B3/Verifier.lean +++ b/Strata/Languages/B3/Verifier.lean @@ -4,125 +4,71 @@ SPDX-License-Identifier: Apache-2.0 OR MIT -/ -import Strata.Languages.B3.Verifier.Expression -import Strata.Languages.B3.Verifier.Formatter -import Strata.Languages.B3.Verifier.State -import Strata.Languages.B3.Verifier.Program -import Strata.Languages.B3.Verifier.Diagnosis +import Strata.Languages.B3.ToCore +import Strata.Languages.B3.Format +import Strata.Languages.B3.DDMTransform.ParseCST +import Strata.Languages.B3.DDMTransform.Conversion +import Strata.Languages.Core.CoreSMT +import Strata.DL.SMT.Solver open Strata -open Strata.B3.Verifier open Strata.SMT /-! # B3 Verifier -Converts B3 programs to SMT and verifies them using SMT solvers. - -## Architecture Overview - -``` -B3 Program (CST) - ↓ - Parse (DDM) - ↓ - B3 AST (de Bruijn indices) - ↓ -FunctionToAxiom Transform - ↓ - B3 AST (declarations + axioms) - ↓ -expressionToSMT (Conversion) - ↓ - SMT Terms - ↓ -formatTermDirect (Formatter) - ↓ - SMT-LIB strings - ↓ - SMT Solver (e.g., Z3/CVC5) - ↓ - Results (proved/counterexample/unknown) - ↓ -Diagnosis (if failed) -``` - -## API Choice - -Use `programToSMT` for automatic diagnosis (recommended) - provides detailed error analysis. -Use `programToSMTWithoutDiagnosis` for faster verification without diagnosis - returns raw results. - -## Usage +Converts B3 programs to Core and verifies them using the CoreSMT verifier. -/ --- Example: Verify a simple B3 program (meta to avoid including in production) --- This is not a test, it only demonstrates the end-to-end API -meta def exampleVerification : IO Unit := do - -- Parse B3 program using DDM syntax - let ddmProgram : Strata.Program := #strata program B3CST; - function f(x : int) : int { x + 1 } - procedure test() { - check 8 == 8 && f(5) == 7 - } - #end - - -- For parsing from files, use: parseStrataProgramFromDialect dialects "B3CST" "file.b3cst.st" - - let b3AST : B3AST.Program SourceRange ← match programToB3AST ddmProgram with - | .ok ast => pure ast - | .error msg => throw (IO.userError s!"Failed to parse: {msg}") - - -- Create solver and verify - let solver : Solver ← createInteractiveSolver "cvc5" - let reports : List ProcedureReport ← programToSMT b3AST solver - -- Don't call exit in tests - let solver terminate naturally - - -- Destructure results to show types (self-documenting) - let [report] ← pure reports | throw (IO.userError "Expected one procedure") - let _procedureName : String := report.procedureName - let results : List (VerificationReport × Option DiagnosisResult) := report.results - - let [(verificationReport, diagnosisOpt)] ← pure results | throw (IO.userError "Expected one result") - - let analyseVerificationReport (verificationReport: VerificationReport) : IO Unit := - do - let context : VerificationContext := verificationReport.context - let result : VerificationResult := verificationReport.result - let _model : Option String := verificationReport.model - - let _decl : B3AST.Decl SourceRange := context.decl - let _stmt : B3AST.Statement SourceRange := context.stmt - let pathCondition : List (B3AST.Expression SourceRange) := context.pathCondition - - -- Interpret verification result (merged error and success cases) - match result with - | .error .counterexample => IO.println "✗ Counterexample found (assertion may not hold)" - | .error .unknown => IO.println "✗ Unknown" - | .error .refuted => IO.println "✗ Refuted (proved false/unreachable)" - | .success .verified => IO.println "✓ Verified (proved)" - | .success .reachable => IO.println "✓ Reachable/Satisfiable" - | .success .reachabilityUnknown => IO.println "✓ Reachability unknown" - - -- Print path condition if present - if !pathCondition.isEmpty then - IO.println " Path condition:" - for expr in pathCondition do - IO.println s!" {B3.Verifier.formatExpression ddmProgram expr B3.ToCSTContext.empty}" - - IO.println s!"Statement: {B3.Verifier.formatStatement ddmProgram verificationReport.context.stmt B3.ToCSTContext.empty}" - analyseVerificationReport verificationReport - - let (.some diagnosis) ← pure diagnosisOpt | throw (IO.userError "Expected a diagnosis") - - -- Interpret diagnosis (if available) - let diagnosedFailures : List DiagnosedFailure := diagnosis.diagnosedFailures - IO.println s!" Found {diagnosedFailures.length} diagnosed failures" - - for failure in diagnosedFailures do - let expression : B3AST.Expression SourceRange := failure.expression - IO.println s!"Failing expression: {B3.Verifier.formatExpression ddmProgram expression B3.ToCSTContext.empty}" - analyseVerificationReport failure.report - - pure () +namespace Strata.B3.Verifier + +/-- Parse DDM program to B3 AST -/ +def programToB3AST (prog : Program) : Except String (B3AST.Program SourceRange) := do + let [op] ← pure prog.commands.toList + | .error "Expected single program command" + if op.name.name != "command_program" then + .error s!"Expected command_program, got {op.name.name}" + let [ArgF.op progOp] ← pure op.args.toList + | .error "Expected single program argument" + let cstProg ← B3CST.Program.ofAst progOp + let (ast, errors) := B3.programFromCST B3.FromCSTContext.empty cstProg + if !errors.isEmpty then + .error s!"CST to AST conversion errors: {errors}" + else + .ok ast + +/-- Create an interactive solver with appropriate flags for the given solver path. -/ +def createInteractiveSolver (solverPath : String := "cvc5") : IO Solver := + let args := if solverPath.endsWith "cvc5" || solverPath == "cvc5" + then #["--quiet", "--lang", "smt", "--incremental", "--produce-models"] + else #["-smt2", "-in"] -- Z3 flags + Solver.spawn solverPath args + +/-- Create a buffer-backed solver for capturing SMT output without running a solver -/ +def createBufferSolver : IO (Solver × IO.Ref IO.FS.Stream.Buffer) := do + let buffer ← IO.mkRef {} + let solver ← Solver.bufferWriter buffer + return (solver, buffer) + +/-- Convert B3 program to Core and verify via CoreSMT pipeline -/ +def programToSMT (prog : B3AST.Program SourceRange) (solver : Solver) : IO (List Core.ProcedureReport) := do + let convResult := B3.ToCore.convertProgram prog + if !convResult.errors.isEmpty then + let msg := convResult.errors.map toString |> String.intercalate "\n" + throw (IO.userError s!"Conversion errors:\n{msg}") + let coreStmts := convResult.value + -- Initialize solver and wrap in SolverInterface + let _ ← (Solver.setLogic "ALL").run solver + let solverInterface ← mkSolverInterfaceFromSolver solver + let config : Core.CoreSMT.CoreSMTConfig := { accumulateErrors := true } + let state := Core.CoreSMT.CoreSMTState.init solverInterface config + let (_, _, results) ← Core.CoreSMT.verify state Core.Env.init coreStmts + let reports := results.map Core.vcResultToVerificationReport + return [{ procedureName := "main", results := reports }] + +def programToSMTWithoutDiagnosis (prog : B3AST.Program SourceRange) (solver : Solver) : IO (List (Except String Core.VerificationReport)) := do + let reports ← programToSMT prog solver + return reports.flatMap (fun r => r.results.map (fun vr => .ok vr)) + +end Strata.B3.Verifier --- See StrataTest/Languages/B3/Verifier/VerifierTests.lean for test of this example. diff --git a/Strata/Languages/B3/Verifier/Diagnosis.lean b/Strata/Languages/B3/Verifier/Diagnosis.lean deleted file mode 100644 index 3e1c09238..000000000 --- a/Strata/Languages/B3/Verifier/Diagnosis.lean +++ /dev/null @@ -1,193 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.Verifier.State -import Strata.Languages.B3.Verifier.Expression -import Strata.Languages.B3.Verifier.Statements - -/-! -# Verification Diagnosis Strategies - -Interactive debugging strategies for failed verifications. - -When a verification fails, these strategies help identify the root cause by: -- Splitting conjunctions to find which conjunct fails -- Inlining definitions -- Simplifying expressions --/ - -namespace Strata.B3.Verifier - -open Strata.SMT - ---------------------------------------------------------------------- --- Pure Helper Functions ---------------------------------------------------------------------- - -/-- Extract conjunction operands if expression is a conjunction, otherwise return none -/ -def splitConjunction (expr : B3AST.Expression SourceRange) : Option (B3AST.Expression SourceRange × B3AST.Expression SourceRange) := - match expr with - | .binaryOp _ (.and _) lhs rhs => some (lhs, rhs) - | _ => none - -/-- Determine if diagnosis should stop early based on check type and failure status -/ -def shouldStopDiagnosis (isReachCheck : Bool) (isProvablyFalse : Bool) : Bool := - isProvablyFalse || isReachCheck - -/-- Upgrade verification result to refuted if provably false -/ -def upgradeToRefutedIfNeeded (result : VerificationReport) (isProvablyFalse : Bool) : VerificationReport := - if isProvablyFalse then - { result with result := .error .refuted } - else - result - -/-- Automatically diagnose a failed check to find root cause. - -For proof checks (check/assert): Recursively splits conjunctions to find all atomic failures. -When checking RHS, assumes LHS holds to provide context-aware diagnosis. - -For reachability checks (reach): Stops after finding first unreachable LHS conjunct, -since all subsequent conjuncts are trivially unreachable if LHS is unreachable. --/ -partial def diagnoseFailureGeneric - (isReachCheck : Bool) - (state : B3VerificationState) - (expr : B3AST.Expression SourceRange) - (sourceDecl : B3AST.Decl SourceRange) - (sourceStmt : B3AST.Statement SourceRange) : IO DiagnosisResult := do - let convResult := expressionToSMT ConversionContext.empty expr - - -- If there are conversion errors, return early - if !convResult.errors.isEmpty then - let vctx : VerificationContext := { decl := sourceDecl, stmt := sourceStmt, pathCondition := state.pathCondition } - let dummyResult : VerificationReport := { - context := vctx - result := .error .unknown - model := none - } - return { originalCheck := dummyResult, diagnosedFailures := [] } - - -- Determine check function based on check type - let checkFn := if isReachCheck then reach else prove - let isFailure := fun r => r.isError - - let vctx : VerificationContext := { decl := sourceDecl, stmt := sourceStmt, pathCondition := state.pathCondition } - let originalResult ← checkFn state convResult.term vctx - - if !isFailure originalResult.result then - return { originalCheck := originalResult, diagnosedFailures := [] } - - let mut diagnosements := [] - - -- Helper to diagnose a single conjunct - let diagnoseConjunct (expr : B3AST.Expression SourceRange) (convResult : ConversionResult SourceRange) - (checkState : B3VerificationState) (vctx : VerificationContext) : IO (List DiagnosedFailure) := do - let result ← checkFn checkState convResult.term vctx - if isFailure result.result then - -- Check if provably false (not just unprovable) - let _ ← push checkState - let runCheck : SolverM Decision := do - Solver.assert convResult.term - Solver.checkSat [] - let (decision, _) ← runCheck.run checkState.smtState.solver - let _ ← pop checkState - let isProvablyFalse := decision == .unsat - - -- Recursively diagnose - let diag ← diagnoseFailureGeneric isReachCheck checkState expr sourceDecl sourceStmt - if diag.diagnosedFailures.isEmpty then - -- Atomic failure - upgrade to refuted if provably false - let finalResult := upgradeToRefutedIfNeeded result isProvablyFalse - return [{ expression := expr, report := finalResult }] - else - -- Has sub-failures - return those - return diag.diagnosedFailures - else - return [] - - -- Strategy: Pattern match on conjunctions and recursively diagnose - match expr with - | .binaryOp _ (.and _) lhs rhs => - let lhsConv := expressionToSMT ConversionContext.empty lhs - if lhsConv.errors.isEmpty then - let lhsFailures ← diagnoseConjunct lhs lhsConv state vctx - diagnosements := diagnosements ++ lhsFailures - - -- Stop early if needed (provably false or reachability check) - if !lhsFailures.isEmpty then - let hasProvablyFalse := lhsFailures.any (fun f => - match f.report.result with | .error .refuted => true | _ => false) - if shouldStopDiagnosis isReachCheck hasProvablyFalse then - return { originalCheck := originalResult, diagnosedFailures := diagnosements } - - -- Check right conjunct assuming left conjunct holds - let rhsConv := expressionToSMT ConversionContext.empty rhs - if lhsConv.errors.isEmpty && rhsConv.errors.isEmpty then - -- Add lhs as assumption when checking rhs - let stateForRhs ← addPathCondition state lhs lhsConv.term - let vctxForRhs : VerificationContext := { decl := sourceDecl, stmt := sourceStmt, pathCondition := stateForRhs.pathCondition } - let rhsFailures ← diagnoseConjunct rhs rhsConv stateForRhs vctxForRhs - diagnosements := diagnosements ++ rhsFailures - | _ => pure () - - return { originalCheck := originalResult, diagnosedFailures := diagnosements } - -/-- Diagnose a failed check/assert -/ -def diagnoseFailure (state : B3VerificationState) (expr : B3AST.Expression SourceRange) (sourceDecl : B3AST.Decl SourceRange) (sourceStmt : B3AST.Statement SourceRange) : IO DiagnosisResult := - diagnoseFailureGeneric false state expr sourceDecl sourceStmt - -/-- Diagnose an unreachable reach -/ -def diagnoseUnreachable (state : B3VerificationState) (expr : B3AST.Expression SourceRange) (sourceDecl : B3AST.Decl SourceRange) (sourceStmt : B3AST.Statement SourceRange) : IO DiagnosisResult := - diagnoseFailureGeneric true state expr sourceDecl sourceStmt - -/-- Determine which diagnosis function to use based on statement type -/ -def diagnoseFailed (state : B3VerificationState) (sourceDecl : B3AST.Decl SourceRange) (stmt : B3AST.Statement SourceRange) : IO (Option DiagnosisResult) := - match stmt with - | .check m expr => do - let d ← diagnoseFailure state expr sourceDecl (.check m expr) - pure (some d) - | .assert m expr => do - let d ← diagnoseFailure state expr sourceDecl (.assert m expr) - pure (some d) - | .reach m expr => do - let d ← diagnoseUnreachable state expr sourceDecl (.reach m expr) - pure (some d) - | _ => pure none - ---------------------------------------------------------------------- --- Statement Symbolic Execution with Diagnosis ---------------------------------------------------------------------- - -/-- Translate statements to SMT with automatic diagnosis on failures (default, recommended). - -This adds diagnosis for failed checks/asserts/reach to help identify root causes. -The diagnosis analyzes failures but does not modify the verification state. - -For faster verification without diagnosis, use statementToSMTWithoutDiagnosis. --/ -def statementToSMT (ctx : ConversionContext) (state : B3VerificationState) (sourceDecl : B3AST.Decl SourceRange) : B3AST.Statement SourceRange → IO SymbolicExecutionResult - | stmt => do - -- Translate the statement to SMT and get results - let execResult ← statementToSMTWithoutDiagnosis ctx state sourceDecl stmt - - -- Add diagnosis to any failed verification results - let mut resultsWithDiagRev := [] - for (stmtResult, _) in execResult.results do - match stmtResult with - | .verified report => - -- If verification failed, diagnose it - let diag ← if report.result.isError then - diagnoseFailed state sourceDecl report.context.stmt - else - pure none - resultsWithDiagRev := (stmtResult, diag) :: resultsWithDiagRev - | .conversionError _ => - -- Conversion errors don't have diagnosis - resultsWithDiagRev := (stmtResult, none) :: resultsWithDiagRev - - pure { results := resultsWithDiagRev.reverse, finalState := execResult.finalState } - -end Strata.B3.Verifier diff --git a/Strata/Languages/B3/Verifier/Expression.lean b/Strata/Languages/B3/Verifier/Expression.lean deleted file mode 100644 index 5fd544ee3..000000000 --- a/Strata/Languages/B3/Verifier/Expression.lean +++ /dev/null @@ -1,328 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.DDMTransform.DefinitionAST -import Strata.DL.SMT.SMT -import Strata.DL.SMT.Factory -import Strata.Languages.B3.DDMTransform.Conversion -import Strata.Util.Tactics - -/-! -# B3 AST to SMT Term Conversion - -Converts B3 abstract syntax trees to SMT terms for verification. --/ - -namespace Strata.B3.Verifier - -open Strata -open Strata.B3AST -open Strata.SMT -open Strata.SMT.Factory - ---------------------------------------------------------------------- --- Type Conversion ---------------------------------------------------------------------- - -/-- Convert B3 type name to SMT `TermType`. -/ -def b3TypeToSMTType (typeName : String) : Strata.SMT.TermType := - match typeName with - | "int" => .int - | "bool" => .bool - | "real" => .real - | "string" => .string - | other => .constr other [] - ---------------------------------------------------------------------- --- Conversion Context ---------------------------------------------------------------------- - -/-- Errors that can occur during B3 to SMT conversion -/ -inductive ConversionError (M : Type) where - | unsupportedConstruct : String → M → ConversionError M - | unboundVariable : Nat → M → ConversionError M - | typeMismatch : String → M → ConversionError M - | invalidFunctionCall : String → M → ConversionError M - | invalidPattern : String → M → ConversionError M - deriving Inhabited - -namespace ConversionError - -def toString [Repr M] : ConversionError M → String - | unsupportedConstruct msg m => s!"Unsupported construct at {repr m}: {msg}" - | unboundVariable idx m => s!"Unbound variable at index {idx} at {repr m}" - | typeMismatch msg m => s!"Type mismatch at {repr m}: {msg}" - | invalidFunctionCall msg m => s!"Invalid function call at {repr m}: {msg}" - | invalidPattern msg m => s!"Invalid pattern at {repr m}: {msg}" - -instance [Repr M] : ToString (ConversionError M) where - toString := ConversionError.toString - -end ConversionError - ---------------------------------------------------------------------- --- Conversion Result with Error Accumulation ---------------------------------------------------------------------- - -/-- Conversion result that can carry both a term and errors -/ -structure ConversionResult (M : Type) where - term : Term - errors : List (ConversionError M) - -namespace ConversionResult - -/-- Create a successful conversion result -/ -def ok {M : Type} (term : Term) : ConversionResult M := - { term := term, errors := [] } - -/-- Create a conversion result with an error and placeholder term -/ -def withError {M : Type} (err : ConversionError M) : ConversionResult M := - { term := Term.bool false, errors := [err] } - -end ConversionResult - -structure ConversionContext where - vars : List String -- Maps de Bruijn index to variable name - enableDiagnosis : Bool := true -- Whether to perform automatic diagnosis on failures - -namespace ConversionContext - -def empty : ConversionContext := { vars := [], enableDiagnosis := true } - -def withoutDiagnosis (ctx : ConversionContext) : ConversionContext := - { ctx with enableDiagnosis := false } - -def push (ctx : ConversionContext) (name : String) : ConversionContext := - { ctx with vars := name :: ctx.vars } - -def lookup (ctx : ConversionContext) (idx : Nat) : Option String := - ctx.vars[idx]? - -end ConversionContext - ---------------------------------------------------------------------- --- Operator Conversion ---------------------------------------------------------------------- - -/-- Placeholder name for UF argument types in SMT encoding. -SMT solvers don't require actual parameter names for uninterpreted functions, -only the types matter for type checking. -/ -def UF_ARG_PLACEHOLDER := "_" - -/-- Convert B3 binary operators to SMT terms without constant folding -/ -def binaryOpToSMT : B3AST.BinaryOp M → (Term → Term → Term) - | .iff _ => fun t1 t2 => Term.app .eq [t1, t2] .bool - | .implies _ => fun t1 t2 => Term.app .implies [t1, t2] .bool - | .impliedBy _ => fun t1 t2 => Term.app .implies [t2, t1] .bool - | .and _ => fun t1 t2 => Term.app .and [t1, t2] .bool - | .or _ => fun t1 t2 => Term.app .or [t1, t2] .bool - | .eq _ => fun t1 t2 => Term.app .eq [t1, t2] .bool - | .neq _ => fun t1 t2 => Term.app .not [Term.app .eq [t1, t2] .bool] .bool - | .lt _ => fun t1 t2 => Term.app .lt [t1, t2] .bool - | .le _ => fun t1 t2 => Term.app .le [t1, t2] .bool - | .ge _ => fun t1 t2 => Term.app .ge [t1, t2] .bool - | .gt _ => fun t1 t2 => Term.app .gt [t1, t2] .bool - | .add _ => fun t1 t2 => Term.app .add [t1, t2] .int - | .sub _ => fun t1 t2 => Term.app .sub [t1, t2] .int - | .mul _ => fun t1 t2 => Term.app .mul [t1, t2] .int - | .div _ => fun t1 t2 => Term.app .div [t1, t2] .int - | .mod _ => fun t1 t2 => Term.app .mod [t1, t2] .int - -/-- Convert B3 unary operators to SMT terms -/ -def unaryOpToSMT : B3AST.UnaryOp M → (Term → Term) - | .not _ => fun t => Term.app .not [t] .bool - | .neg _ => fun t => Term.app .neg [t] .int - -/-- Convert B3 literals to SMT terms -/ -def literalToSMT : B3AST.Literal M → Term - | .intLit _ n => Term.int n - | .boolLit _ b => Term.bool b - | .stringLit _ s => Term.string s - ---------------------------------------------------------------------- --- Pattern Validation ---------------------------------------------------------------------- - -/-- Collect bound variable indices from a pattern expression. -Returns error if the expression is not structurally valid as a pattern. -Valid patterns consist only of function applications, bound variables, and literals. -/ -def collectPatternBoundVars (expr : B3AST.Expression M) (exprM : M) : Except (ConversionError M) (List Nat) := - match expr with - | .id _ idx => .ok [idx] - | .literal _ _ => .ok [] - | .functionCall _ _ args => do - let results ← args.val.toList.mapM (fun arg => collectPatternBoundVars arg exprM) - return results.flatten - | _ => .error (ConversionError.invalidPattern "patterns must consist only of function applications, variables, and literals" exprM) - termination_by SizeOf.sizeOf expr - decreasing_by (cases args; simp_all; term_by_mem) - -/-- Validate pattern expressions for a quantifier -/ -def validatePatternExprs (patterns : Array (B3AST.Expression M)) (patternM : M) : Except (ConversionError M) Unit := - if patterns.isEmpty then - .ok () -- Empty patterns are OK (solver will auto-generate) - else do - -- Check that each pattern expression is a function application (not just a variable or literal) - for p in patterns do - match p with - | .functionCall _ _ _ => pure () -- Valid - | _ => throw (ConversionError.invalidPattern "each pattern expression must be a function application" patternM) - - -- Collect all bound variables from all patterns - let allBoundVars ← patterns.toList.mapM (fun p => collectPatternBoundVars p patternM) - let flatVars := allBoundVars.flatten - -- Check if the bound variable (id 0) appears in at least one pattern - if !flatVars.contains 0 then - .error (ConversionError.invalidPattern "bound variable must appear in at least one pattern" patternM) - else - .ok () - ---------------------------------------------------------------------- --- Metadata Extraction ---------------------------------------------------------------------- - -/-- Extract metadata from any B3 expression -/ -def getExpressionMetadata : B3AST.Expression M → M - | .binaryOp m _ _ _ => m - | .literal m _ => m - | .id m _ => m - | .ite m _ _ _ => m - | .unaryOp m _ _ => m - | .functionCall m _ _ => m - | .labeledExpr m _ _ => m - | .letExpr m _ _ _ => m - | .quantifierExpr m _ _ _ _ => m - ---------------------------------------------------------------------- --- Expression Conversion ---------------------------------------------------------------------- - -/-- Convert B3 expressions to SMT terms with error accumulation -/ -def expressionToSMT (ctx : ConversionContext) (e : B3AST.Expression M) : ConversionResult M := - match e with - | .literal _m lit => - ConversionResult.ok (literalToSMT lit) - - | .id m idx => - match ctx.lookup idx with - | some name => ConversionResult.ok (Term.var ⟨name, .int⟩) - | none => ConversionResult.withError (ConversionError.unboundVariable idx m) - - | .ite _m cond thn els => - let condResult := expressionToSMT ctx cond - let thnResult := expressionToSMT ctx thn - let elsResult := expressionToSMT ctx els - let errors := condResult.errors ++ thnResult.errors ++ elsResult.errors - let term := Term.app .ite [condResult.term, thnResult.term, elsResult.term] thnResult.term.typeOf - { term := term, errors := errors } - - | .binaryOp _m op lhs rhs => - let lhsResult := expressionToSMT ctx lhs - let rhsResult := expressionToSMT ctx rhs - let errors := lhsResult.errors ++ rhsResult.errors - let term := (binaryOpToSMT op) lhsResult.term rhsResult.term - { term := term, errors := errors } - - | .unaryOp _m op arg => - let argResult := expressionToSMT ctx arg - let term := (unaryOpToSMT op) argResult.term - { term := term, errors := argResult.errors } - - | .functionCall m fnName args => - let argResults := args.val.map (fun arg => match _: arg with | a => expressionToSMT ctx a) - let errors := argResults.toList.foldl (fun acc r => acc ++ r.errors) [] - let argTerms := argResults.toList.map (·.term) - let uf : UF := { - id := fnName.val, - args := argTerms.map (fun t => ⟨UF_ARG_PLACEHOLDER, t.typeOf⟩), - out := .int - } - let term := Term.app (.uf uf) argTerms .int - { term := term, errors := errors } - - | .labeledExpr _m _ expr => - expressionToSMT ctx expr - - | .letExpr _m _var value body => - let ctx' := ctx.push _var.val - let valueResult := expressionToSMT ctx value - let bodyResult := expressionToSMT ctx' body - let errors := valueResult.errors ++ bodyResult.errors - { term := bodyResult.term, errors := errors } - - | .quantifierExpr m qkind vars patterns body => - -- Handle multiple quantified variables - let varList := vars.val.toList.filterMap (fun v => - match _: v with - | .quantVarDecl _ name ty => some (name.val, ty.val) - ) - - -- Extend context with all variables - let ctx' := varList.foldl (fun c (name, _) => c.push name) ctx - - -- Convert body - let bodyResult := expressionToSMT ctx' body - - -- Convert pattern expressions and collect errors - let patternResults : Array (List Term × List (ConversionError M)) := patterns.val.map (fun p => - match _: p with - | .pattern _ exprs => - let results : Array (ConversionResult M) := exprs.val.map (fun e => match _: e with | expr => expressionToSMT ctx' expr) - (results.toList.map (·.term), results.toList.foldl (fun acc r => acc ++ r.errors) []) - ) - let patternTermLists : List (List Term) := patternResults.toList.map (·.1) - let patternErrors : List (ConversionError M) := patternResults.toList.foldl (fun acc r => acc ++ r.2) [] - - -- Validate pattern structure - let patternExprArray := patterns.val.flatMap (fun p => - match _: p with - | .pattern _ exprs => exprs.val - ) - let validationErrors := match validatePatternExprs patternExprArray m with - | .ok () => [] - | .error err => [err] - - -- Build trigger from pattern terms - let allPatternTerms := patternTermLists.foldl (· ++ ·) [] - let trigger := if patterns.val.isEmpty then - -- No patterns specified in source - don't generate a trigger - Term.app .triggers [] .trigger - else if allPatternTerms.isEmpty then - -- Patterns specified but empty (shouldn't happen) - generate simple trigger for first var - match varList.head? with - | some (name, _) => Factory.mkSimpleTrigger name .int - | none => Term.app .triggers [] .trigger - else - -- Patterns specified - use them - allPatternTerms.foldl (fun acc term => Factory.addTrigger term acc) (Term.app .triggers [] .trigger) - - -- Build quantifier term with all variables - let qk := match _: qkind with - | .forall _ => QuantifierKind.all - | .exists _ => QuantifierKind.exist - - let term := varList.foldr (fun (name, _ty) body => - Factory.quant qk name .int trigger body - ) bodyResult.term - - -- Accumulate all errors - let allErrors := bodyResult.errors ++ validationErrors ++ patternErrors - { term := term, errors := allErrors } - - termination_by SizeOf.sizeOf e - decreasing_by - all_goals (try term_by_mem) - . cases args; term_by_mem - . cases exprs; cases patterns; term_by_mem - -def formatExpression (prog : Program) (expr : B3AST.Expression SourceRange) (ctx: B3.ToCSTContext): String := - let (cstExpr, _) := B3.expressionToCST ctx expr - let ctx := FormatContext.ofDialects prog.dialects prog.globalContext {} - let fmtState : FormatState := { openDialects := prog.dialects.toList.foldl (init := {}) fun a (dialect : Dialect) => a.insert dialect.name } - let formatted := mformat (ArgF.op cstExpr.toAst) ctx fmtState |>.format.pretty.trimAscii.toString - formatted - -end Strata.B3.Verifier diff --git a/Strata/Languages/B3/Verifier/Formatter.lean b/Strata/Languages/B3/Verifier/Formatter.lean deleted file mode 100644 index 880bcbee4..000000000 --- a/Strata/Languages/B3/Verifier/Formatter.lean +++ /dev/null @@ -1,28 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.DL.SMT.DDMTransform.Translate - -/-! -# SMT Term Formatting - -Formats SMT terms to SMT-LIB syntax using the SMT dialect's pretty-printer. - -This module uses `SMTDDM.toString` which translates SMT terms to the SMT dialect's -AST and then uses the dialect's formatter to generate SMT-LIB strings. --/ - -namespace Strata.B3.Verifier - -open Strata.SMT - -/-- Format SMT term to SMT-LIB syntax using the SMT dialect's pretty-printer -/ -def formatTermDirect (t : Term) : String := - match SMTDDM.termToString t with - | .ok s => s - | .error msg => s!"(error: {msg})" - -end Strata.B3.Verifier diff --git a/Strata/Languages/B3/Verifier/Program.lean b/Strata/Languages/B3/Verifier/Program.lean deleted file mode 100644 index 037f21584..000000000 --- a/Strata/Languages/B3/Verifier/Program.lean +++ /dev/null @@ -1,202 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.Verifier.State -import Strata.Languages.B3.Verifier.Expression -import Strata.Languages.B3.Verifier.Formatter -import Strata.Languages.B3.Verifier.Statements -import Strata.Languages.B3.Verifier.Diagnosis -import Strata.Languages.B3.Transform.FunctionToAxiom -import Strata.Languages.B3.DDMTransform.Conversion - -/-! -# B3 Program Verification - -Program-level verification API for B3 programs. -Verifies entire programs with automatic diagnosis. --/ - -namespace Strata.B3.Verifier - -open Strata -open Strata.SMT -open Strata.B3AST - ---------------------------------------------------------------------- --- Batch Verification API ---------------------------------------------------------------------- - -/-- Extract function declarations from a B3 program -/ -def extractFunctionDeclarations (prog : B3AST.Program SourceRange) : List (String × List TermType × TermType) := - match prog with - | .program _ decls => - decls.val.toList.filterMap (fun decl => - match decl with - | .function _ name params resultType _ body => - if body.val.isNone then - let argTypes := params.val.toList.map (fun p => - match p with - | .fParameter _ _ _ ty => b3TypeToSMTType ty.val - ) - let retType := b3TypeToSMTType resultType.val - some (name.val, argTypes, retType) - else - none - | _ => none - ) - -/-- Extract axiom expressions from a B3 program -/ -def extractAxioms (prog : B3AST.Program SourceRange) : List (B3AST.Expression SourceRange) := - match prog with - | .program _ decls => - decls.val.toList.filterMap (fun decl => - match decl with - | .axiom _ _ expr => some expr - | _ => none - ) - -/-- Add declarations and axioms from a transformed B3 program to the verification state -/ -private def addDeclarationsAndAxioms (state : B3VerificationState) (prog : B3AST.Program SourceRange) : IO (B3VerificationState × List String) := do - let mut state := state - let mut errors := [] - - -- Add function declarations - for (name, argTypes, retType) in extractFunctionDeclarations prog do - state ← addFunctionDecl state name argTypes retType - - -- Add axioms - for expr in extractAxioms prog do - let convResult := expressionToSMT ConversionContext.empty expr - state ← addPathCondition state expr convResult.term - errors := errors ++ convResult.errors.map toString - - return (state, errors) - -/-- Extract parameter-free procedures with bodies from a B3 program -/ -def extractVerifiableProcedures (prog : B3AST.Program SourceRange) : List (String × B3AST.Decl SourceRange × B3AST.Statement SourceRange) := - match prog with - | .program _ decls => - decls.val.toList.filterMap (fun decl => - match decl with - | .procedure _ name params _ body => - if params.val.isEmpty && body.val.isSome then - some (name.val, decl, body.val.get!) - else - none - | _ => none - ) - -/-- Translate a B3 program to SMT without automatic diagnosis (faster, less detailed errors) -/ -def programToSMTWithoutDiagnosis (prog : B3AST.Program SourceRange) (solver : Solver) : IO (List (Except String VerificationReport)) := do - let initialState ← initVerificationState solver - let mut results := [] - - -- Transform: split functions into declarations + axioms - let transformedProg := Transform.functionToAxiom prog - - -- Add function declarations and axioms - let (state, conversionErrors) ← addDeclarationsAndAxioms initialState transformedProg - - -- Report conversion errors - results := results ++ conversionErrors.map .error - - -- Verify parameter-free procedures - for (_name, decl, bodyStmt) in extractVerifiableProcedures prog do - let execResult ← statementToSMTWithoutDiagnosis ConversionContext.empty state decl bodyStmt - -- Extract just the StatementResults (no diagnosis) - let stmtResults := execResult.results.map (·.1) - results := results ++ stmtResults.map StatementResult.toExcept - - closeVerificationState state - return results - ---------------------------------------------------------------------- --- Convenience Wrappers ---------------------------------------------------------------------- - -/-- Convert DDM Program to B3 AST with error handling -/ -def programToB3AST (prog : Program) : Except String (B3AST.Program SourceRange) := do - let [op] ← pure prog.commands.toList - | .error "Expected single program command" - - if op.name.name != "command_program" then - .error s!"Expected command_program, got {op.name.name}" - - let [ArgF.op progOp] ← pure op.args.toList - | .error "Expected single program argument" - - let cstProg ← B3CST.Program.ofAst progOp - - let (ast, errors) := B3.programFromCST B3.FromCSTContext.empty cstProg - if !errors.isEmpty then - .error s!"CST to AST conversion errors: {errors}" - else - .ok ast - -/-- Build verification state from B3 program (functions and axioms only, no procedures) -/ -def buildProgramState (prog : Strata.B3AST.Program SourceRange) (solver : Solver) : IO B3VerificationState := do - let state ← initVerificationState solver - let transformedProg := Transform.functionToAxiom prog - let (newState, errors) ← addDeclarationsAndAxioms state transformedProg - -- Log errors if any - for err in errors do - IO.eprintln s!"Warning: {err}" - return newState - -/-- Generate SMT commands for a B3 program -/ -def programToSMTCommands (prog : Strata.B3AST.Program SourceRange) : IO String := do - let (solver, buffer) ← createBufferSolver - let _ ← (Solver.setLogic "ALL").run solver - let _ ← programToSMTWithoutDiagnosis prog solver - let contents ← buffer.get - if h: contents.data.IsValidUTF8 - then return String.fromUTF8 contents.data h - else return "Error: Invalid UTF-8 in SMT output" - ---------------------------------------------------------------------- --- Batch Verification with Automatic Diagnosis ---------------------------------------------------------------------- - -structure ProcedureReport where - procedureName : String - results : List (VerificationReport × Option DiagnosisResult) - -/-- Translate a B3 program to SMT and verify with automatic diagnosis. - -Main entry point for verification. - -Workflow: -1. Build program state (functions, axioms) -2. For each parameter-free procedure: - - Translate statements to SMT - - Check each VC - - If failed, automatically diagnose to find root cause -3. Report all results with diagnosis - -The solver is reset at the beginning to ensure clean state. --/ -def programToSMT (prog : Strata.B3AST.Program SourceRange) (solver : Solver) : IO (List ProcedureReport) := do - -- Reset solver to clean state - let _ ← (Solver.reset).run solver - let state ← buildProgramState prog solver - let mut reportsRev := [] - - -- Verify parameter-free procedures - for (name, decl, bodyStmt) in extractVerifiableProcedures prog do - let execResult ← statementToSMT ConversionContext.empty state decl bodyStmt - -- Extract VerificationReports with diagnosis - let resultsWithDiag := execResult.results.filterMap (fun (stmtResult, diag) => - match stmtResult with - | .verified report => some (report, diag) - | .conversionError _ => none - ) - reportsRev := { - procedureName := name - results := resultsWithDiag - } :: reportsRev - - closeVerificationState state - return reportsRev.reverse diff --git a/Strata/Languages/B3/Verifier/State.lean b/Strata/Languages/B3/Verifier/State.lean deleted file mode 100644 index 9d921e52e..000000000 --- a/Strata/Languages/B3/Verifier/State.lean +++ /dev/null @@ -1,201 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.Verifier.Expression -import Strata.Languages.B3.DDMTransform.DefinitionAST -import Strata.DL.SMT.Solver -import Strata.DL.SMT.Factory - -/-! -# B3 Verification State - -Manages incremental verification state for interactive debugging. --/ - -namespace Strata.B3.Verifier - -open Strata -open Strata.SMT -open Strata.B3AST -open Strata.B3.Verifier (UF_ARG_PLACEHOLDER) - ---------------------------------------------------------------------- --- B3 Verification Results ---------------------------------------------------------------------- - -/-- Verification outcome when check fails -/ -inductive VerificationError where - | counterexample : VerificationError -- Possibly wrong (sat) - | unknown : VerificationError -- Couldn't determine - | refuted : VerificationError -- Proved false/unreachable (unsat) - -/-- Verification outcome when check succeeds -/ -inductive VerificationSuccess where - | verified : VerificationSuccess -- Proved - | reachable : VerificationSuccess -- Reachability confirmed - | reachabilityUnknown : VerificationSuccess -- Couldn't determine, but not an error - -/-- Unified verification result -/ -inductive VerificationResult where - | error : VerificationError → VerificationResult - | success : VerificationSuccess → VerificationResult - -def VerificationResult.isError : VerificationResult → Bool - | .error _ => true - | .success _ => false - -def VerificationResult.fromDecisionForProve (d : Decision) : VerificationResult := - match d with - | .unsat => .success .verified - | .sat => .error .counterexample - | .unknown => .error .unknown - -def VerificationResult.fromDecisionForReach (d : Decision) : VerificationResult := - match d with - | .unsat => .error .refuted - | .sat => .success .reachable - | .unknown => .success .reachabilityUnknown - ---------------------------------------------------------------------- --- Verification Context and Results ---------------------------------------------------------------------- - -/-- Context for a verification check (where in the program and what we know) -/ -structure VerificationContext where - decl : B3AST.Decl SourceRange - stmt : B3AST.Statement SourceRange - pathCondition : List (B3AST.Expression SourceRange) -- Accumulated assertions - -/-- VerificationReport combines VerificationResult with source context. -Top-level result type returned to users, containing: -- The verification result (proved/counterexample/reachable/etc.) -- Source context (declaration, statement, and path condition) -- Optional model/counterexample information (TODO: use structured Model type instead of String) --/ -structure VerificationReport where - context : VerificationContext - result : VerificationResult - model : Option String := none -- TODO: Replace with structured Model type (Map String Term) - ---------------------------------------------------------------------- --- SMT Solver State ---------------------------------------------------------------------- - -/-- SMT solver state (reusable for any language) -/ -structure SMTSolverState where - solver : Solver - declaredFunctions : List (String × List TermType × TermType) - assertions : List Term - -/-- B3-specific verification state -/ -structure B3VerificationState where - smtState : SMTSolverState - context : ConversionContext - pathCondition : List (B3AST.Expression SourceRange) -- Accumulated assertions for debugging - -def initVerificationState (solver : Solver) : IO B3VerificationState := do - let _ ← (Solver.setLogic "ALL").run solver - let _ ← (Solver.setOption "produce-models" "true").run solver - return { - smtState := { - solver := solver - declaredFunctions := [] - assertions := [] - } - context := ConversionContext.empty - pathCondition := [] - } - -def addFunctionDecl (state : B3VerificationState) (name : String) (argTypes : List TermType) (returnType : TermType) : IO B3VerificationState := do - let _ ← (Solver.declareFun name argTypes returnType).run state.smtState.solver - return { state with smtState := { state.smtState with declaredFunctions := (name, argTypes, returnType) :: state.smtState.declaredFunctions } } - -def addPathCondition (state : B3VerificationState) (expr : B3AST.Expression SourceRange) (term : Term) : IO B3VerificationState := do - let _ ← (Solver.assert term).run state.smtState.solver - return { - state with - smtState := { state.smtState with assertions := term :: state.smtState.assertions } - pathCondition := expr :: state.pathCondition - } - -def push (state : B3VerificationState) : IO B3VerificationState := do - let solver := state.smtState.solver - solver.smtLibInput.putStr "(push 1)\n" - solver.smtLibInput.flush - return state - -def pop (state : B3VerificationState) : IO B3VerificationState := do - let solver := state.smtState.solver - solver.smtLibInput.putStr "(pop 1)\n" - solver.smtLibInput.flush - return state - -/-- Prove a property holds (check/assert statement) -/ -def prove (state : B3VerificationState) (term : Term) (ctx : VerificationContext) : IO VerificationReport := do - let _ ← push state - let runCheck : SolverM (Decision × Option String) := do - Solver.assert (Factory.not term) - let decision ← Solver.checkSat [] - let model := if decision == .sat then some "model available" else none - return (decision, model) - let ((decision, model), _) ← runCheck.run state.smtState.solver - let _ ← pop state - return { - context := ctx - result := VerificationResult.fromDecisionForProve decision - model := model - } - -/-- Check if a property is reachable (reach statement) -/ -def reach (state : B3VerificationState) (term : Term) (ctx : VerificationContext) : IO VerificationReport := do - let _ ← push state - let runCheck : SolverM (Decision × Option String) := do - Solver.assert term - let decision ← Solver.checkSat [] - let model := if decision == .sat then some "reachable" else none - return (decision, model) - let ((decision, model), _) ← runCheck.run state.smtState.solver - let _ ← pop state - return { - context := ctx - result := VerificationResult.fromDecisionForReach decision - model := model - } - -def closeVerificationState (state : B3VerificationState) : IO Unit := do - let _ ← (Solver.exit).run state.smtState.solver - pure () - ---------------------------------------------------------------------- --- Solver Creation Helpers ---------------------------------------------------------------------- - -/-- Create an interactive solver (Z3/CVC5) -/ -def createInteractiveSolver (solverPath : String := "cvc5") : IO Solver := - let args := if solverPath.endsWith "cvc5" || solverPath == "cvc5" - then #["--lang", "smt2", "--incremental"] - else #["-smt2", "-in"] -- Z3 flags - Solver.spawn solverPath args - -/-- Create a buffer solver for SMT command generation -/ -def createBufferSolver : IO (Solver × IO.Ref IO.FS.Stream.Buffer) := do - let buffer ← IO.mkRef {} - let solver ← Solver.bufferWriter buffer - return (solver, buffer) - ---------------------------------------------------------------------- --- Verification Results ---------------------------------------------------------------------- - -structure DiagnosedFailure where - expression : B3AST.Expression SourceRange - report : VerificationReport -- Contains context (with pathCondition), result (refuted if provably false), model - -structure DiagnosisResult where - originalCheck : VerificationReport - diagnosedFailures : List DiagnosedFailure - -end Strata.B3.Verifier diff --git a/Strata/Languages/B3/Verifier/Statements.lean b/Strata/Languages/B3/Verifier/Statements.lean deleted file mode 100644 index 4518ae0a4..000000000 --- a/Strata/Languages/B3/Verifier/Statements.lean +++ /dev/null @@ -1,117 +0,0 @@ -/- - Copyright Strata Contributors - - SPDX-License-Identifier: Apache-2.0 OR MIT --/ - -import Strata.Languages.B3.Verifier.Expression -import Strata.Languages.B3.Verifier.State -import Strata.Languages.B3.DDMTransform.ParseCST -import Strata.Languages.B3.DDMTransform.Conversion -import Strata.DDM.Integration.Lean -import Strata.DDM.Util.Format -import Strata.Util.Tactics - -/-! -# B3 Statement Streaming Translation - -Translates B3 statements to SMT via streaming symbolic execution (NOT batch VCG). - -## Streaming Symbolic Execution - -Statements are translated and symbolically executed immediately: -- `assert e` - prove e, then add to solver state (assumes e regardless of proof result) -- `check e` - prove e (push/pop, doesn't affect state) -- `assume e` - add to solver state -- `reach e` - check satisfiability (push/pop) - -This allows the solver to learn from asserts, making later checks easier. -Key advantage: O(n) not O(n²), solver accumulates lemmas. --/ - -namespace Strata.B3.Verifier - -open Strata -open Strata.SMT - -inductive StatementResult where - | verified : VerificationReport → StatementResult - | conversionError : String → StatementResult - -/-- Convert StatementResult to Except for easier error handling -/ -def StatementResult.toExcept : StatementResult → Except String VerificationReport - | .verified report => .ok report - | .conversionError msg => .error msg - -structure SymbolicExecutionResult where - results : List (StatementResult × Option DiagnosisResult) - finalState : B3VerificationState - -/-- Convert conversion errors to StatementResults -/ -def conversionErrorsToResults {M : Type} [Repr M] (errors : List (ConversionError M)) : List StatementResult := - errors.map (fun err => StatementResult.conversionError (toString err)) - -/-- Create VerificationContext from state and statement -/ -def mkVerificationContext (state : B3VerificationState) (decl : B3AST.Decl SourceRange) (stmt : B3AST.Statement SourceRange) : VerificationContext := - { decl := decl, stmt := stmt, pathCondition := state.pathCondition } - -/-- Create a SymbolicExecutionResult with conversion errors and optional verification result -/ -def mkExecutionResult {M : Type} [Repr M] (convErrors : List (ConversionError M)) (verificationResult : Option VerificationReport) (state : B3VerificationState) : SymbolicExecutionResult := - let errorResults := conversionErrorsToResults convErrors - let allResults := match verificationResult with - | some report => errorResults.map (·, none) ++ [(StatementResult.verified report, none)] - | none => errorResults.map (·, none) - { results := allResults, finalState := state } - -/-- Translate B3 statements to SMT via streaming symbolic execution (without diagnosis) -/ -def statementToSMTWithoutDiagnosis (ctx : ConversionContext) (state : B3VerificationState) (sourceDecl : B3AST.Decl SourceRange) : B3AST.Statement SourceRange → IO SymbolicExecutionResult - | .check m expr => do - let convResult := expressionToSMT ctx expr - let vctx := mkVerificationContext state sourceDecl (.check m expr) - let result ← prove state convResult.term vctx - pure <| mkExecutionResult convResult.errors (some result) state - - | .assert m expr => do - let convResult := expressionToSMT ctx expr - let vctx := mkVerificationContext state sourceDecl (.assert m expr) - let result ← prove state convResult.term vctx - -- Always add to path condition (assert assumes its condition regardless of proof result) - let newState ← addPathCondition state expr convResult.term - pure <| mkExecutionResult convResult.errors (some result) newState - - | .assume _ expr => do - let convResult := expressionToSMT ctx expr - let newState ← addPathCondition state expr convResult.term - pure <| mkExecutionResult convResult.errors none newState - - | .reach m expr => do - let convResult := expressionToSMT ctx expr - let vctx := mkVerificationContext state sourceDecl (.reach m expr) - let result ← reach state convResult.term vctx - pure <| mkExecutionResult convResult.errors (some result) state - - | .blockStmt _ stmts => do - let mut currentState := state - let mut allResultsRev := [] - for stmt in stmts.val.toList do - let execResult ← statementToSMTWithoutDiagnosis ctx currentState sourceDecl stmt - currentState := execResult.finalState - allResultsRev := execResult.results.reverse ++ allResultsRev - pure { results := allResultsRev.reverse, finalState := currentState } - - | _ => - pure { results := [], finalState := state } - termination_by stmt => SizeOf.sizeOf stmt - decreasing_by cases stmts; simp_all; term_by_mem - ---------------------------------------------------------------------- --- Statement Formatting ---------------------------------------------------------------------- - -def formatStatement (prog : Program) (stmt : B3AST.Statement SourceRange) (ctx: B3.ToCSTContext): String := - let (cstStmt, _) := B3.stmtToCST ctx stmt - let fmtCtx := FormatContext.ofDialects prog.dialects prog.globalContext {} - let fmtState : FormatState := { openDialects := prog.dialects.toList.foldl (init := {}) fun a (dialect : Dialect) => a.insert dialect.name } - (mformat (ArgF.op cstStmt.toAst) fmtCtx fmtState).format.pretty.trimAscii.toString - -end Strata.B3.Verifier diff --git a/Strata/Languages/C_Simp/Verify.lean b/Strata/Languages/C_Simp/Verify.lean index da3cd6886..43c1fb47e 100644 --- a/Strata/Languages/C_Simp/Verify.lean +++ b/Strata/Languages/C_Simp/Verify.lean @@ -19,17 +19,22 @@ namespace Strata -- 2. Running SymExec of Lambda and Imp +/-- Convert C_Simp expression metadata (Unit) to Core expression metadata (SourceRange). + C_Simp does not track source locations, so we use SourceRange.none. -/ +private def csimpMetaToCore (_ : C_Simp.CSimpLParams.mono.base.Metadata) : Core.CoreLParams.mono.base.Metadata := + Strata.SourceRange.none + def translate_expr (e : C_Simp.Expression.Expr) : Lambda.LExpr Core.CoreLParams.mono := match e with - | .const m c => .const m c - | .op m o ty => .op m ⟨o.name, ()⟩ ty - | .bvar m n => .bvar m n - | .fvar m n ty => .fvar m ⟨n.name, ()⟩ ty - | .abs m name ty e => .abs m name ty (translate_expr e) - | .quant m k name ty tr e => .quant m k name ty (translate_expr tr) (translate_expr e) - | .app m fn e => .app m (translate_expr fn) (translate_expr e) - | .ite m c t e => .ite m (translate_expr c) (translate_expr t) (translate_expr e) - | .eq m e1 e2 => .eq m (translate_expr e1) (translate_expr e2) + | .const m c => .const (csimpMetaToCore m) c + | .op m o ty => .op (csimpMetaToCore m) ⟨o.name, ()⟩ ty + | .bvar m n => .bvar (csimpMetaToCore m) n + | .fvar m n ty => .fvar (csimpMetaToCore m) ⟨n.name, ()⟩ ty + | .abs m name ty e => .abs (csimpMetaToCore m) name ty (translate_expr e) + | .quant m k name ty tr e => .quant (csimpMetaToCore m) k name ty (translate_expr tr) (translate_expr e) + | .app m fn e => .app (csimpMetaToCore m) (translate_expr fn) (translate_expr e) + | .ite m c t e => .ite (csimpMetaToCore m) (translate_expr c) (translate_expr t) (translate_expr e) + | .eq m e1 e2 => .eq (csimpMetaToCore m) (translate_expr e1) (translate_expr e2) def translate_opt_expr (e : Option C_Simp.Expression.Expr) : Option (Lambda.LExpr Core.CoreLParams.mono) := match e with @@ -84,7 +89,8 @@ def loop_elimination_statement(s : C_Simp.Statement) : Core.Statement := let assigned_vars := (Imperative.Block.modifiedVars body).map (λ s => ⟨s.name, ()⟩) let havocd : Core.Statement := .block "loop havoc" (assigned_vars.map (λ n => Core.Statement.havoc n {})) {} - let measure_pos := (.app () (.app () (.op () "Int.Ge" none) (translate_expr measure)) (.intConst () 0)) + -- Synthesized Core expressions have no C_Simp source location; SourceRange.none is used. + let measure_pos := (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Ge" none) (translate_expr measure)) (.intConst Strata.SourceRange.none 0)) let entry_invariants : List Core.Statement := invList.mapIdx fun i inv => .assert s!"entry_invariant_{i}" (translate_expr inv) {} @@ -97,8 +103,8 @@ def loop_elimination_statement(s : C_Simp.Statement) : Core.Statement := ([Core.Statement.assume "assume_guard" (translate_expr guard) {}] ++ inv_assumes ++ [Core.Statement.assume "assume_measure_pos" measure_pos {}]) {} let measure_old_value_assign : Core.Statement := .init "special-name-for-old-measure-value" (.forAll [] (.tcons "int" [])) (some (translate_expr measure)) {} - let measure_decreases : Core.Statement := .assert "measure_decreases" (.app () (.app () (.op () "Int.Lt" none) (translate_expr measure)) (.fvar () "special-name-for-old-measure-value" none)) {} - let measure_imp_not_guard : Core.Statement := .assert "measure_imp_not_guard" (.ite () (.app () (.app () (.op () "Int.Le" none) (translate_expr measure)) (.intConst () 0)) (.app () (.op () "Bool.Not" none) (translate_expr guard)) (.true ())) {} + let measure_decreases : Core.Statement := .assert "measure_decreases" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Lt" none) (translate_expr measure)) (.fvar Strata.SourceRange.none "special-name-for-old-measure-value" none)) {} + let measure_imp_not_guard : Core.Statement := .assert "measure_imp_not_guard" (.ite Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Le" none) (translate_expr measure)) (.intConst Strata.SourceRange.none 0)) (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (translate_expr guard)) (.true Strata.SourceRange.none)) {} let maintain_invariants : List Core.Statement := invList.mapIdx fun i inv => .assert s!"arbitrary_iter_maintain_invariant_{i}" (translate_expr inv) {} let body_statements : List Core.Statement := body.map translate_stmt @@ -106,7 +112,7 @@ def loop_elimination_statement(s : C_Simp.Statement) : Core.Statement := ([havocd, arbitrary_iter_assumes, measure_old_value_assign] ++ body_statements ++ [measure_decreases, measure_imp_not_guard] ++ maintain_invariants) {} - let not_guard : Core.Statement := .assume "not_guard" (.app () (.op () "Bool.Not" none) (translate_expr guard)) {} + let not_guard : Core.Statement := .assume "not_guard" (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (translate_expr guard)) {} let invariant_assumes : List Core.Statement := invList.mapIdx fun i inv => .assume s!"invariant_{i}" (translate_expr inv) {} diff --git a/Strata/Languages/Core/CoreSMT.lean b/Strata/Languages/Core/CoreSMT.lean new file mode 100644 index 000000000..bdba4307f --- /dev/null +++ b/Strata/Languages/Core/CoreSMT.lean @@ -0,0 +1,19 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.SMT.SolverInterface +import Strata.Languages.Core.DiagnosisTypes +import Strata.Languages.Core.CoreSMT.State +import Strata.Languages.Core.CoreSMT.IsCoreSMT +import Strata.Languages.Core.CoreSMT.ExprTranslator +import Strata.Languages.Core.CoreSMT.StmtVerifier +import Strata.Languages.Core.CoreSMT.Diagnosis +import Strata.Languages.Core.CoreSMT.Verifier +import Strata.Languages.Core.CoreSMT.RemoveUnusedVars + +namespace Strata.Core.CoreSMT + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/Diagnosis.lean b/Strata/Languages/Core/CoreSMT/Diagnosis.lean new file mode 100644 index 000000000..eac12f0db --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/Diagnosis.lean @@ -0,0 +1,77 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.CoreSMT.State +import Strata.Languages.Core.CoreSMT.ExprTranslator +import Strata.Languages.Core.DiagnosisTypes + +/-! +# CoreSMT Diagnosis Engine + +When a verification check fails, this module diagnoses the failure by splitting +conjunction expressions and checking each conjunct individually. This helps +identify which specific sub-conditions are responsible for the failure. +-/ + +namespace Strata.Core.CoreSMT + +open Core +open Strata.SMT +open Lambda + +/-- Split a conjunction expression (And operator) into left and right. + Matches the pattern: `app _ (app _ (op _ "Bool.And" _) lhs) rhs` -/ +def splitConjunction (e : Core.Expression.Expr) : Option (Core.Expression.Expr × Core.Expression.Expr) := + match e with + | .app _ (.app _ (.op _ name _) lhs) rhs => + if name.name == "Bool.And" then some (lhs, rhs) + else none + | _ => none + +/-- Diagnose a failed verification check by splitting conjunctions -/ +partial def diagnoseFailure (state : CoreSMTState) (E : Core.Env) + (expr : Core.Expression.Expr) (isReachCheck : Bool) + (smtCtx : Core.SMT.Context) + (pathCondition : List Core.Expression.Expr := []) : IO DiagnosisResult := do + match splitConjunction expr with + | none => + match translateExpr E expr smtCtx with + | Except.error _ => return { diagnosedFailures := [] } + | Except.ok (term, _) => + if isReachCheck then + -- Reach: check if expr is refuted (always false) + let decision ← state.solver.checkSatAssuming [term] + if decision == .unsat then + let report : DiagnosisReport := { result := .error .refuted, context := { pathCondition } } + return { diagnosedFailures := [{ expression := expr, isRefuted := true, report }] } + else + return { diagnosedFailures := [] } + else + let provedDecision ← state.solver.checkSatAssuming [Factory.not term] + if provedDecision == .unsat then + return { diagnosedFailures := [] } + let refutedDecision ← state.solver.checkSatAssuming [term] + let isRefuted := refutedDecision == .unsat + let resultType := if isRefuted then DiagnosisResultType.refuted else DiagnosisResultType.unknown + let report : DiagnosisReport := { result := .error resultType, context := { pathCondition } } + return { diagnosedFailures := [{ expression := expr, isRefuted, report }] } + | some (lhs, rhs) => + let leftResult ← diagnoseFailure state E lhs isReachCheck smtCtx pathCondition + if isReachCheck then + let leftRefuted := leftResult.diagnosedFailures.any (·.isRefuted) + if leftRefuted then + return { diagnosedFailures := leftResult.diagnosedFailures } + match translateExpr E lhs smtCtx with + | Except.error _ => + return { diagnosedFailures := leftResult.diagnosedFailures } + | Except.ok (lhsTerm, _) => + state.solver.push + state.solver.assert lhsTerm + let rightResult ← diagnoseFailure state E rhs isReachCheck smtCtx (lhs :: pathCondition) + state.solver.pop + return { diagnosedFailures := leftResult.diagnosedFailures ++ rightResult.diagnosedFailures } + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/ExprTranslator.lean b/Strata/Languages/Core/CoreSMT/ExprTranslator.lean new file mode 100644 index 000000000..8538668b9 --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/ExprTranslator.lean @@ -0,0 +1,38 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.SMTEncoder +import Strata.Languages.Core.CoreSMT.IsCoreSMT + +/-! +# Expression Translator for CoreSMT Verifier + +Translates Core expressions to SMT terms by delegating to the existing +`Core.toSMTTerm` infrastructure in `SMTEncoder.lean`. Also provides type +translation via `LMonoTy.toSMTType`. +-/ + +namespace Strata.Core.CoreSMT + +open Strata.SMT +open Lambda + +/-- Translate a Core type to an SMT TermType using the existing encoder -/ +def translateType (E : Core.Env) (ty : Core.Expression.Ty) (ctx : Core.SMT.Context) : + Except Std.Format (TermType × Core.SMT.Context) := + Core.LMonoTy.toSMTType E ty.toMonoTypeUnsafe ctx + +/-- Translate a Core expression to an SMT Term using the existing encoder -/ +def translateExpr (E : Core.Env) (e : Core.Expression.Expr) (ctx : Core.SMT.Context) : + Except Std.Format (Term × Core.SMT.Context) := + Core.toSMTTerm E [] e ctx + +/-- Translate a list of Core expressions to SMT Terms -/ +def translateExprs (E : Core.Env) (es : List Core.Expression.Expr) (ctx : Core.SMT.Context) : + Except Std.Format (List Term × Core.SMT.Context) := + Core.toSMTTerms E es ctx + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/IsCoreSMT.lean b/Strata/Languages/Core/CoreSMT/IsCoreSMT.lean new file mode 100644 index 000000000..dc3d199c1 --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/IsCoreSMT.lean @@ -0,0 +1,103 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.Statement + +/-! +# isCoreSMT Predicate + +Defines predicates that characterize the subset of Strata Core that maps +directly to SMT-LIB constructs. Statements and expressions outside this subset +require alternative verification approaches (e.g., symbolic execution, loop +elimination). + +Each predicate returns `Except String` where the error case provides a +human-readable reason why the construct is not in the CoreSMT subset. +-/ + +namespace Strata.Core.CoreSMT + +open Imperative +open Lambda + +/-- Check if a monomorphic type is SMT-native (int, bool, real, string, bitvec, Map, arrow). -/ +def isCoreSMTMonoTy : LMonoTy → Except String Unit + | .tcons "int" [] => .ok () + | .tcons "bool" [] => .ok () + | .tcons "real" [] => .ok () + | .tcons "string" [] => .ok () + | .bitvec _ => .ok () + | .tcons "Map" [k, v] => do isCoreSMTMonoTy k; isCoreSMTMonoTy v + | .tcons "arrow" [a, b] => do isCoreSMTMonoTy a; isCoreSMTMonoTy b + | .ftvar _ => .ok () -- type variables are allowed (polymorphic) + | ty => .error s!"type '{repr ty}' is not an SMT-native type" + +/-- Check if a type scheme is SMT-native. -/ +def isCoreSMTTy : LTy → Except String Unit + | .forAll _ mty => isCoreSMTMonoTy mty + +/-- Predicate for expressions that map to SMT terms. + Abstractions are supported only when immediately applied (translates to SMT let). -/ +def checkCoreSMTExpr : Core.Expression.Expr → Except String Unit + | .const _ _ => .ok () + | .fvar _ _ _ => .ok () + | .bvar _ _ => .ok () + | .op _ _ _ => .ok () + | .eq _ e1 e2 => do checkCoreSMTExpr e1; checkCoreSMTExpr e2 + | .ite _ c t e => do checkCoreSMTExpr c; checkCoreSMTExpr t; checkCoreSMTExpr e + | .quant _ _ _ _ tr b => do checkCoreSMTExpr tr; checkCoreSMTExpr b + | .app _ (.abs _ _ _ body) arg => do checkCoreSMTExpr body; checkCoreSMTExpr arg + | .app _ fn arg => do checkCoreSMTExpr fn; checkCoreSMTExpr arg + | .abs _ _ _ _ => .error "standalone abstraction is not supported in CoreSMT" + +/-- Boolean version for backward compatibility -/ +def isCoreSMTExpr (e : Core.Expression.Expr) : Bool := + (checkCoreSMTExpr e).isOk + +/-- Check a command is in the CoreSMT subset. -/ +def checkCoreSMTCmd : Core.Command → Except String Unit + | .cmd (.assume _ e _) => checkCoreSMTExpr e + | .cmd (.assert _ e _) => checkCoreSMTExpr e + | .cmd (.cover _ e _) => checkCoreSMTExpr e + | .cmd (.init _ ty eOpt _) => do + isCoreSMTTy ty + match eOpt with + | some e => checkCoreSMTExpr e + | none => .ok () + | .cmd (.havoc _ _) => .error "havoc is not in the CoreSMT subset" + | .cmd (.set _ _ _) => .error "assignment (set) is not in the CoreSMT subset" + | .call _ _ _ _ => .error "procedure call is not in the CoreSMT subset" + +/-- Boolean version for backward compatibility -/ +def isCoreSMTCmd (c : Core.Command) : Bool := + (checkCoreSMTCmd c).isOk + +mutual +/-- Check a statement is in the CoreSMT subset. -/ +def checkCoreSMTStmt : Core.Statement → Except String Unit + | .cmd c => checkCoreSMTCmd c + | .block _ stmts _ => checkCoreSMTStmts stmts + | .funcDecl _ _ => .ok () + | .typeDecl _ _ => .ok () + | .ite _ _ _ _ => .error "if-then-else statement is not in the CoreSMT subset" + | .loop _ _ _ _ _ => .error "loop statement is not in the CoreSMT subset" + | .exit _ _ => .error "exit statement is not in the CoreSMT subset" + +/-- Check all statements in a list are CoreSMT -/ +def checkCoreSMTStmts : Core.Statements → Except String Unit + | [] => .ok () + | s :: ss => do checkCoreSMTStmt s; checkCoreSMTStmts ss +end + +/-- Boolean version for backward compatibility -/ +def isCoreSMTStmt (s : Core.Statement) : Bool := + (checkCoreSMTStmt s).isOk + +/-- Boolean version for backward compatibility -/ +def isCoreSMTStmts (ss : Core.Statements) : Bool := + (checkCoreSMTStmts ss).isOk + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/RemoveUnusedVars.lean b/Strata/Languages/Core/CoreSMT/RemoveUnusedVars.lean new file mode 100644 index 000000000..05a297664 --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/RemoveUnusedVars.lean @@ -0,0 +1,91 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.Statement + +/-! +# Remove Unused Variables + +A Core-to-Core transformation that removes `init` statements for variables +that are never referenced in subsequent statements. This is useful as a +pre-processing step before CoreSMT verification, where unused variables +with non-SMT types would cause errors. +-/ + +namespace Strata.Core.CoreSMT + +open Imperative +open Lambda + +/-- Collect all free variable names referenced in an expression. -/ +partial def collectExprVarNames : Core.Expression.Expr → List String + | .fvar _ name _ => [name.name] + | .eq _ e1 e2 => collectExprVarNames e1 ++ collectExprVarNames e2 + | .ite _ c t e => collectExprVarNames c ++ collectExprVarNames t ++ collectExprVarNames e + | .quant _ _ _ _ tr b => collectExprVarNames tr ++ collectExprVarNames b + | .app _ fn arg => collectExprVarNames fn ++ collectExprVarNames arg + | .abs _ _ _ body => collectExprVarNames body + | _ => [] + +/-- Collect all variable names referenced in a command (excluding the defined variable). -/ +def collectCmdUsedVarNames : Core.Command → List String + | .cmd (.assume _ e _) => collectExprVarNames e + | .cmd (.assert _ e _) => collectExprVarNames e + | .cmd (.cover _ e _) => collectExprVarNames e + | .cmd (.init _ _ (some e) _) => collectExprVarNames e + | .cmd (.init _ _ none _) => [] + | .cmd (.havoc _ _) => [] + | .cmd (.set _ e _) => collectExprVarNames e + | .call _ _ args _ => args.flatMap collectExprVarNames + +mutual +/-- Collect all variable names referenced in a statement. -/ +partial def collectStmtUsedVarNames : Core.Statement → List String + | .cmd c => collectCmdUsedVarNames c + | .block _ stmts _ => collectStmtsUsedVarNames stmts + | .funcDecl decl _ => + match decl.body with + | some e => collectExprVarNames e + | none => [] + | .typeDecl _ _ => [] + | .ite cond thenB elseB _ => + collectExprVarNames cond ++ collectStmtsUsedVarNames thenB ++ collectStmtsUsedVarNames elseB + | .loop guard _ _ body _ => + collectExprVarNames guard ++ collectStmtsUsedVarNames body + | .exit _ _ => [] + +/-- Collect all variable names referenced in a list of statements. -/ +partial def collectStmtsUsedVarNames : Core.Statements → List String + | [] => [] + | s :: ss => collectStmtUsedVarNames s ++ collectStmtsUsedVarNames ss +end + +mutual +/-- Remove unused init statements from a statement. -/ +partial def removeUnusedVarsStmt : Core.Statement → Core.Statement + | .block label stmts md => .block label (removeUnusedVarsStmts stmts) md + | .ite cond thenB elseB md => + .ite cond (removeUnusedVarsStmts thenB) (removeUnusedVarsStmts elseB) md + | .loop guard measure invs body md => + .loop guard measure invs (removeUnusedVarsStmts body) md + | s => s + +/-- Remove unused init statements from a list of statements. + An init is unused if the variable name doesn't appear in any subsequent statement. -/ +partial def removeUnusedVarsStmts : Core.Statements → Core.Statements + | [] => [] + | s :: rest => + let rest' := removeUnusedVarsStmts rest + match s with + | .cmd (.cmd (.init name _ _ _)) => + if (collectStmtsUsedVarNames rest').contains name.name then + removeUnusedVarsStmt s :: rest' + else + rest' + | _ => removeUnusedVarsStmt s :: rest' +end + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/State.lean b/Strata/Languages/Core/CoreSMT/State.lean new file mode 100644 index 000000000..d46ea2abb --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/State.lean @@ -0,0 +1,63 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.SMT.State + +namespace Strata.Core.CoreSMT + +/-- Configuration for CoreSMT verification -/ +structure CoreSMTConfig where + /-- Continue verification after errors (accumulate all errors) -/ + accumulateErrors : Bool := true + deriving Repr, Inhabited + +/-- CoreSMT verification state -/ +structure CoreSMTState where + /-- SMT solver state -/ + smtState : SMT.VerifierState + /-- CoreSMT-specific configuration -/ + config : CoreSMTConfig + /-- Stack of Core expression assumptions (for diagnosis path conditions) -/ + assumptionStack : List (List Core.Expression.Expr) := [[]] + +def CoreSMTState.init (solver : SMT.SolverInterface) (config : CoreSMTConfig := {}) : CoreSMTState := + { smtState := SMT.VerifierState.init solver, config } + +/-- Get current path condition (all assumptions in scope) -/ +def CoreSMTState.pathCondition (state : CoreSMTState) : List Core.Expression.Expr := + state.assumptionStack.flatten + +/-- Add a Core expression assumption to the current scope -/ +def CoreSMTState.addAssumption (state : CoreSMTState) (e : Core.Expression.Expr) : CoreSMTState := + match state.assumptionStack with + | [] => { state with assumptionStack := [[e]] } + | scope :: rest => { state with assumptionStack := (e :: scope) :: rest } + +-- Delegate methods to smtState +def CoreSMTState.push (state : CoreSMTState) : IO CoreSMTState := do + let smtState ← state.smtState.push + return { state with smtState, assumptionStack := [] :: state.assumptionStack } + +def CoreSMTState.pop (state : CoreSMTState) : IO CoreSMTState := do + let smtState ← state.smtState.pop + match state.assumptionStack with + | [] => return { state with smtState } + | _ :: rest => return { state with smtState, assumptionStack := rest } + +def CoreSMTState.addItem (state : CoreSMTState) (item : SMT.ContextItem) : CoreSMTState := + { state with smtState := state.smtState.addItem item } + +def CoreSMTState.allContextItems (state : CoreSMTState) : List SMT.ContextItem := + state.smtState.allContextItems + +-- Accessors for SMT state fields (as abbrevs for dot notation) +@[inline] def CoreSMTState.solver (state : CoreSMTState) : SMT.SolverInterface := + state.smtState.solver + +@[inline] def CoreSMTState.contextStack (state : CoreSMTState) : SMT.ContextStack := + state.smtState.contextStack + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/StmtVerifier.lean b/Strata/Languages/Core/CoreSMT/StmtVerifier.lean new file mode 100644 index 000000000..40f1ec4b0 --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/StmtVerifier.lean @@ -0,0 +1,246 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.DL.SMT.State +import Strata.Languages.Core.CoreSMT.State +import Strata.Languages.Core.CoreSMT.ExprTranslator +import Strata.Languages.Core.CoreSMT.IsCoreSMT +import Strata.Languages.Core.CoreSMT.Diagnosis +import Strata.Languages.Core.Verifier + +/-! +# Statement Processor for CoreSMT Verifier + +Processes CoreSMT statements by translating them to SMT solver commands. +Each statement type maps to specific SMT-LIB operations: +- assume → assert +- init with expr → define-fun +- init without expr → declare-fun +- assert → check-sat of negation (push/pop) +- cover → check-sat (push/pop) +- block → push/pop +- funcDecl → declare-fun or define-fun +-/ + +namespace Strata.Core.CoreSMT + +open Core +open Strata.SMT +open Lambda +open Imperative + +/-- Run a verification check: for assert, negate the expression; for cover, use it directly. -/ +private def runCheck (state : CoreSMTState) (E : Core.Env) + (label : String) (expr : Core.Expression.Expr) (property : Imperative.PropertyType) + (smtCtx : Core.SMT.Context) (md : Imperative.MetaData Core.Expression := .empty) + : IO (Core.VCResult × Core.SMT.Context) := do + match translateExpr E expr smtCtx with + | .error msg => + let obligation : Imperative.ProofObligation Core.Expression := { + label, property, assumptions := [], obligation := expr, metadata := md + } + return ({ obligation, result := .implementationError s!"Translation error: {msg}" }, smtCtx) + | .ok (term, smtCtx) => + let isCover := property == .cover + let checkTerm := if isCover then term else Factory.not term + let decision ← state.solver.checkSatAssuming [checkTerm] + let outcome := match isCover, decision with + | true, .sat => Core.Outcome.pass + | true, .unsat => Core.Outcome.fail + | true, .unknown => Core.Outcome.unknown + | false, .unsat => Core.Outcome.pass + | false, .sat => Core.Outcome.fail + | false, .unknown => Core.Outcome.unknown + let obligation : Imperative.ProofObligation Core.Expression := { + label, property, assumptions := [], obligation := expr, metadata := md + } + let smtObligationResult := match decision with + | .unsat => SMT.Result.unsat + | .sat => SMT.Result.unknown + | .unknown => SMT.Result.unknown + let diagnosis ← if outcome != .pass then + let diagResult ← diagnoseFailure state E expr isCover smtCtx + let statePathCond := state.pathCondition + let failures := diagResult.diagnosedFailures.map fun f => + { f with report := { f.report with context := + { pathCondition := f.report.context.pathCondition ++ statePathCond } } } + pure (some { isRefuted := failures.any (·.isRefuted), diagnosedFailures := failures, + statePathCondition := statePathCond }) + else + pure none + return ({ obligation, smtObligationResult, result := outcome, diagnosis }, smtCtx) + +private def proveCheck (state : CoreSMTState) (E : Core.Env) + (label : String) (expr : Core.Expression.Expr) + (smtCtx : Core.SMT.Context) (md : Imperative.MetaData Core.Expression := .empty) := + runCheck state E label expr .assert smtCtx md + +private def coverCheck (state : CoreSMTState) (E : Core.Env) + (label : String) (expr : Core.Expression.Expr) + (smtCtx : Core.SMT.Context) (md : Imperative.MetaData Core.Expression := .empty) := + runCheck state E label expr .cover smtCtx md + +private def processFuncDecl (state : CoreSMTState) (E : Core.Env) + (decl : Imperative.PureFunc Core.Expression) (smtCtx : Core.SMT.Context) + : IO (CoreSMTState × Core.SMT.Context × List Core.VCResult) := do + let inputTypesResult ← decl.inputs.foldlM (fun (acc : Except Std.Format (List TermType)) (_, ty) => do + match acc with + | .error msg => return .error msg + | .ok types => + match translateType E ty smtCtx with + | .error msg => return .error msg + | .ok (smtTy, _) => return .ok (types ++ [smtTy]) + ) (.ok []) + let mkError (msg : String) : Core.VCResult := + let dummyExpr : Core.Expression.Expr := .const Strata.SourceRange.none (.boolConst true) + { obligation := { label := s!"funcDecl {decl.name.name}", property := .assert, + assumptions := [], obligation := dummyExpr, metadata := .empty }, + result := .implementationError msg } + match inputTypesResult with + | .error msg => return (state, smtCtx, [mkError s!"Type translation error: {toString msg}"]) + | .ok inputTypes => + match translateType E decl.output smtCtx with + | .error msg => return (state, smtCtx, [mkError s!"Output type translation error: {toString msg}"]) + | .ok (outTy, smtCtx) => + let ufArgs := decl.inputs.zip inputTypes |>.map fun ((name, _), smtTy) => TermVar.mk name.name smtTy + let uf : UF := { id := decl.name.name, args := ufArgs, out := outTy } + let smtCtx := smtCtx.addUF uf + match decl.body with + | none => + state.solver.declareFun decl.name.name inputTypes outTy + return ({ state with smtState := state.smtState.addItem (.funcDecl decl.name.name inputTypes outTy) }, smtCtx, []) + | some body => + match translateExpr E body smtCtx with + | .error msg => + return (state, smtCtx, [{ obligation := { label := s!"funcDecl {decl.name.name}", property := .assert, + assumptions := [], obligation := body, metadata := .empty }, + result := .implementationError s!"Body translation error: {msg}" }]) + | .ok (bodyTerm, smtCtx) => + let args := decl.inputs.zip inputTypes |>.map fun ((name, _), smtTy) => (name.name, smtTy) + state.solver.defineFun decl.name.name args outTy bodyTerm + return ({ state with smtState := state.smtState.addItem (.funcDef decl.name.name args outTy bodyTerm) }, smtCtx, []) + +mutual +/-- Process a single CoreSMT statement. Returns updated state, SMT context, + and an optional check result (for assert/cover). -/ +partial def processStatement (state : CoreSMTState) (E : Core.Env) + (stmt : Core.Statement) (smtCtx : Core.SMT.Context) + : IO (CoreSMTState × Core.SMT.Context × List Core.VCResult) := do + match checkCoreSMTStmt stmt with + | .error reason => + let obligation : Imperative.ProofObligation Core.Expression := { + label := "non-CoreSMT" + property := .assert + assumptions := [] + obligation := .fvar Strata.SourceRange.none (⟨"error", ()⟩) none + metadata := .empty + } + let result : Core.VCResult := { obligation, result := .implementationError s!"Statement not in CoreSMT subset: {reason}" } + return (state, smtCtx, [result]) + | .ok () => + match stmt with + | Core.Statement.assume _label expr _ => + match translateExpr E expr smtCtx with + | .error msg => + let obligation : Imperative.ProofObligation Core.Expression := { + label := "assume", property := .assert, assumptions := [], obligation := expr, metadata := .empty + } + return (state, smtCtx, [{ obligation, result := .implementationError s!"Translation error: {msg}" }]) + | .ok (term, smtCtx) => + let solver : SMT.SolverInterface := state.solver + solver.assert term + let state := state.addItem (.assumption term) + let state := state.addAssumption expr + return (state, smtCtx, []) + + | Core.Statement.init name ty (some expr) _ => + match translateExpr E expr smtCtx with + | .error msg => + let obligation : Imperative.ProofObligation Core.Expression := { + label := s!"init {name.name}", property := .assert, assumptions := [], obligation := expr, metadata := .empty + } + return (state, smtCtx, [{ obligation, result := .implementationError s!"Translation error: {msg}" }]) + | .ok (term, smtCtx) => + match translateType E ty smtCtx with + | .error msg => + let obligation : Imperative.ProofObligation Core.Expression := { + label := s!"init {name.name}", property := .assert, assumptions := [], obligation := expr, metadata := .empty + } + return (state, smtCtx, [{ obligation, result := .implementationError s!"Type translation error: {msg}" }]) + | .ok (smtTy, smtCtx) => + let solver : SMT.SolverInterface := state.solver + solver.defineFun name.name [] smtTy term + let state := state.addItem (.varDef name.name smtTy term) + -- Track the definition as an assumption for diagnosis context (x == expr) + let nameExpr : Core.Expression.Expr := .fvar Strata.SourceRange.none name none + let eqExpr : Core.Expression.Expr := .eq Strata.SourceRange.none nameExpr expr + let state := state.addAssumption eqExpr + return (state, smtCtx, []) + + | Core.Statement.init name ty none _ => + match translateType E ty smtCtx with + | .error msg => + -- Use a dummy expression for error reporting + let dummyExpr : Core.Expression.Expr := .const Strata.SourceRange.none (.boolConst true) + let obligation : Imperative.ProofObligation Core.Expression := { + label := s!"init {name.name}", property := .assert, assumptions := [], + obligation := dummyExpr, metadata := .empty + } + return (state, smtCtx, [{ obligation, result := .implementationError s!"Type translation error: {toString msg}" }]) + | .ok (smtTy, smtCtx) => + let solver : SMT.SolverInterface := state.solver + solver.declareFun name.name [] smtTy + let state := state.addItem (.varDecl name.name smtTy) + return (state, smtCtx, []) + + | Core.Statement.assert label expr md => + let (result, smtCtx) ← proveCheck state E label expr smtCtx md + return (state, smtCtx, [result]) + + | Core.Statement.cover label expr md => + let (result, smtCtx) ← coverCheck state E label expr smtCtx md + return (state, smtCtx, [result]) + + | .block _label stmts _ => + let state ← state.push + let (state, smtCtx, results) ← processStatements state E stmts smtCtx + let state ← state.pop + return (state, smtCtx, results) + + | .funcDecl decl _ => + processFuncDecl state E decl smtCtx + + | _ => + let obligation : Imperative.ProofObligation Core.Expression := { + label := "unknown" + property := .assert + assumptions := [] + obligation := .fvar Strata.SourceRange.none (⟨"error", ()⟩) none + metadata := .empty + } + return (state, smtCtx, [{ obligation, result := .implementationError "Unexpected statement" }]) + +/-- Process a list of CoreSMT statements sequentially -/ +partial def processStatements (initialState : CoreSMTState) (E : Core.Env) + (stmts : List Core.Statement) (smtCtx : Core.SMT.Context) + : IO (CoreSMTState × Core.SMT.Context × List Core.VCResult) := do + let accumulateErrors := initialState.config.accumulateErrors + let mut state := initialState + let mut smtCtx := smtCtx + let mut results : List Core.VCResult := [] + for stmt in stmts do + let (state', smtCtx', stmtResults) ← processStatement state E stmt smtCtx + state := state' + smtCtx := smtCtx' + results := results ++ stmtResults + -- If not accumulating errors and we got a failure, stop + let shouldStop := !accumulateErrors && stmtResults.any (·.result != Core.Outcome.pass) + if shouldStop then + return (state, smtCtx, results) + return (state, smtCtx, results) +end + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/CoreSMT/Verifier.lean b/Strata/Languages/Core/CoreSMT/Verifier.lean new file mode 100644 index 000000000..bde731f57 --- /dev/null +++ b/Strata/Languages/Core/CoreSMT/Verifier.lean @@ -0,0 +1,36 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.CoreSMT.StmtVerifier +import Strata.Languages.Core.CoreSMT.Diagnosis + +/-! +# CoreSMT Verifier Public Interface + +Provides the main entry point for verifying CoreSMT programs. The verifier +processes statements sequentially, accumulating results and returning updated +state for reuse. +-/ + +namespace Strata.Core.CoreSMT + +/-- Verify a list of CoreSMT statements. Returns updated state and check results. -/ +def verify (state : CoreSMTState) (E : Core.Env) (stmts : List Core.Statement) + (smtCtx : Core.SMT.Context := Core.SMT.Context.default) + : IO (CoreSMTState × Core.SMT.Context × List Core.VCResult) := do + let (state, smtCtx, results) ← processStatements state E stmts smtCtx + return (state, smtCtx, results) + +/-- Process prelude statements to initialize state for subsequent verification. + Returns state ready for reuse across multiple verify calls. -/ +def processPrelude (state : CoreSMTState) (E : Core.Env) + (prelude : List Core.Statement) + (smtCtx : Core.SMT.Context := Core.SMT.Context.default) + : IO (CoreSMTState × Core.SMT.Context) := do + let (state, smtCtx, _) ← processStatements state E prelude smtCtx + return (state, smtCtx) + +end Strata.Core.CoreSMT diff --git a/Strata/Languages/Core/DDMTransform/ASTtoCST.lean b/Strata/Languages/Core/DDMTransform/ASTtoCST.lean index 7411d5efd..22c7dfab4 100644 --- a/Strata/Languages/Core/DDMTransform/ASTtoCST.lean +++ b/Strata/Languages/Core/DDMTransform/ASTtoCST.lean @@ -785,6 +785,18 @@ partial def stmtToCST {M} [Inhabited M] (s : Core.Statement) ⟨default, none⟩ tyCST let dl := DeclList.declAtom default bind pure (.varStatement default dl) + | some (.fvar _ f _) => + -- Handle free variable initializers (e.g., `var tmp := x` from CallElim). + -- Look up the variable in the bound context; if not found, format it as an expression. + let ctx ← get + match ctx.freeVarIndex? f.name with + | some idx => + let exprCST := CoreDDM.Expr.fvar default idx + pure (.initStatement default tyCST nameAnn exprCST) + | none => do + -- Free variable not in bound context - format as expression + let exprCST ← lexprToExpr (.fvar Strata.SourceRange.none f none) 0 + pure (.initStatement default tyCST nameAnn exprCST) | some e => let exprCST ← lexprToExpr e 0 pure (.initStatement default tyCST nameAnn exprCST) diff --git a/Strata/Languages/Core/DDMTransform/Translate.lean b/Strata/Languages/Core/DDMTransform/Translate.lean index 326dce824..047adc852 100644 --- a/Strata/Languages/Core/DDMTransform/Translate.lean +++ b/Strata/Languages/Core/DDMTransform/Translate.lean @@ -659,14 +659,14 @@ def translateQuantifier TransM Core.Expression.Expr := do let xsArray ← translateDeclList bindings xsa -- Note: the indices in the following are placeholders - let newBoundVars := List.toArray (xsArray.mapIdx (fun i _ => LExpr.bvar () i)) + let newBoundVars := List.toArray (xsArray.mapIdx (fun i _ => LExpr.bvar xsa.ann i)) let boundVars' := bindings.boundVars ++ newBoundVars let xbindings := { bindings with boundVars := boundVars' } let b ← translateExpr p xbindings bodya -- Handle triggers if present let triggers ← match triggersa with - | none => pure (LExpr.noTrigger ()) + | none => pure (LExpr.noTrigger bodya.ann) | some tsa => translateTriggers p xbindings tsa -- Create one quantifier constructor per variable @@ -677,8 +677,8 @@ def translateQuantifier let triggers := if first then triggers else - LExpr.noTrigger () - (.quant () qk name.name (.some mty) triggers e, false) + LExpr.noTrigger bodya.ann + (.quant bodya.ann qk name.name (.some mty) triggers e, false) | _ => panic! s!"Expected monomorphic type in quantifier, got: {ty}" return xsArray.foldr buildQuantifier (init := (b, true)) |>.1 @@ -691,7 +691,7 @@ def translateTriggerGroup (p: Program) (bindings : TransBindings) (arg : Arg) : match op.name, op.args with | q`Core.trigger, #[tsa] => do let ts ← translateCommaSep (fun t => translateExpr p bindings t) tsa - return ts.foldl (fun g t => .app () (.app () Core.addTriggerOp t) g) Core.emptyTriggerGroupOp + return ts.foldl (fun g t => .app arg.ann (.app arg.ann Core.addTriggerOp t) g) Core.emptyTriggerGroupOp | _, _ => panic! s!"Unexpected operator in trigger group" partial @@ -702,69 +702,70 @@ def translateTriggers (p: Program) (bindings : TransBindings) (arg : Arg) : match op.name, op.args with | q`Core.triggersAtom, #[group] => let g ← translateTriggerGroup p bindings group - return .app () (.app () Core.addTriggerGroupOp g) Core.emptyTriggersOp + return .app arg.ann (.app arg.ann Core.addTriggerGroupOp g) Core.emptyTriggersOp | q`Core.triggersPush, #[triggers, group] => do let ts ← translateTriggers p bindings triggers let g ← translateTriggerGroup p bindings group - return .app () (.app () Core.addTriggerGroupOp g) ts + return .app arg.ann (.app arg.ann Core.addTriggerGroupOp g) ts | _, _ => panic! s!"Unexpected operator in trigger" partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : TransM Core.Expression.Expr := do let .expr expr := arg | TransM.error s!"translateExpr expected expr {repr arg}" + let sr := arg.ann let (op, args) := expr.flatten match op, args with -- Constants/Literals | .fn _ q`Core.btrue, [] => - return .true () + return .true sr | .fn _ q`Core.bfalse, [] => - return .false () + return .false sr | .fn _ q`Core.natToInt, [xa] => let n ← translateNat xa - return .intConst () n + return .intConst sr n | .fn _ q`Core.bv1Lit, [xa] => let n ← translateBitVec 1 xa - return .bitvecConst () 1 n + return .bitvecConst sr 1 n | .fn _ q`Core.bv8Lit, [xa] => let n ← translateBitVec 8 xa - return .bitvecConst () 8 n + return .bitvecConst sr 8 n | .fn _ q`Core.bv16Lit, [xa] => let n ← translateBitVec 16 xa - return .bitvecConst () 16 n + return .bitvecConst sr 16 n | .fn _ q`Core.bv32Lit, [xa] => let n ← translateBitVec 32 xa - return .bitvecConst () 32 n + return .bitvecConst sr 32 n | .fn _ q`Core.bv64Lit, [xa] => let n ← translateBitVec 64 xa - return .bitvecConst () 64 n + return .bitvecConst sr 64 n | .fn _ q`Core.strLit, [xa] => let x ← translateStr xa - return .strConst () x + return .strConst sr x | .fn _ q`Core.realLit, [xa] => let x ← translateReal xa - return .realConst () (Strata.Decimal.toRat x) + return .realConst sr (Strata.Decimal.toRat x) -- Equality | .fn _ q`Core.equal, [_tpa, xa, ya] => let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya - return .eq () x y + return .eq sr x y | .fn _ q`Core.not_equal, [_tpa, xa, ya] => let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya - return (.app () Core.boolNotOp (.eq () x y)) + return (.app sr Core.boolNotOp (.eq sr x y)) | .fn _ q`Core.bvnot, [tpa, xa] => let tp ← translateLMonoTy bindings (dealiasTypeArg p tpa) let x ← translateExpr p bindings xa let fn : LExpr Core.CoreLParams.mono ← translateFn (.some tp) q`Core.bvnot - return (.app () fn x) + return (.app sr fn x) -- If-then-else expression | .fn _ q`Core.if, [_tpa, ca, ta, fa] => let c ← translateExpr p bindings ca let t ← translateExpr p bindings ta let f ← translateExpr p bindings fa - return .ite () c t f + return .ite sr c t f -- Re.AllChar | .fn _ q`Core.re_allchar, [] => let fn ← translateFn .none q`Core.re_allchar @@ -797,23 +798,23 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : | q`Core.re_comp => do let fn ← translateFn .none fni let x ← translateExpr p bindings xa - return .mkApp () fn [x] + return .mkApp sr fn [x] | _ => TransM.error s!"translateExpr unimplemented {repr op} {repr args}" | .fn _ q`Core.neg_expr, [tpa, xa] => let ty ← translateLMonoTy bindings (dealiasTypeArg p tpa) let fn ← translateFn ty q`Core.neg_expr let x ← translateExpr p bindings xa - return .mkApp () fn [x] + return .mkApp sr fn [x] -- Strings | .fn _ q`Core.str_concat, [xa, ya] => let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya - return .mkApp () Core.strConcatOp [x, y] + return .mkApp sr Core.strConcatOp [x, y] | .fn _ q`Core.str_substr, [xa, ia, na] => let x ← translateExpr p bindings xa let i ← translateExpr p bindings ia let n ← translateExpr p bindings na - return .mkApp () Core.strSubstrOp [x, i, n] + return .mkApp sr Core.strSubstrOp [x, i, n] | .fn _ q`Core.old, [_tp, xa] => let x ← translateExpr p bindings xa match x with @@ -823,19 +824,19 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : let kty ← translateLMonoTy bindings _ktp let vty ← translateLMonoTy bindings _vtp -- TODO: use Core.mapSelectOp, but specialized - let fn : LExpr Core.CoreLParams.mono := (LExpr.op () "select" (.some (LMonoTy.mkArrow (Core.mapTy kty vty) [kty, vty]))) + let fn : LExpr Core.CoreLParams.mono := (LExpr.op sr "select" (.some (LMonoTy.mkArrow (Core.mapTy kty vty) [kty, vty]))) let m ← translateExpr p bindings ma let i ← translateExpr p bindings ia - return .mkApp () fn [m, i] + return .mkApp sr fn [m, i] | .fn _ q`Core.map_set, [_ktp, _vtp, ma, ia, xa] => let kty ← translateLMonoTy bindings _ktp let vty ← translateLMonoTy bindings _vtp -- TODO: use Core.mapUpdateOp, but specialized - let fn : LExpr Core.CoreLParams.mono := (LExpr.op () "update" (.some (LMonoTy.mkArrow (Core.mapTy kty vty) [kty, vty, Core.mapTy kty vty]))) + let fn : LExpr Core.CoreLParams.mono := (LExpr.op sr "update" (.some (LMonoTy.mkArrow (Core.mapTy kty vty) [kty, vty, Core.mapTy kty vty]))) let m ← translateExpr p bindings ma let i ← translateExpr p bindings ia let x ← translateExpr p bindings xa - return .mkApp () fn [m, i, x] + return .mkApp sr fn [m, i, x] -- Quantifiers | .fn _ q`Core.forall, [xsa, ba] => translateQuantifier .all p bindings xsa .none ba @@ -850,13 +851,13 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : let fn ← translateFn .none fni let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya - return .mkApp () fn [x, y] + return .mkApp sr fn [x, y] | .fn _ q`Core.re_loop, [xa, ya, za] => let fn ← translateFn .none q`Core.re_loop let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya let z ← translateExpr p bindings za - return .mkApp () fn [x, y, z] + return .mkApp sr fn [x, y, z] -- Binary function applications (polymorphic) | .fn _ fni, [tpa, xa, ya] => match fni with @@ -894,7 +895,7 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : let fn ← translateFn (.some ty) fni let x ← translateExpr p bindings xa let y ← translateExpr p bindings ya - return .mkApp () fn [x, y] + return .mkApp sr fn [x, y] | _ => TransM.error s!"translateExpr unimplemented {repr op} {repr args}" -- NOTE: Bound and free variables are numbered differently. Bound variables -- ascending order (so closer to deBrujin levels). @@ -908,7 +909,7 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : | _ => return expr | _ => let args ← translateExprs p bindings argsa.toArray - return .mkApp () expr args.toList + return .mkApp sr expr args.toList else -- Bound variable index exceeds boundVars - check if it's a local function let funcIndex := i - bindings.boundVars.size @@ -920,7 +921,7 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : | [] => return func.opExpr | _ => let args ← translateExprs p bindings argsa.toArray - return .mkApp () func.opExpr args.toList + return .mkApp sr func.opExpr args.toList | _ => TransM.error s!"translateExpr out-of-range bound variable: {i}" else TransM.error s!"translateExpr out-of-range bound variable: {i}" @@ -933,10 +934,10 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : match decl with | .var name _ty _expr _md => -- Global Variable - return (.fvar () name ty?) + return (.fvar sr name ty?) | .func func _md => -- 0-ary Function - return (.op () func.name ty?) + return (.op sr func.name ty?) | _ => TransM.error s!"translateExpr unimplemented fvar decl (no args): {format decl}" | .fvar _ i, argsa => @@ -946,7 +947,7 @@ partial def translateExpr (p : Program) (bindings : TransBindings) (arg : Arg) : match decl with | .func func _md => let args ← translateExprs p bindings argsa.toArray - return .mkApp () func.opExpr args.toList + return .mkApp sr func.opExpr args.toList | _ => TransM.error s!"translateExpr unimplemented fvar decl: {format decl} \nargs:{repr argsa}" | op, args => @@ -1005,7 +1006,7 @@ def translateVarStatement (bindings : TransBindings) (decls : Array Arg) let (stmts, bindings) ← initVarStmts tpids bindings md let newVars ← tpids.mapM (fun (id, ty) => if h: ty.isMonoType then - return ((LExpr.fvar () id (ty.toMonoType h)): LExpr Core.CoreLParams.mono) + return ((LExpr.fvar decls[0]!.ann id (ty.toMonoType h)): LExpr Core.CoreLParams.mono) else TransM.error s!"translateVarStatement requires {id} to have a monomorphic type, but it has type {ty}") let bbindings := bindings.boundVars ++ newVars @@ -1021,7 +1022,7 @@ def translateInitStatement (p : Program) (bindings : TransBindings) (args : Arra let lhs ← translateIdent Core.CoreIdent args[1]! let val ← translateExpr p bindings args[2]! let ty := (.forAll [] mty) - let newBinding: LExpr Core.CoreLParams.mono := LExpr.fvar () lhs mty + let newBinding: LExpr Core.CoreLParams.mono := LExpr.fvar args[1]!.ann lhs mty let bbindings := bindings.boundVars ++ [newBinding] return ([.init lhs ty val md], { bindings with boundVars := bbindings }) @@ -1047,7 +1048,7 @@ partial def translateFnPreconds (p : Program) (name : Core.CoreIdent) (bindings let args ← checkOpArg specElt q`Core.requires_spec 3 let _l ← translateOptionLabel s!"{name.name}_requires_{count}" args[0]! let e ← translateExpr p bindings args[2]! - return (acc ++ [⟨e, ()⟩], count + 1) + return (acc ++ [⟨e, specElt.ann⟩], count + 1) | _ => TransM.error s!"translateFnPreconds: only requires allowed, got {repr op.name}" return preconds.1 @@ -1142,8 +1143,8 @@ partial def translateStmt (p : Program) (bindings : TransBindings) (arg : Arg) : -- The function name is NOT in scope inside the body (declareFn adds it -- for subsequent statements only). So body bindings = outer + parameters. let funcType := Lambda.LMonoTy.mkArrow outputMono (inputs.values.reverse) - let funcBinding : LExpr Core.CoreLParams.mono := .op () name (some funcType) - let in_bindings := (inputs.map (fun (v, ty) => (LExpr.fvar () v ty))).toArray + let funcBinding : LExpr Core.CoreLParams.mono := .op namea.ann name (some funcType) + let in_bindings := (inputs.map (fun (v, ty) => (LExpr.fvar bindingsa.ann v ty))).toArray let bodyBindings := { bindings with boundVars := bindings.boundVars ++ in_bindings } -- Translate preconditions @@ -1337,8 +1338,8 @@ def translateProcedure (p : Program) (bindings : TransBindings) (op : Operation) let typeArgs ← translateTypeArgs op.args[1]! let sig ← translateBindings bindings op.args[2]! let ret ← translateOptionMonoDeclList bindings op.args[3]! - let in_bindings := (sig.map (fun (v, ty) => (LExpr.fvar () v ty))).toArray - let out_bindings := (ret.map (fun (v, ty) => (LExpr.fvar () v ty))).toArray + let in_bindings := (sig.map (fun (v, ty) => (LExpr.fvar op.args[2]!.ann v ty))).toArray + let out_bindings := (ret.map (fun (v, ty) => (LExpr.fvar op.args[3]!.ann v ty))).toArray -- This bindings order -- original, then inputs, and then outputs, is -- critical here. Is this right though? let origBindings := bindings @@ -1458,7 +1459,9 @@ def translateFunction (status : FnInterp) (p : Program) (bindings : TransBinding let sig := sigAndCases.1 let casesIdx := sigAndCases.2 let ret ← translateLMonoTy bindings op.args[3]! - let in_bindings := (sig.map (fun (v, ty) => (LExpr.fvar () v ty))).toArray + let in_bindings := (sig.map (fun (v, ty) => (LExpr.fvar op.args[2]!.ann v ty))).toArray + -- This bindings order -- original, then inputs, is + -- critical here. Is this right though? let orig_bbindings := bindings.boundVars -- INVARIANT: The binding order here must exactly match the DDM elaborator's -- typing context in `Elab/Core.lean` (the `scopeSelf` branch), which pushes: @@ -1470,9 +1473,9 @@ def translateFunction (status : FnInterp) (p : Program) (bindings : TransBinding let bbindings ← match status with | .RecursiveDefinition => let fnTy := LMonoTy.mkArrow' ret (sig.map Prod.snd) - let selfBinding := LExpr.op () fname fnTy + let selfBinding := LExpr.op op.args[2]!.ann fname fnTy let tyArgPlaceholders := typeArgs.map fun (ta: TyIdentifier) => - LExpr.op () (ta : Core.CoreIdent) .none + LExpr.op op.args[2]!.ann (ta : Core.CoreIdent) .none pure (bindings.boundVars ++ #[selfBinding] ++ tyArgPlaceholders ++ in_bindings) | _ => pure (bindings.boundVars ++ in_bindings) let bindings := { bindings with boundVars := bbindings } diff --git a/Strata/Languages/Core/DiagnosisTypes.lean b/Strata/Languages/Core/DiagnosisTypes.lean new file mode 100644 index 000000000..01fd9bd00 --- /dev/null +++ b/Strata/Languages/Core/DiagnosisTypes.lean @@ -0,0 +1,49 @@ +/- + Copyright Strata Contributors + + SPDX-License-Identifier: Apache-2.0 OR MIT +-/ + +import Strata.Languages.Core.Expressions + +/-! +# Core Diagnosis Types + +Types for verification diagnosis results, used by the CoreSMT pipeline +and `Core.Verifier`. +-/ + +namespace Strata.Core + +/-- Verification result for diagnosis -/ +inductive DiagnosisResultType + | refuted + | counterexample + | unknown + deriving Repr, Inhabited + +/-- Context for a diagnosed failure -/ +structure DiagnosisContext where + pathCondition : List Core.Expression.Expr := [] + deriving Inhabited + +/-- Report for a diagnosed failure -/ +structure DiagnosisReport where + result : Except DiagnosisResultType Unit + context : DiagnosisContext + deriving Inhabited + +/-- Result of diagnosing a single sub-expression -/ +structure DiagnosedFailure where + expression : Core.Expression.Expr + isRefuted : Bool + report : DiagnosisReport + deriving Inhabited + +/-- Full diagnosis result -/ +structure DiagnosisResult where + diagnosedFailures : List DiagnosedFailure + statePathCondition : List Core.Expression.Expr := [] + deriving Inhabited + +end Strata.Core diff --git a/Strata/Languages/Core/Env.lean b/Strata/Languages/Core/Env.lean index ef10b5ae7..e4ec550fa 100644 --- a/Strata/Languages/Core/Env.lean +++ b/Strata/Languages/Core/Env.lean @@ -15,7 +15,7 @@ open Imperative open Strata instance : ToFormat ExpressionMetadata := - show ToFormat Unit from inferInstance + inferInstanceAs (ToFormat Strata.SourceRange) -- ToFormat instance for Expression.Expr instance : ToFormat Expression.Expr := by @@ -38,13 +38,16 @@ instance : ToFormat (Map CoreIdent (Option Lambda.LMonoTy × Expression.Expr)) w format := formatScope instance : Inhabited ExpressionMetadata := - show Inhabited Unit from inferInstance + inferInstanceAs (Inhabited Strata.SourceRange) instance : Lambda.Traceable Lambda.LExpr.EvalProvenance ExpressionMetadata where - combine _ := () + combine _ := Strata.SourceRange.none + +instance : Lambda.Traceable Lambda.LExpr.EvalProvenance CoreExprMetadata where + combine _ := Strata.SourceRange.none instance : Inhabited (Lambda.LExpr ⟨⟨ExpressionMetadata, CoreIdent⟩, LMonoTy⟩) := - show Inhabited (Lambda.LExpr ⟨⟨Unit, CoreIdent⟩, LMonoTy⟩) from inferInstance + inferInstanceAs (Inhabited (Lambda.LExpr ⟨⟨Strata.SourceRange, CoreIdent⟩, LMonoTy⟩)) --------------------------------------------------------------------- @@ -265,8 +268,8 @@ def Env.genFVar (E : Env) (xt : (Lambda.IdentT Lambda.LMonoTy Unit)) : Expression.Expr × Env := let (xid, E) := E.genVar xt.ident let xe := match xt.ty? with - | none => .fvar () xid none - | some xty => .fvar () xid (some xty) + | none => .fvar Strata.SourceRange.none xid none + | some xty => .fvar Strata.SourceRange.none xid (some xty) (xe, E) /-- @@ -293,7 +296,7 @@ def Env.insertFreeVarsInOldestScope (xs : List (Lambda.IdentT Lambda.LMonoTy Unit)) (E : Env) : Env := let (xis, xtyei) := xs.foldl (fun (acc_ids, acc_pairs) x => - (x.fst :: acc_ids, (x.snd, .fvar () x.fst x.snd) :: acc_pairs)) + (x.fst :: acc_ids, (x.snd, .fvar Strata.SourceRange.none x.fst x.snd) :: acc_pairs)) ([], []) let state' := Maps.addInOldest E.exprEnv.state xis xtyei { E with exprEnv := { E.exprEnv with state := state' }} @@ -302,10 +305,10 @@ def Env.insertFreeVarsInOldestScope open Imperative Lambda in def PathCondition.merge (cond : Expression.Expr) (pc1 pc2 : PathCondition Expression) : PathCondition Expression := let pc1' := pc1.map (fun (label, e) => (label, mkImplies cond e)) - let pc2' := pc2.map (fun (label, e) => (label, mkImplies (LExpr.ite () cond (LExpr.false ()) (LExpr.true ())) e)) + let pc2' := pc2.map (fun (label, e) => (label, mkImplies (LExpr.ite Strata.SourceRange.none cond (LExpr.false Strata.SourceRange.none) (LExpr.true Strata.SourceRange.none)) e)) pc1' ++ pc2' where mkImplies (ant con : Expression.Expr) : Expression.Expr := - LExpr.ite () ant con (LExpr.true ()) + LExpr.ite Strata.SourceRange.none ant con (LExpr.true Strata.SourceRange.none) def Env.performMerge (cond : Expression.Expr) (E1 E2 : Env) (_h1 : E1.error.isNone) (_h2 : E2.error.isNone) : Env := diff --git a/Strata/Languages/Core/Expressions.lean b/Strata/Languages/Core/Expressions.lean index 7e9b45059..b55f41dcd 100644 --- a/Strata/Languages/Core/Expressions.lean +++ b/Strata/Languages/Core/Expressions.lean @@ -10,12 +10,13 @@ import Strata.DL.Lambda.Lambda import Strata.DL.Imperative.PureExpr import Strata.Languages.Core.Identifiers import Strata.DL.Imperative.HasVars +import Strata.DDM.Util.SourceRange namespace Core open Std (ToFormat Format format) --------------------------------------------------------------------- -def ExpressionMetadata := Unit +def ExpressionMetadata := Strata.SourceRange abbrev Expression : Imperative.PureExpr := { Ident := CoreIdent, @@ -31,7 +32,7 @@ instance : Imperative.HasVarsPure Expression Expression.Expr where getVars := Lambda.LExpr.LExpr.getVars instance : Inhabited Expression.Expr where - default := .intConst () 0 + default := .intConst Strata.SourceRange.none 0 --------------------------------------------------------------------- diff --git a/Strata/Languages/Core/Factory.lean b/Strata/Languages/Core/Factory.lean index a411e578a..9386aa431 100644 --- a/Strata/Languages/Core/Factory.lean +++ b/Strata/Languages/Core/Factory.lean @@ -13,7 +13,7 @@ import Strata.DL.Lambda.IntBoolFactory --------------------------------------------------------------------- namespace Core -open Lambda LTy.Syntax LExpr.SyntaxMono +open Lambda LTy.Syntax LExpr.SyntaxMono Core.Syntax @[match_pattern] def mapTy (keyTy : LMonoTy) (valTy : LMonoTy) : LMonoTy := @@ -38,6 +38,8 @@ def KnownTypes : KnownTypes := def TImplicit {Metadata: Type} (IDMeta: Type): LExprParamsT := ({Metadata := Metadata, IDMeta}: LExprParams).mono + + /-- Kind of bitvector evaluator, used to generate both the combinator name and the concrete-evaluator syntax for each BV operation. -/ private inductive BVEvalKind @@ -210,7 +212,7 @@ def mapConstFunc : WFLFunc CoreLParams := [("d", mty[%v])] (mapTy mty[%k] mty[%v]) (axioms := [ - esM[∀ (%v): -- %1 d + eb[∀ (%v): -- %1 d (∀ (%k): -- %0 kk {(((~select : (Map %k %v) → %k → %v) ((~const : %v → (Map %k %v)) %1)) %0)} @@ -230,7 +232,7 @@ def mapUpdateFunc : WFLFunc CoreLParams := (mapTy mty[%k] mty[%v]) (axioms := [ -- updateSelect: forall m: Map k v, kk: k, vv: v :: m[kk := vv][kk] == vv - esM[∀(Map %k %v): + eb[∀(Map %k %v): (∀ (%k): (∀ (%v):{ (((~select : (Map %k %v) → %k → %v) @@ -238,7 +240,7 @@ def mapUpdateFunc : WFLFunc CoreLParams := (((~select : (Map %k %v) → %k → %v) ((((~update : (Map %k %v) → %k → %v → (Map %k %v)) %2) %1) %0)) %1) == %0))], -- updatePreserve: forall m: Map k v, okk: k, kk: k, vv: v :: okk != kk ==> m[kk := vv][okk] == m[okk] - esM[∀ (Map %k %v): -- %3 m + eb[∀ (Map %k %v): -- %3 m (∀ (%k): -- %2 okk (∀ (%k): -- %1 kk (∀ (%v): -- %0 vv @@ -394,7 +396,7 @@ elab "DefBVOpFuncExprs" "[" sizes:num,* "]" : command => do elabCommand (← `(def $opName : Expression.Expr := ($funcName).opExpr)) instance : Inhabited CoreLParams.Metadata where - default := () + default := Strata.SourceRange.none DefBVOpFuncExprs [1, 8, 16, 32, 64] @@ -418,7 +420,7 @@ def emptyTriggerGroupOp : Expression.Expr := emptyTriggerGroupFunc.opExpr def addTriggerOp : Expression.Expr := addTriggerFunc.opExpr instance : Inhabited (⟨ExpressionMetadata, CoreIdent⟩: LExprParams).Metadata where - default := () + default := Strata.SourceRange.none def intAddOp : Expression.Expr := (@intAddFunc CoreLParams _).opExpr def intSubOp : Expression.Expr := (@intSubFunc CoreLParams _).opExpr @@ -472,11 +474,11 @@ def mapSelectOp : Expression.Expr := mapSelectFunc.opExpr def mapUpdateOp : Expression.Expr := mapUpdateFunc.opExpr def mkTriggerGroup (ts : List Expression.Expr) : Expression.Expr := - ts.foldl (fun g t => .app () (.app () addTriggerOp t) g) emptyTriggerGroupOp + ts.foldl (fun g t => .app Strata.SourceRange.none (.app Strata.SourceRange.none addTriggerOp t) g) emptyTriggerGroupOp def mkTriggerExpr (ts : List (List Expression.Expr)) : Expression.Expr := let groups := ts.map mkTriggerGroup - groups.foldl (fun gs g => .app () (.app () addTriggerGroupOp g) gs) emptyTriggersOp + groups.foldl (fun gs g => .app Strata.SourceRange.none (.app Strata.SourceRange.none addTriggerGroupOp g) gs) emptyTriggersOp /-- Get all the built-in functions supported by Strata Core. diff --git a/Strata/Languages/Core/Identifiers.lean b/Strata/Languages/Core/Identifiers.lean index 0481d7f9b..04d2bcfa6 100644 --- a/Strata/Languages/Core/Identifiers.lean +++ b/Strata/Languages/Core/Identifiers.lean @@ -7,13 +7,14 @@ import Strata.DL.Lambda.LExprTypeEnv import Strata.DL.Lambda.Factory +import Strata.DDM.Util.SourceRange namespace Core open Std abbrev CoreIdent := Lambda.Identifier Unit -abbrev CoreExprMetadata := Unit +abbrev CoreExprMetadata := Strata.SourceRange abbrev CoreLParams: Lambda.LExprParams := {Metadata := CoreExprMetadata, IDMeta := Unit} abbrev CoreLabel := String @@ -73,19 +74,21 @@ def elabCoreIdent : Syntax → MetaM Expr instance : MkLExprParams ⟨CoreExprMetadata, Unit⟩ where elabIdent := elabCoreIdent toExpr := mkApp2 (mkConst ``Lambda.LExprParams.mk) (mkConst ``CoreExprMetadata) (mkConst ``Unit) + defaultMetadata := return mkConst ``Strata.SourceRange.none elab "eb[" e:lexprmono "]" : term => elabLExprMono (T:=⟨CoreExprMetadata, Unit⟩) e /-- -info: Lambda.LExpr.op () { name := "old", metadata := () } +info: Lambda.LExpr.op Strata.SourceRange.none { name := "old", metadata := () } none : Lambda.LExpr { Metadata := CoreExprMetadata, IDMeta := Unit }.mono -/ #guard_msgs in #check eb[~old] /-- -info: Lambda.LExpr.app () (Lambda.LExpr.op () { name := "old", metadata := () } none) - (Lambda.LExpr.fvar () { name := "a", metadata := () } +info: Lambda.LExpr.app Strata.SourceRange.none + (Lambda.LExpr.op Strata.SourceRange.none { name := "old", metadata := () } none) + (Lambda.LExpr.fvar Strata.SourceRange.none { name := "a", metadata := () } none) : Lambda.LExpr { Metadata := CoreExprMetadata, IDMeta := Unit }.mono -/ #guard_msgs in @@ -94,7 +97,7 @@ info: Lambda.LExpr.app () (Lambda.LExpr.op () { name := "old", metadata := () } open Lambda.LTy.Syntax in /-- -info: Lambda.LExpr.fvar () { name := "x", metadata := () } +info: Lambda.LExpr.fvar Strata.SourceRange.none { name := "x", metadata := () } (some (Lambda.LMonoTy.tcons "bool" [])) : Lambda.LExpr { Metadata := CoreExprMetadata, IDMeta := Unit }.mono -/ #guard_msgs in diff --git a/Strata/Languages/Core/Options.lean b/Strata/Languages/Core/Options.lean index a1ca1a103..64bab68a1 100644 --- a/Strata/Languages/Core/Options.lean +++ b/Strata/Languages/Core/Options.lean @@ -78,6 +78,9 @@ structure VerifyOptions where Off by default. CLI: `--reach-check`. -/ reachCheck : Bool + /-- Use the incremental (in-memory) CoreSMT verification engine instead of + the default batch SMT file approach. -/ + incremental : Bool def VerifyOptions.default : VerifyOptions := { verbose := .normal, @@ -92,6 +95,7 @@ def VerifyOptions.default : VerifyOptions := { solver := defaultSolver vcDirectory := .none reachCheck := false + incremental := false } instance : Inhabited VerifyOptions where diff --git a/Strata/Languages/Core/Procedure.lean b/Strata/Languages/Core/Procedure.lean index a698dfe1d..87858ef4e 100644 --- a/Strata/Languages/Core/Procedure.lean +++ b/Strata/Languages/Core/Procedure.lean @@ -19,10 +19,10 @@ open Std.Format -- Type class instances to enable deriving for structures containing Expression.Expr instance : DecidableEq ExpressionMetadata := - show DecidableEq Unit from inferInstance + inferInstanceAs (DecidableEq Strata.SourceRange) instance : Repr ExpressionMetadata := - show Repr Unit from inferInstance + inferInstanceAs (Repr Strata.SourceRange) instance : DecidableEq (⟨⟨ExpressionMetadata, CoreIdent⟩, LMonoTy⟩ : LExprParamsT).base.Metadata := show DecidableEq ExpressionMetadata from inferInstance diff --git a/Strata/Languages/Core/ProcedureEval.lean b/Strata/Languages/Core/ProcedureEval.lean index 9449710a6..471ff8826 100644 --- a/Strata/Languages/Core/ProcedureEval.lean +++ b/Strata/Languages/Core/ProcedureEval.lean @@ -32,7 +32,7 @@ def eval (E : Env) (p : Procedure) : List (Procedure × Env) := -- the context. These reflect the pre-state values of the globals. let modifies_tys := p.spec.modifies.map - (fun l => (E.exprEnv.state.findD l (none, .fvar () l none)).fst) + (fun l => (E.exprEnv.state.findD l (none, .fvar Strata.SourceRange.none l none)).fst) let modifies_typed := p.spec.modifies.zip modifies_tys let (globals_fvars, E) := E.genFVars modifies_typed let global_init_subst := List.zip modifies_typed globals_fvars @@ -70,7 +70,7 @@ def eval (E : Env) (p : Procedure) : List (Procedure × Env) := -- that hides the expression from the evaluator, allowing us -- to retain the postcondition body instead of replacing it -- with "true". - (.assert label (.true ()) + (.assert label (.true Strata.SourceRange.none) ((Imperative.MetaData.pushElem #[] (.label label) diff --git a/Strata/Languages/Core/SMTEncoder.lean b/Strata/Languages/Core/SMTEncoder.lean index b38020a3d..a33500034 100644 --- a/Strata/Languages/Core/SMTEncoder.lean +++ b/Strata/Languages/Core/SMTEncoder.lean @@ -601,13 +601,13 @@ partial def toSMTOp (E : Env) (fn : CoreIdent) (fnty : LMonoTy) (ctx : SMT.Conte | some body => -- Substitute the formals in the function body with appropriate -- `.bvar`s. Use substFvarsLifting to properly lift indices under binders. - let bvars := (List.range formals.length).map (fun i => LExpr.bvar () i) + let bvars := (List.range formals.length).map (fun i => LExpr.bvar Strata.SourceRange.none i) let body := LExpr.substFvarsLifting body (formals.zip bvars) let (term, ctx) ← toSMTTerm E bvs body ctx .ok (ctx.addIF uf term, !ctx.ifs.contains ({ uf := uf, body := term })) -- For recursive functions, generate per-constructor axioms let recAxioms ← if func.isRecursive && isNew then - Lambda.genRecursiveAxioms func ctx.typeFactory E.exprEval () + Lambda.genRecursiveAxioms func ctx.typeFactory E.exprEval Strata.SourceRange.none else .ok [] let allAxioms := func.axioms ++ recAxioms if isNew then @@ -720,42 +720,42 @@ and render them with the correct Core data structure. def smtTermToLExpr (t : Strata.SMT.Term) (constructorNames : Std.HashSet String := {}) : LExpr CoreLParams.mono := match t with - | .prim (.bool b) => .boolConst () b - | .prim (.int i) => .intConst () i - | .prim (.real d) => .realConst () d.toRat - | .prim (.bitvec b) => .bitvecConst () _ b - | .prim (.string s) => .strConst () s + | .prim (.bool b) => .boolConst Strata.SourceRange.none b + | .prim (.int i) => .intConst Strata.SourceRange.none i + | .prim (.real d) => .realConst Strata.SourceRange.none d.toRat + | .prim (.bitvec b) => .bitvecConst Strata.SourceRange.none _ b + | .prim (.string s) => .strConst Strata.SourceRange.none s | .var v => -- Zero-arg constructors arrive as plain variables from the SMT solver. -- Mark them with `.op` so the formatter can emit `Name()`. if constructorNames.contains v.id then - .op () v.id none + .op Strata.SourceRange.none v.id none else - .fvar () v.id none + .fvar Strata.SourceRange.none v.id none | .app (.core (.uf uf)) args _retTy => -- Constructor names use `.op` so the formatter can distinguish them -- from plain variables (e.g., `Nil` constructor must not be .fvar) let fnExpr : LExpr CoreLParams.mono := if constructorNames.contains uf.id then - .op () uf.id none + .op Strata.SourceRange.none uf.id none else - .fvar () uf.id none - args.foldl (fun acc arg => .app () acc (smtTermToLExpr arg constructorNames)) fnExpr + .fvar Strata.SourceRange.none uf.id none + args.foldl (fun acc arg => .app Strata.SourceRange.none acc (smtTermToLExpr arg constructorNames)) fnExpr | .app (.datatype_op _kind name) args _retTy => - let fnExpr : LExpr CoreLParams.mono := .op () name none - args.foldl (fun acc arg => .app () acc (smtTermToLExpr arg constructorNames)) fnExpr + let fnExpr : LExpr CoreLParams.mono := .op Strata.SourceRange.none name none + args.foldl (fun acc arg => .app Strata.SourceRange.none acc (smtTermToLExpr arg constructorNames)) fnExpr | .app op args _ => -- Generic fallback for other ops: render as op name applied to args let opName := op.mkName - let fnExpr : LExpr CoreLParams.mono := .op () opName none - args.foldl (fun acc arg => .app () acc (smtTermToLExpr arg constructorNames)) fnExpr - | .none _ty => .op () "none" none - | .some inner => .app () (.op () "some" none) (smtTermToLExpr inner constructorNames) + let fnExpr : LExpr CoreLParams.mono := .op Strata.SourceRange.none opName none + args.foldl (fun acc arg => .app Strata.SourceRange.none acc (smtTermToLExpr arg constructorNames)) fnExpr + | .none _ty => .op Strata.SourceRange.none "none" none + | .some inner => .app Strata.SourceRange.none (.op Strata.SourceRange.none "some" none) (smtTermToLExpr inner constructorNames) | .quant _ _ _ _ => -- Quantifiers in model values are unusual; fall back to string repr let s := match Strata.SMTDDM.termToString t with | .ok s => s | .error _ => repr t |>.pretty - .fvar () s none + .fvar Strata.SourceRange.none s none /-- Extract the set of datatype constructor names from an `SMT.Context`. diff --git a/Strata/Languages/Core/StatementEval.lean b/Strata/Languages/Core/StatementEval.lean index 3a241f219..aed107b81 100644 --- a/Strata/Languages/Core/StatementEval.lean +++ b/Strata/Languages/Core/StatementEval.lean @@ -79,7 +79,7 @@ LHS mapping: `[("x", fresh_var)]` -/ private def mkReturnSubst (proc : Procedure) (lhs : List Expression.Ident) (E : Env) : VarSubst × VarSubst × Env := - let lhs_tys := lhs.map (fun l => (E.exprEnv.state.findD l (none, .fvar () l none)).fst) + let lhs_tys := lhs.map (fun l => (E.exprEnv.state.findD l (none, .fvar Strata.SourceRange.none l none)).fst) let lhs_typed := lhs.zip lhs_tys let (lhs_fvars, E') := E.genFVars lhs_typed let return_tys := proc.header.outputs.keys.map @@ -96,7 +96,7 @@ private def mkGlobalSubst (proc : Procedure) (current_globals : VarSubst) (E : Env) : VarSubst × Env := -- Create fresh variables for modified globals let modifies_tys := proc.spec.modifies.map - (fun l => (E.exprEnv.state.findD l (none, .fvar () l none)).fst) + (fun l => (E.exprEnv.state.findD l (none, .fvar Strata.SourceRange.none l none)).fst) let modifies_typed := proc.spec.modifies.zip modifies_tys let (globals_fvars, E') := E.genFVars modifies_typed let modified_subst := List.zip modifies_typed globals_fvars @@ -145,7 +145,7 @@ private def computeTypeSubst (input_tys output_tys: List LMonoTy) Subst := let actual_tys := args.filterMap getExprType let lhs_tys := lhs.filterMap (fun l => - (E.exprEnv.state.findD l (none, .fvar () l none)).fst) + (E.exprEnv.state.findD l (none, .fvar Strata.SourceRange.none l none)).fst) let input_constraints := actual_tys.zip input_tys let output_constraints := lhs_tys.zip output_tys let constraints := input_constraints ++ output_constraints @@ -328,7 +328,7 @@ private def createUnreachableCoverObligations Imperative.ProofObligations Expression := covers.toArray.map (fun (label, md) => - (Imperative.ProofObligation.mk label .cover pathConditions (LExpr.false ()) md)) + (Imperative.ProofObligation.mk label .cover pathConditions (LExpr.false Strata.SourceRange.none) md)) /-- Create assert obligations for asserts in an unreachable (dead) branch, including @@ -344,7 +344,7 @@ private def createUnreachableAssertObligations let propType := match md.getPropertyType with | some s => if s == Imperative.MetaData.divisionByZero then .divisionByZero else .assert | _ => .assert - (Imperative.ProofObligation.mk label propType pathConditions (LExpr.true ()) md)) + (Imperative.ProofObligation.mk label propType pathConditions (LExpr.true Strata.SourceRange.none) md)) /-- Substitute free variables in an expression with their current values from the environment, @@ -469,7 +469,7 @@ def evalAuxGo (steps : Nat) (old_var_subst : SubstMap) (Ewn : EnvWithNext) (ss : let ss_f_covers := Statements.collectCovers ss_f let ss_f_asserts := Statements.collectAsserts ss_f let deadLabel := toString (f!"") - let deadPathConds := Ewn.env.pathConditions.push [(deadLabel, LExpr.false ())] + let deadPathConds := Ewn.env.pathConditions.push [(deadLabel, LExpr.false Strata.SourceRange.none)] let deferred := createUnreachableCoverObligations deadPathConds ss_f_covers let deferred := deferred ++ createUnreachableAssertObligations deadPathConds ss_f_asserts [{ Ewn with env.deferred := Ewn.env.deferred ++ deferred }] @@ -535,7 +535,7 @@ def processIteBranches (steps : Nat) (old_var_subst : SubstMap) (Ewn : EnvWithNe let label_false := toString (f!"") let path_conds_true := Ewn.env.pathConditions.push [(label_true, cond')] let path_conds_false := Ewn.env.pathConditions.push - [(label_false, (.ite () cond' (LExpr.false ()) (LExpr.true ())))] + [(label_false, (.ite Strata.SourceRange.none cond' (LExpr.false Strata.SourceRange.none) (LExpr.true Strata.SourceRange.none)))] have : 1 <= Imperative.Block.sizeOf then_ss := by unfold Imperative.Block.sizeOf; split <;> omega have : 1 <= Imperative.Block.sizeOf else_ss := by @@ -568,12 +568,12 @@ def processIteBranches (steps : Nat) (old_var_subst : SubstMap) (Ewn : EnvWithNe | _, _ => let Ewns_t := Ewns_t.map (fun (ewn : EnvWithNext) => - let s' := Imperative.Stmt.ite (LExpr.true ()) ewn.stk.top [] md + let s' := Imperative.Stmt.ite (LExpr.true Strata.SourceRange.none) ewn.stk.top [] md { ewn with env := ewn.env.popScope, stk := orig_stk.appendToTop [s']}) let Ewns_f := Ewns_f.map (fun (ewn : EnvWithNext) => - let s' := Imperative.Stmt.ite (LExpr.false ()) [] ewn.stk.top md + let s' := Imperative.Stmt.ite (LExpr.false Strata.SourceRange.none) [] ewn.stk.top md { ewn with env := ewn.env.popScope, stk := orig_stk.appendToTop [s']}) Ewns_t ++ Ewns_f diff --git a/Strata/Languages/Core/StatementSemantics.lean b/Strata/Languages/Core/StatementSemantics.lean index dd236c158..a5315d8f1 100644 --- a/Strata/Languages/Core/StatementSemantics.lean +++ b/Strata/Languages/Core/StatementSemantics.lean @@ -16,17 +16,17 @@ namespace Core /-- expressions that can't be reduced when evaluating -/ inductive Value : Core.Expression.Expr → Prop where - | const : Value (.const () _) - | bvar : Value (.bvar () _) - | op : Value (.op () _ _) - | abs : Value (.abs () _ _ _) + | const : Value (.const _ _) + | bvar : Value (.bvar _ _) + | op : Value (.op _ _ _) + | abs : Value (.abs _ _ _ _) open Imperative instance : HasVal Core.Expression where value := Value instance : HasFvar Core.Expression where - mkFvar := (.fvar () · none) + mkFvar := (.fvar Strata.SourceRange.none · none) getFvar | .fvar _ v _ => some v | _ => none @@ -35,9 +35,9 @@ instance : HasSubstFvar Core.Expression where substFvar := Lambda.LExpr.substFvar @[match_pattern] -def Core.true : Core.Expression.Expr := .boolConst () Bool.true +def Core.true : Core.Expression.Expr := .boolConst Strata.SourceRange.none Bool.true @[match_pattern] -def Core.false : Core.Expression.Expr := .boolConst () Bool.false +def Core.false : Core.Expression.Expr := .boolConst Strata.SourceRange.none Bool.false instance : HasBool Core.Expression where tt := Core.true @@ -47,7 +47,7 @@ instance : HasNot Core.Expression where not | Core.true => Core.false | Core.false => Core.true - | e => Lambda.LExpr.app () (Lambda.boolNotFunc (T:=CoreLParams)).opExpr e + | e => Lambda.LExpr.app Strata.SourceRange.none (Lambda.boolNotFunc (T:=CoreLParams)).opExpr e abbrev CoreEval := SemanticEval Expression abbrev CoreStore := SemanticStore Expression @@ -185,10 +185,10 @@ def WellFormedCoreEvalTwoState (δ : CoreEval) (σ₀ σ : CoreStore) : Prop := ∀ v, -- "old g" in the post-state holds the pre-state value of g (v ∈ vs → - δ σ (.fvar () (CoreIdent.mkOld v.name) none) = σ₀ v) ∧ + δ σ (.fvar Strata.SourceRange.none (CoreIdent.mkOld v.name) none) = σ₀ v) ∧ -- if the variable is not modified, "old g" is the same as g (¬ v ∈ vs → - δ σ (.fvar () (CoreIdent.mkOld v.name) none) = σ v)) + δ σ (.fvar Strata.SourceRange.none (CoreIdent.mkOld v.name) none) = σ v)) /-! ### Closure Capture for Function Declarations -/ diff --git a/Strata/Languages/Core/Verifier.lean b/Strata/Languages/Core/Verifier.lean index d7ca523d6..79757bb48 100644 --- a/Strata/Languages/Core/Verifier.lean +++ b/Strata/Languages/Core/Verifier.lean @@ -9,6 +9,7 @@ import Strata.Languages.Core.DDMTransform.ASTtoCST import Strata.Languages.Core.Options import Strata.Languages.Core.CallGraph import Strata.Languages.Core.SMTEncoder +import Strata.Languages.Core.DiagnosisTypes import Strata.DL.Imperative.MetaData import Strata.DL.Imperative.SMTUtils import Strata.DDM.AST @@ -151,6 +152,13 @@ instance : ToFormat Outcome where | .unknown => "🟡 unknown" | .implementationError e => s!"🚨 Implementation Error! {e}" +/-- Diagnosis information for verification failures -/ +structure DiagnosisInfo where + isRefuted : Bool := false + diagnosedFailures : List Core.DiagnosedFailure := [] + statePathCondition : List Core.Expression.Expr := [] + deriving Inhabited + /-- A model expressed as Core `LExpr` values, suitable for display using Core's expression formatter and for future use as program metadata. @@ -168,11 +176,31 @@ structure VCResult where result : Outcome := .unknown estate : EncoderState := EncoderState.init verbose : VerboseMode := .normal + diagnosis : Option DiagnosisInfo := .none /-- model with values converted from `SMT.Term` to Core `LExpr`. The contents must be consistent with smtObligationResult, if smtObligationResult was .sat. -/ lexprModel : LExprModel := [] +/-- Simplified verification report for display and API use -/ +structure VerificationReport where + label : String + outcome : Outcome + diagnosis : Option DiagnosisInfo := none + obligation : Option (Imperative.ProofObligation Expression) := none + +/-- Procedure-level verification report grouping multiple checks -/ +structure ProcedureReport where + procedureName : String + results : List VerificationReport + +/-- Convert VCResult to VerificationReport -/ +def vcResultToVerificationReport (vcResult : VCResult) : VerificationReport := + { label := vcResult.obligation.label + outcome := vcResult.result + diagnosis := vcResult.diagnosis + obligation := some vcResult.obligation } + /-- Map the result from an SMT backend engine to an `Outcome`. -/ diff --git a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean index 2756dad67..a771af57b 100644 --- a/Strata/Languages/Laurel/LaurelToCoreTranslator.lean +++ b/Strata/Languages/Laurel/LaurelToCoreTranslator.lean @@ -114,7 +114,7 @@ def translateExpr (expr : StmtExprMd) let s ← get let model := s.model -- Dummy expression used as placeholder when an error is emitted in pure context - let dummy := .fvar () (⟨s!"DUMMY_VAR_{← freshId}", ()⟩) none + let dummy := .fvar Strata.SourceRange.none (⟨s!"DUMMY_VAR_{← freshId}", ()⟩) none -- Emit an error in pure context; panic in impure context (lifting invariant violated) let disallowed (md : MetaData) (msg : String) : TranslateM Core.Expression.Expr := do if isPureContext then @@ -122,39 +122,40 @@ def translateExpr (expr : StmtExprMd) return dummy else panic! s!"translateExpr: {msg} (should have been lifted): {Std.Format.pretty (Std.ToFormat.format md)}" + let sr := (Imperative.getFileRange expr.md).map (·.range) |>.getD Strata.SourceRange.none match h: expr.val with - | .LiteralBool b => return .const () (.boolConst b) - | .LiteralInt i => return .const () (.intConst i) - | .LiteralString s => return .const () (.strConst s) + | .LiteralBool b => return .const sr (.boolConst b) + | .LiteralInt i => return .const sr (.intConst i) + | .LiteralString s => return .const sr (.strConst s) | .Identifier name => -- First check if this name is bound by an enclosing quantifier match boundVars.findIdx? (· == name) with | some idx => -- Bound variable: use de Bruijn index - return .bvar () idx + return .bvar Strata.SourceRange.none idx | none => match model.get name with | .field _ f => - return .op () ⟨f.name.text, ()⟩ none + return .op Strata.SourceRange.none ⟨f.name.text, ()⟩ none | astNode => - return .fvar () ⟨name.text, ()⟩ (some (translateType model $ astNode.getType.getD (panic! "LaurelToCore.translateExpr"))) + return .fvar Strata.SourceRange.none ⟨name.text, ()⟩ (some (translateType model $ astNode.getType.getD (panic! "LaurelToCore.translateExpr"))) | .PrimitiveOp op [e] => match op with | .Not => let re ← translateExpr e boundVars isPureContext - return .app () boolNotOp re + return .app Strata.SourceRange.none boolNotOp re | .Neg => let re ← translateExpr e boundVars isPureContext - return .app () intNegOp re + return .app Strata.SourceRange.none intNegOp re | _ => panic! s!"translateExpr: Invalid unary op: {repr op}" | .PrimitiveOp op [e1, e2] => let re1 ← translateExpr e1 boundVars isPureContext let re2 ← translateExpr e2 boundVars isPureContext let binOp (bop : Core.Expression.Expr) : Core.Expression.Expr := - LExpr.mkApp () bop [re1, re2] + LExpr.mkApp Strata.SourceRange.none bop [re1, re2] match op with - | .Eq => return .eq () re1 re2 - | .Neq => return .app () boolNotOp (.eq () re1 re2) + | .Eq => return .eq Strata.SourceRange.none re1 re2 + | .Neq => return .app Strata.SourceRange.none boolNotOp (.eq Strata.SourceRange.none re1 re2) | .And => return binOp boolAndOp | .Or => return binOp boolOrOp | .Implies => return binOp boolImpliesOp @@ -183,30 +184,30 @@ def translateExpr (expr : StmtExprMd) have := WithMetadata.sizeOf_val_lt expr cases expr; simp_all; omega translateExpr e boundVars isPureContext - return .ite () bcond bthen belse + return .ite Strata.SourceRange.none bcond bthen belse | .StaticCall callee args => -- In a pure context, only Core functions (not procedures) are allowed if isPureContext && !model.isFunction callee then disallowed expr.md "calls to procedures are not supported in functions or contracts" else - let fnOp : Core.Expression.Expr := .op () ⟨callee.text, ()⟩ none + let fnOp : Core.Expression.Expr := .op Strata.SourceRange.none ⟨callee.text, ()⟩ none args.attach.foldlM (fun acc ⟨arg, _⟩ => do let re ← translateExpr arg boundVars isPureContext - return .app () acc re) fnOp + return .app Strata.SourceRange.none acc re) fnOp | .Block [single] _ => translateExpr single boundVars isPureContext | .Forall ⟨ name, ty ⟩ body => let coreTy := translateType model ty let coreBody ← translateExpr body (name :: boundVars) isPureContext - return LExpr.all () name.text (some coreTy) coreBody + return LExpr.all Strata.SourceRange.none name.text (some coreTy) coreBody | .Exists ⟨ name, ty ⟩ body => let coreTy := translateType model ty let coreBody ← translateExpr body (name :: boundVars) isPureContext - return LExpr.exist () name.text (some coreTy) coreBody + return LExpr.exist Strata.SourceRange.none name.text (some coreTy) coreBody | .Hole => return dummy | .ReferenceEquals e1 e2 => let re1 ← translateExpr e1 boundVars isPureContext let re2 ← translateExpr e2 boundVars isPureContext - return .eq () re1 re2 + return .eq Strata.SourceRange.none re1 re2 | .Assign _ _ => disallowed expr.md "destructive assignments are not supported in functions or contracts" | .While _ _ _ _ => @@ -264,15 +265,15 @@ def getNameFromMd (md : Imperative.MetaData Core.Expression): String := def defaultExprForType (model : SemanticModel) (ty : HighTypeMd) : Core.Expression.Expr := match ty.val with - | .TInt => .const () (.intConst 0) - | .TBool => .const () (.boolConst false) - | .TString => .const () (.strConst "") + | .TInt => .const Strata.SourceRange.none (.intConst 0) + | .TBool => .const Strata.SourceRange.none (.boolConst false) + | .TString => .const Strata.SourceRange.none (.strConst "") | _ => -- For types without a natural default (arrays, composites, etc.), -- use a fresh free variable. This is only used when the value is -- immediately overwritten by a procedure call. let coreTy := translateType model ty - .fvar () (⟨"$default", ()⟩) (some coreTy) + .fvar Strata.SourceRange.none (⟨"$default", ()⟩) (some coreTy) /-- Translate Laurel StmtExpr to Core Statements using the `TranslateM` monad. @@ -435,7 +436,7 @@ def translateProcedure (proc : Procedure) : TranslateM Core.Procedure := do match proc.body with | .Transparent bodyExpr => translateStmt proc.outputs bodyExpr | .Opaque _postconds (some impl) _ => translateStmt proc.outputs impl - | _ => pure [Core.Statement.assume "no_body" (.const () (.boolConst false)) .empty] + | _ => pure [Core.Statement.assume "no_body" (.const Strata.SourceRange.none (.boolConst false)) .empty] -- Wrap body in a labeled block so early returns (exit) work correctly. let body : List Core.Statement := [.block "$body" bodyStmts .empty] let spec : Core.Procedure.Spec := { modifies, preconditions, postconditions } @@ -454,7 +455,7 @@ def translateProcedureToFunction (proc : Procedure) : TranslateM Core.Decl := do -- Translate precondition to FuncPrecondition (skip trivial `true`) let preconditions ← proc.preconditions.mapM (fun precondition => do let checkExpr ← translateExpr precondition [] true - return { expr := checkExpr, md := () }) + return { expr := checkExpr, md := Strata.SourceRange.none }) let body ← match proc.body with | .Transparent bodyExpr => some <$> translateExpr bodyExpr [] (isPureContext := true) diff --git a/Strata/Languages/Python/FunctionSignatures.lean b/Strata/Languages/Python/FunctionSignatures.lean index e9e57cd72..3bb5e5dad 100644 --- a/Strata/Languages/Python/FunctionSignatures.lean +++ b/Strata/Languages/Python/FunctionSignatures.lean @@ -148,13 +148,13 @@ def TypeStrToCoreExpr (ty: String) : Core.Expression.Expr := panic! s!"Should only be called for possibly None types. Called for: {ty}" else match ty with - | "StrOrNone" => .app () (.op () "StrOrNone_mk_none" none) (.op () "None_none" none) - | "BoolOrNone" => .app () (.op () "BoolOrNone_mk_none" none) (.op () "None_none" none) - | "BoolOrStrOrNone" => .app () (.op () "BoolOrStrOrNone_mk_none" none) (.op () "None_none" none) - | "AnyOrNone" => .app () (.op () "AnyOrNone_mk_none" none) (.op () "None_none" none) - | "IntOrNone" => .app () (.op () "IntOrNone_mk_none" none) (.op () "None_none" none) - | "BytesOrStrOrNone" => .app () (.op () "BytesOrStrOrNone_mk_none" none) (.op () "None_none" none) - | "DictStrStrOrNone" => .app () (.op () "DictStrStrOrNone_mk_none" none) (.op () "None_none" none) + | "StrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "StrOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "BoolOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "BoolOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "BoolOrStrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "BoolOrStrOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "AnyOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "AnyOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "IntOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "IntOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "BytesOrStrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "BytesOrStrOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) + | "DictStrStrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "DictStrStrOrNone_mk_none" none) (.op Strata.SourceRange.none "None_none" none) | _ => panic! s!"unsupported type: {ty}" end Python diff --git a/Strata/Languages/Python/PyFactory.lean b/Strata/Languages/Python/PyFactory.lean index 9a620ff80..e49c8dbd9 100644 --- a/Strata/Languages/Python/PyFactory.lean +++ b/Strata/Languages/Python/PyFactory.lean @@ -72,7 +72,7 @@ def reCompileFunc : LFunc Core.CoreLParams := output := mty[ExceptErrorRegex], concreteEval := some (fun _ args => match args with - | [LExpr.strConst () s, LExpr.intConst () 0] => + | [LExpr.strConst _ s, LExpr.intConst _ 0] => -- This function has a concrete evaluation implementation only when -- flags == 0. -- (FIXME): We use `.match` mode below because we support only @@ -84,13 +84,13 @@ def reCompileFunc : LFunc Core.CoreLParams := -- Note: Do not use `eb` (in Strata Core Syntax) here (e.g., see below) -- eb[(~ExceptErrorRegex_mkOK expr)] -- that captures `expr` as an `.fvar`. - .some (LExpr.mkApp () (.op () "ExceptErrorRegex_mkOK" none) [expr]) + .some (LExpr.mkApp Strata.SourceRange.none (.op Strata.SourceRange.none "ExceptErrorRegex_mkOK" none) [expr]) | some (ParseError.unimplemented msg _pattern _pos) => - .some (LExpr.mkApp () (.op () "ExceptErrorRegex_mkErr" none) - [LExpr.mkApp () (.op () "Error_Unimplemented" none) [.strConst () (toString msg)]]) + .some (LExpr.mkApp Strata.SourceRange.none (.op Strata.SourceRange.none "ExceptErrorRegex_mkErr" none) + [LExpr.mkApp Strata.SourceRange.none (.op Strata.SourceRange.none "Error_Unimplemented" none) [.strConst Strata.SourceRange.none (toString msg)]]) | some (ParseError.patternError msg _pattern _pos) => - .some (LExpr.mkApp () (.op () "ExceptErrorRegex_mkErr" none) - [LExpr.mkApp () (.op () "Error_RePatternErr" none) [.strConst () (toString msg)]]) + .some (LExpr.mkApp Strata.SourceRange.none (.op Strata.SourceRange.none "ExceptErrorRegex_mkErr" none) + [LExpr.mkApp Strata.SourceRange.none (.op Strata.SourceRange.none "Error_RePatternErr" none) [.strConst Strata.SourceRange.none (toString msg)]]) | _ => .none) } diff --git a/Strata/Languages/Python/PythonToCore.lean b/Strata/Languages/Python/PythonToCore.lean index b96065b40..1f718bfd1 100644 --- a/Strata/Languages/Python/PythonToCore.lean +++ b/Strata/Languages/Python/PythonToCore.lean @@ -21,25 +21,25 @@ open Lambda.LTy.Syntax -- Some hard-coded things we'll need to fix later: def clientType : Core.Expression.Ty := .forAll [] (.tcons "Client" []) -def dummyClient : Core.Expression.Expr := .fvar () "DUMMY_CLIENT" none +def dummyClient : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_CLIENT" none def dictStrAnyType : Core.Expression.Ty := .forAll [] (.tcons "DictStrAny" []) -def dummyDictStrAny : Core.Expression.Expr := .fvar () "DUMMY_DICT_STR_ANY" none +def dummyDictStrAny : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_DICT_STR_ANY" none def strType : Core.Expression.Ty := .forAll [] (.tcons "string" []) -def dummyStr : Core.Expression.Expr := .fvar () "DUMMY_STR" none +def dummyStr : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_STR" none def listStrType : Core.Expression.Ty := .forAll [] (.tcons "ListStr" []) -def dummyListStr : Core.Expression.Expr := .fvar () "DUMMY_LIST_STR" none +def dummyListStr : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_LIST_STR" none def datetimeType : Core.Expression.Ty := .forAll [] (.tcons "Datetime" []) -def dummyDatetime : Core.Expression.Expr := .fvar () "DUMMY_DATETIME" none +def dummyDatetime : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_DATETIME" none def dateType : Core.Expression.Ty := .forAll [] (.tcons "Date" []) -def dummyDate : Core.Expression.Expr := .fvar () "DUMMY_DATE" none +def dummyDate : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_DATE" none def timedeltaType : Core.Expression.Ty := .forAll [] (.tcons "int" []) -def dummyTimedelta : Core.Expression.Expr := .fvar () "DUMMY_Timedelta" none +def dummyTimedelta : Core.Expression.Expr := .fvar Strata.SourceRange.none "DUMMY_Timedelta" none ------------------------------------------------------------------------------- @@ -114,10 +114,10 @@ def unwrapModule (c : Python.Command SourceRange) : Array (Python.stmt SourceRan | _ => panic! "Expected module" def strToCoreExpr (s: String) : Core.Expression.Expr := - .strConst () s + .strConst Strata.SourceRange.none s def intToCoreExpr (i: Int) : Core.Expression.Expr := - .intConst () i + .intConst Strata.SourceRange.none i def PyIntToInt (i : Python.int SourceRange) : Int := match i with @@ -126,102 +126,102 @@ def PyIntToInt (i : Python.int SourceRange) : Int := def PyConstToCore (c: Python.constant SourceRange) : Core.Expression.Expr := match c with - | .ConString _ s => .strConst () s.val - | .ConPos _ i => .intConst () i.val - | .ConNeg _ i => .intConst () (-i.val) - | .ConBytes _ _b => .const () (.strConst "") -- TODO: fix - | .ConFloat _ f => .strConst () (f.val) + | .ConString _ s => .strConst Strata.SourceRange.none s.val + | .ConPos _ i => .intConst Strata.SourceRange.none i.val + | .ConNeg _ i => .intConst Strata.SourceRange.none (-i.val) + | .ConBytes _ _b => .const Strata.SourceRange.none (.strConst "") -- TODO: fix + | .ConFloat _ f => .strConst Strata.SourceRange.none (f.val) | _ => panic! s!"Unhandled Constant: {repr c}" def PyAliasToCoreExpr (a : Python.alias SourceRange) : Core.Expression.Expr := match a with | .mk_alias _ n as_n => assert! as_n.val.isNone - .strConst () n.val + .strConst Strata.SourceRange.none n.val def handleAdd (translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := match lhs, rhs with - | .intConst () l, .intConst () r => .intConst () (l + r) - | .fvar () l _, .fvar () r _ => + | .intConst _ l, .intConst _ r => .intConst Strata.SourceRange.none (l + r) + | .fvar _ l _, .fvar _ r _ => let l_ty := translation_ctx.variableTypes.find? (λ p => p.fst == l.name) let r_ty := translation_ctx.variableTypes.find? (λ p => p.fst == r.name) match l_ty, r_ty with | some (_, .tcons "int" []), some (_, .tcons "int" []) => - .app () (.app () (.op () "Int.Add" mty[int → (int → int)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Add" mty[int → (int → int)]) lhs) rhs | some (_, .tcons "string" []), some (_, .tcons "string" []) => - .app () (.app () (.op () "Str.Concat" mty[string → (string → string)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Str.Concat" mty[string → (string → string)]) lhs) rhs | _, _ => panic! s!"Unsupported types for +. Exprs: {lhs} and {rhs}" - | _, _ => .app () (.app () (.op () "Str.Concat" mty[string → (string → string)]) lhs) rhs + | _, _ => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Str.Concat" mty[string → (string → string)]) lhs) rhs def handleSub (translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := match lhs, rhs with - | .intConst () l, .intConst () r => .intConst () (l - r) - | .fvar () l _, .fvar () r _ => + | .intConst _ l, .intConst _ r => .intConst Strata.SourceRange.none (l - r) + | .fvar _ l _, .fvar _ r _ => let l_ty := translation_ctx.variableTypes.find? (λ p => p.fst == l.name) let r_ty := translation_ctx.variableTypes.find? (λ p => p.fst == r.name) match l_ty, r_ty with | some (_, .tcons "int" []), some (_, .tcons "int" []) => - .app () (.app () (.op () "Int.Sub" mty[int → (int → int)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Sub" mty[int → (int → int)]) lhs) rhs | some (_, .tcons "Datetime" []), some (_, .tcons "int" []) => - .app () (.app () (.op () "Datetime_sub" none) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Datetime_sub" none) lhs) rhs | some (_, .tcons "Datetime" []), some (_, .tcons "Timedelta" []) => - .app () (.app () (.op () "Datetime_sub" none) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Datetime_sub" none) lhs) rhs | _, _ => panic! s!"Unsupported types for -. Exprs: {lhs} and {rhs}" | _, _ => panic! s!"Unsupported args for -. Got: {lhs} and {rhs}" def handleMult (translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := match lhs, rhs with - | .strConst () s, .intConst () i => .strConst () (String.join (List.replicate i.toNat s)) - | .intConst () l, .intConst () r => .intConst () (l * r) - | .fvar () l _, .fvar () r _ => + | .strConst _ s, .intConst _ i => .strConst Strata.SourceRange.none (String.join (List.replicate i.toNat s)) + | .intConst _ l, .intConst _ r => .intConst Strata.SourceRange.none (l * r) + | .fvar _ l _, .fvar _ r _ => let l := translation_ctx.variableTypes.find? (λ p => p.fst == l.name) let r := translation_ctx.variableTypes.find? (λ p => p.fst == r.name) match l, r with | .some lty, .some rty => match lty.snd, rty.snd with - | .tcons "int" [], .tcons "int" [] => .app () (.app () (.op () "Int.Mul" mty[int → (int → int)]) lhs) rhs + | .tcons "int" [], .tcons "int" [] => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Mul" mty[int → (int → int)]) lhs) rhs | _, _ => panic! s!"Unsupported types for fvar *. Types: {lty} and {rty}" | _, _ => panic! s!"Missing needed type information for *. Exprs: {lhs} and {rhs}" | _ , _ => panic! s!"Unsupported args for * . Got: {lhs} and {rhs}" def handleFloorDiv (_translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := - .app () (.app () (.op () "Int.Div" mty[int → (int → int)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Div" mty[int → (int → int)]) lhs) rhs def handleNot (arg: Core.Expression.Expr) : Core.Expression.Expr := let ty : Lambda.LMonoTy := (.tcons "ListStr" []) match ty with - | (.tcons "ListStr" []) => .eq () arg (.op () "ListStr_nil" none) + | (.tcons "ListStr" []) => .eq Strata.SourceRange.none arg (.op Strata.SourceRange.none "ListStr_nil" none) | _ => panic! s!"Unimplemented not op for {arg}" def handleLt (translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := match lhs, rhs with - | .fvar () l _, .fvar () r _ => + | .fvar _ l _, .fvar _ r _ => let l_ty := translation_ctx.variableTypes.find? (λ p => p.fst == l.name) let r_ty := translation_ctx.variableTypes.find? (λ p => p.fst == r.name) match l_ty, r_ty with | some (_, .tcons "Datetime" []), some (_, .tcons "Datetime" []) => - .app () (.app () (.op () "Datetime_lt" none) lhs) rhs - | _, _ => .app () (.app () (.op () "Int.Lt" mty[int → (int → bool)]) lhs) rhs - | _, _ => .app () (.app () (.op () "Int.Lt" mty[int → (int → bool)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Datetime_lt" none) lhs) rhs + | _, _ => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Lt" mty[int → (int → bool)]) lhs) rhs + | _, _ => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Lt" mty[int → (int → bool)]) lhs) rhs def handleLtE (translation_ctx: TranslationContext) (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := match lhs, rhs with - | .fvar () l _, .fvar () r _ => + | .fvar _ l _, .fvar _ r _ => let l_ty := translation_ctx.variableTypes.find? (λ p => p.fst == l.name) let r_ty := translation_ctx.variableTypes.find? (λ p => p.fst == r.name) match l_ty, r_ty with | some (_, .tcons "Datetime" []), some (_, .tcons "Datetime" []) => - let eq := (.eq () lhs rhs) - let lt := (.app () (.app () (.op () "Datetime_lt" none) lhs) rhs) - (.app () (.app () (.op () "Bool.Or" none) eq) lt) - | _, _ => .app () (.app () (.op () "Int.Le" mty[int → (int → bool)]) lhs) rhs - | _, _ => .app () (.app () (.op () "Int.Le" mty[int → (int → bool)]) lhs) rhs + let eq := (.eq Strata.SourceRange.none lhs rhs) + let lt := (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Datetime_lt" none) lhs) rhs) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Or" none) eq) lt) + | _, _ => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Le" mty[int → (int → bool)]) lhs) rhs + | _, _ => .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Le" mty[int → (int → bool)]) lhs) rhs def handleGt (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := - .app () (.app () (.op () "Int.Gt" mty[int → (int → bool)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Gt" mty[int → (int → bool)]) lhs) rhs def handleGtE (lhs rhs: Core.Expression.Expr) : Core.Expression.Expr := - .app () (.app () (.op () "Int.Ge" mty[int → (int → bool)]) lhs) rhs + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Ge" mty[int → (int → bool)]) lhs) rhs structure SubstitutionRecord where pyExpr : Python.expr SourceRange @@ -239,13 +239,13 @@ def PyExprIdent (e1 e2: Python.expr SourceRange) : Bool := -- TODO: handle rest of names def PyListStrToCore (names : Array (Python.alias SourceRange)) : Core.Expression.Expr := - .app () (.app () (.op () "ListStr_cons" mty[string → (ListStr → ListStr)]) (PyAliasToCoreExpr names[0]!)) - (.op () "ListStr_nil" mty[ListStr]) + .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "ListStr_cons" mty[string → (ListStr → ListStr)]) (PyAliasToCoreExpr names[0]!)) + (.op Strata.SourceRange.none "ListStr_nil" mty[ListStr]) def handleList (_elmts: Array (Python.expr SourceRange)) (expected_type : Lambda.LMonoTy): PyExprTranslated := match expected_type with - | (.tcons "ListStr" _) => {stmts := [], expr := (.op () "ListStr_nil" expected_type)} - | (.tcons "ListDictStrAny" _) => {stmts := [], expr := (.op () "ListDictStrAny_nil" expected_type)} + | (.tcons "ListStr" _) => {stmts := [], expr := (.op Strata.SourceRange.none "ListStr_nil" expected_type)} + | (.tcons "ListDictStrAny" _) => {stmts := [], expr := (.op Strata.SourceRange.none "ListDictStrAny_nil" expected_type)} | _ => panic! s!"Unexpected type : {expected_type}" def PyOptExprToString (e : Python.opt_expr SourceRange) : String := @@ -315,15 +315,15 @@ def noneOrExpr (translation_ctx : TranslationContext) (fname n : String) (e: Cor if type_str.endsWith "OrNone" then -- Optional param. Need to wrap e.g., string into StrOrNone match type_str with - | "IntOrNone" => .app () (.op () "IntOrNone_mk_int" none) e - | "StrOrNone" => .app () (.op () "StrOrNone_mk_str" none) e - | "BytesOrStrOrNone" => .app () (.op () "BytesOrStrOrNone_mk_str" none) e + | "IntOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "IntOrNone_mk_int" none) e + | "StrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "StrOrNone_mk_str" none) e + | "BytesOrStrOrNone" => .app Strata.SourceRange.none (.op Strata.SourceRange.none "BytesOrStrOrNone_mk_str" none) e | _ => panic! "Unsupported type_str: "++ type_str else e def handleCallThrow (jmp_target : String) : Core.Statement := - let cond := .app () (.op () "ExceptOrNone..isExceptOrNone_mk_code" none) (.fvar () "maybe_except" none) + let cond := .app Strata.SourceRange.none (.op Strata.SourceRange.none "ExceptOrNone..isExceptOrNone_mk_code" none) (.fvar Strata.SourceRange.none "maybe_except" none) .ite cond [.exit (some jmp_target) .empty] [] .empty def deduplicateTypeAnnotations (l : List (String × Option String)) : List (String × String) := Id.run do @@ -363,11 +363,11 @@ partial def collectVarDecls (translation_ctx : TranslationContext) (stmts: Array let name := p.fst let ty_name := p.snd match ty_name with - | "bool" => [(.init name t[bool] (some (.boolConst () false)) .empty), (.havoc name .empty)] - | "str" => [(.init name t[string] (some (.strConst () "")) .empty), (.havoc name .empty)] - | "int" => [(.init name t[int] (some (.intConst () 0)) .empty), (.havoc name .empty)] - | "float" => [(.init name t[string] (some (.strConst () "0.0")) .empty), (.havoc name .empty)] -- Floats as strs for now - | "bytes" => [(.init name t[string] (some (.strConst () "")) .empty), (.havoc name .empty)] + | "bool" => [(.init name t[bool] (some (.boolConst Strata.SourceRange.none false)) .empty), (.havoc name .empty)] + | "str" => [(.init name t[string] (some (.strConst Strata.SourceRange.none "")) .empty), (.havoc name .empty)] + | "int" => [(.init name t[int] (some (.intConst Strata.SourceRange.none 0)) .empty), (.havoc name .empty)] + | "float" => [(.init name t[string] (some (.strConst Strata.SourceRange.none "0.0")) .empty), (.havoc name .empty)] -- Floats as strs for now + | "bytes" => [(.init name t[string] (some (.strConst Strata.SourceRange.none "")) .empty), (.havoc name .empty)] | "Client" => [(.init name clientType (some dummyClient) .empty), (.havoc name .empty)] | "Dict[str Any]" => [(.init name dictStrAnyType (some dummyDictStrAny) .empty), (.havoc name .empty)] | "List[str]" => [(.init name listStrType (some dummyListStr) .empty), (.havoc name .empty)] @@ -379,7 +379,7 @@ partial def collectVarDecls (translation_ctx : TranslationContext) (stmts: Array match user_defined_class with | .some i => let user_defined_class_ty := .forAll [] (.tcons i.name []) - let user_defined_class_dummy := .fvar () ("DUMMY_" ++ i.name) none + let user_defined_class_dummy := .fvar Strata.SourceRange.none ("DUMMY_" ++ i.name) none [(.init name user_defined_class_ty (some user_defined_class_dummy) .empty), (.havoc name .empty)] | .none => panic! s!"Unsupported type annotation: `{ty_name}`" let foo := dedup.map toCore @@ -477,24 +477,24 @@ partial def argsAndKWordsToCanonicalList (translation_ctx : TranslationContext) partial def handleDict (translation_ctx: TranslationContext) (sr : SourceRange) (keys: Array (Python.opt_expr SourceRange)) (values: Array (Python.expr SourceRange)) : PyExprTranslated := let md := sourceRangeToMetaData translation_ctx.filePath sr - let dict := .app () (.op () "DictStrAny_mk" none) (.strConst () "DefaultDict") -- TODO: need to generate unique dict arg + let dict := .app Strata.SourceRange.none (.op Strata.SourceRange.none "DictStrAny_mk" none) (.strConst Strata.SourceRange.none "DefaultDict") -- TODO: need to generate unique dict arg assert! keys.size == values.size let zipped := Array.zip keys values let res := zipped.toList.flatMap (λ (k, v) => let n := PyOptExprToString k - let in_dict := (.assume s!"assume_{n}_in_dict" (.app () (.app () (.op () "str_in_dict_str_any" none) (.strConst () n)) dict) md) + let in_dict := (.assume s!"assume_{n}_in_dict" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) (.strConst Strata.SourceRange.none n)) dict) md) match v with | .Call _ f args _ => match f with | .Name _ {ann := _ , val := "str"} _ => assert! args.val.size == 1 - let dt := (.app () (.op () "datetime_to_str" none) ((PyExprToCore default args.val[0]!).expr)) - let dict_of_v_is_k := (.assume s!"assume_{n}_key" (.eq () (.app () (.app () (.op () "dict_str_any_get_str" none) dict) (.strConst () n)) dt) md) + let dt := (.app Strata.SourceRange.none (.op Strata.SourceRange.none "datetime_to_str" none) ((PyExprToCore default args.val[0]!).expr)) + let dict_of_v_is_k := (.assume s!"assume_{n}_key" (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_get_str" none) dict) (.strConst Strata.SourceRange.none n)) dt) md) [in_dict, dict_of_v_is_k] | _ => panic! "Unsupported function when constructing map" | _ => - let dict_of_v_is_k := (.assume s!"assume_{n}_key" (.eq () (.app () (.app () (.op () "dict_str_any_get_str" none) dict) (.strConst () n)) (.strConst () "DummyVal")) md) + let dict_of_v_is_k := (.assume s!"assume_{n}_key" (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_get_str" none) dict) (.strConst Strata.SourceRange.none n)) (.strConst Strata.SourceRange.none "DummyVal")) md) [in_dict, dict_of_v_is_k]) {stmts := res , expr := dict, post_stmts := []} @@ -511,17 +511,17 @@ partial def PyExprToCore (translation_ctx : TranslationContext) (e : Python.expr | .Constant _ c _ => {stmts := [], expr := PyConstToCore c} | .Name _ n _ => match n.val with - | "AssertionError" | "Exception" => {stmts := [], expr := .strConst () n.val} + | "AssertionError" | "Exception" => {stmts := [], expr := .strConst Strata.SourceRange.none n.val} | s => match translation_ctx.variableTypes.find? (λ p => p.fst == s) with | .some p => if translation_ctx.expectedType == some (.tcons "bool" []) && p.snd == (.tcons "DictStrAny" []) then - let a := .fvar () n.val none - let e := .app () (.op () "Bool.Not" none) (.eq () (.app () (.op () "dict_str_any_length" none) a) (.intConst () 0)) + let a := .fvar Strata.SourceRange.none n.val none + let e := .app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_length" none) a) (.intConst Strata.SourceRange.none 0)) {stmts := [], expr := e} else - {stmts := [], expr := .fvar () n.val none} - | .none => {stmts := [], expr := .fvar () n.val none} + {stmts := [], expr := .fvar Strata.SourceRange.none n.val none} + | .none => {stmts := [], expr := .fvar Strata.SourceRange.none n.val none} | .JoinedStr _ ss => PyExprToCore translation_ctx ss.val[0]! -- TODO: need to actually join strings | .BinOp _ lhs op rhs => let lhs := (PyExprToCore translation_ctx lhs) @@ -543,9 +543,9 @@ partial def PyExprToCore (translation_ctx : TranslationContext) (e : Python.expr match op.val with | #[v] => match v with | Strata.Python.cmpop.Eq _ => - {stmts := lhs.stmts ++ rhs.stmts, expr := (.eq () lhs.expr rhs.expr)} + {stmts := lhs.stmts ++ rhs.stmts, expr := (.eq Strata.SourceRange.none lhs.expr rhs.expr)} | Strata.Python.cmpop.In _ => - {stmts := lhs.stmts ++ rhs.stmts, expr := .app () (.app () (.op () "str_in_dict_str_any" none) lhs.expr) rhs.expr} + {stmts := lhs.stmts ++ rhs.stmts, expr := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) lhs.expr) rhs.expr} | Strata.Python.cmpop.Lt _ => {stmts := lhs.stmts ++ rhs.stmts, expr := handleLt translation_ctx lhs.expr rhs.expr} | Strata.Python.cmpop.LtE _ => @@ -569,20 +569,20 @@ partial def PyExprToCore (translation_ctx : TranslationContext) (e : Python.expr let k := PyExprToCore translation_ctx slice -- TODO: we need to plumb the type of `v` here match s!"{repr l.expr}" with - | "LExpr.fvar () { name := \"keys\", metadata := () } none" => - -- let access_check : Core.Statement := .assert "subscript_bounds_check" (.app () (.app () (.op () "str_in_dict_str_any" none) k.expr) l.expr) - {stmts := l.stmts ++ k.stmts, expr := .app () (.app () (.op () "list_str_get" none) l.expr) k.expr} - | "LExpr.fvar () { name := \"blended_cost\", metadata := () } none" => - -- let access_check : Core.Statement := .assert "subscript_bounds_check" (.app () (.app () (.op () "str_in_dict_str_any" none) k.expr) l.expr) - {stmts := l.stmts ++ k.stmts, expr := .app () (.app () (.op () "dict_str_any_get_str" none) l.expr) k.expr} + | "LExpr.fvar Strata.SourceRange.none { name := \"keys\", metadata := () } none" => + -- let access_check : Core.Statement := .assert "subscript_bounds_check" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) k.expr) l.expr) + {stmts := l.stmts ++ k.stmts, expr := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "list_str_get" none) l.expr) k.expr} + | "LExpr.fvar Strata.SourceRange.none { name := \"blended_cost\", metadata := () } none" => + -- let access_check : Core.Statement := .assert "subscript_bounds_check" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) k.expr) l.expr) + {stmts := l.stmts ++ k.stmts, expr := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_get_str" none) l.expr) k.expr} | _ => match translation_ctx.expectedType with | .some (.tcons "ListStr" []) => - let access_check : Core.Statement := .assert "subscript_bounds_check" (.app () (.app () (.op () "str_in_dict_str_any" none) k.expr) l.expr) sub_md - {stmts := l.stmts ++ k.stmts ++ [access_check], expr := .app () (.app () (.op () "dict_str_any_get_list_str" none) l.expr) k.expr} + let access_check : Core.Statement := .assert "subscript_bounds_check" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) k.expr) l.expr) sub_md + {stmts := l.stmts ++ k.stmts ++ [access_check], expr := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_get_list_str" none) l.expr) k.expr} | _ => - let access_check : Core.Statement := .assert "subscript_bounds_check" (.app () (.app () (.op () "str_in_dict_str_any" none) k.expr) l.expr) sub_md - {stmts := l.stmts ++ k.stmts ++ [access_check], expr := .app () (.app () (.op () "dict_str_any_get" none) l.expr) k.expr} + let access_check : Core.Statement := .assert "subscript_bounds_check" (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "str_in_dict_str_any" none) k.expr) l.expr) sub_md + {stmts := l.stmts ++ k.stmts ++ [access_check], expr := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_get" none) l.expr) k.expr} | .List _ elmts _ => match elmts.val[0]! with | .Constant _ expr _ => match expr with @@ -602,11 +602,11 @@ partial def initTmpParam (translation_ctx: TranslationContext) (p: Python.expr S match f with | .Name _ n _ => match n.val with - | "json_dumps" => [(.init p.snd t[string] (some (.strConst () "")) md), .call [p.snd, "maybe_except"] "json_dumps" [(.app () (.op () "DictStrAny_mk" none) (.strConst () "DefaultDict")), (Strata.Python.TypeStrToCoreExpr "IntOrNone")] md] + | "json_dumps" => [(.init p.snd t[string] (some (.strConst Strata.SourceRange.none "")) md), .call [p.snd, "maybe_except"] "json_dumps" [(.app Strata.SourceRange.none (.op Strata.SourceRange.none "DictStrAny_mk" none) (.strConst Strata.SourceRange.none "DefaultDict")), (Strata.Python.TypeStrToCoreExpr "IntOrNone")] md] | "str" => assert! args.val.size == 1 - [(.init p.snd t[string] (some (.strConst () "")) md), .set p.snd (.app () (.op () "datetime_to_str" none) ((PyExprToCore default args.val[0]!).expr)) md] - | "int" => [(.init p.snd t[int] (some (.intConst () 0)) md), .set p.snd (.op () "datetime_to_int" none) md] + [(.init p.snd t[string] (some (.strConst Strata.SourceRange.none "")) md), .set p.snd (.app Strata.SourceRange.none (.op Strata.SourceRange.none "datetime_to_str" none) ((PyExprToCore default args.val[0]!).expr)) md] + | "int" => [(.init p.snd t[int] (some (.intConst Strata.SourceRange.none 0)) md), .set p.snd (.op Strata.SourceRange.none "datetime_to_int" none) md] | _ => panic! s!"Unsupported name {n.val}" | _ => panic! s!"Unsupported tmp param init call: {repr f}" | _ => panic! "Expected Call" @@ -619,16 +619,16 @@ partial def exceptHandlersToCore (jmp_targets: List String) (translation_ctx: Tr let set_ex_ty_matches := match ex_ty.val with | .some ex_ty => let inherits_from : Core.CoreIdent := "inheritsFrom" - let get_ex_tag : Core.CoreIdent := "ExceptOrNone..code_val!" - let exception_ty : Core.Expression.Expr := .app () (.op () get_ex_tag none) (.fvar () "maybe_except" none) - let rhs_curried : Core.Expression.Expr := .app () (.op () inherits_from none) exception_ty +let get_ex_tag : Core.CoreIdent := "ExceptOrNone..code_val!" + let exception_ty : Core.Expression.Expr := .app Strata.SourceRange.none (.op Strata.SourceRange.none get_ex_tag none) (.fvar Strata.SourceRange.none "maybe_except" none) + let rhs_curried : Core.Expression.Expr := .app Strata.SourceRange.none (.op Strata.SourceRange.none inherits_from none) exception_ty let res := PyExprToCore translation_ctx ex_ty - let rhs : Core.Expression.Expr := .app () rhs_curried (res.expr) + let rhs : Core.Expression.Expr := .app Strata.SourceRange.none rhs_curried (res.expr) let call := .set "exception_ty_matches" rhs md res.stmts ++ [call] | .none => - [.set "exception_ty_matches" (.boolConst () false) md] - let cond := .fvar () "exception_ty_matches" none + [.set "exception_ty_matches" (.boolConst Strata.SourceRange.none false) md] + let cond := .fvar Strata.SourceRange.none "exception_ty_matches" none let body_if_matches := body.val.toList.flatMap (λ s => (PyStmtToCore jmp_targets.tail! translation_ctx s).fst) ++ [.exit (some jmp_targets[1]!) md] set_ex_ty_matches ++ [.ite cond body_if_matches [] md] @@ -655,8 +655,8 @@ partial def handleFunctionCall (lhs: List Core.Expression.Ident) if isCall arg then some arg else none) let kwords_calls_to_tmps := nested_kwords_calls.map (λ a => (a, s!"call_kword_tmp_{a.toAst.ann.start}")) - let substitution_records : List SubstitutionRecord := args_calls_to_tmps.toList.map (λ p => {pyExpr := p.fst, coreExpr := .fvar () p.snd none}) ++ - kwords_calls_to_tmps.toList.map (λ p => {pyExpr := p.fst, coreExpr := .fvar () p.snd none}) + let substitution_records : List SubstitutionRecord := args_calls_to_tmps.toList.map (λ p => {pyExpr := p.fst, coreExpr := .fvar Strata.SourceRange.none p.snd none}) ++ + kwords_calls_to_tmps.toList.map (λ p => {pyExpr := p.fst, coreExpr := .fvar Strata.SourceRange.none p.snd none}) let md := sourceRangeToMetaData translation_ctx.filePath s.toAst.ann let res := argsAndKWordsToCanonicalList translation_ctx fname args.val kwords.val substitution_records @@ -670,9 +670,9 @@ partial def handleComprehension (translation_ctx: TranslationContext) (lhs: Pyth | .mk_comprehension sr _ itr _ _ => let md := sourceRangeToMetaData translation_ctx.filePath sr let res := PyExprToCore default itr - let guard := .app () (.op () "Bool.Not" none) (.eq () (.app () (.op () "dict_str_any_length" none) res.expr) (.intConst () 0)) + let guard := .app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_length" none) res.expr) (.intConst Strata.SourceRange.none 0)) let then_ss: List Core.Statement := [.havoc (PyExprToString lhs) md] - let else_ss: List Core.Statement := [.set (PyExprToString lhs) (.op () "ListStr_nil" none) md] + let else_ss: List Core.Statement := [.set (PyExprToString lhs) (.op Strata.SourceRange.none "ListStr_nil" none) md] res.stmts ++ [.ite guard then_ss else_ss md] partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : TranslationContext) (s : Python.stmt SourceRange) : List Core.Statement × TranslationContext := @@ -733,7 +733,7 @@ partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : Translati | .none => ([.exit (some jmp_targets[0]!) md], none) | .For _ tgt itr body _ _ => -- Do one unrolling: - let guard := .app () (.op () "Bool.Not" none) (.eq () (.app () (.op () "dict_str_any_length" none) (PyExprToCore default itr).expr) (.intConst () 0)) + let guard := .app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_length" none) (PyExprToCore default itr).expr) (.intConst Strata.SourceRange.none 0)) match tgt with | .Name _ n _ => let assign_tgt := [(.init n.val dictStrAnyType (some dummyDictStrAny) md)] @@ -742,7 +742,7 @@ partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : Translati -- TODO: missing havoc | .While _ test body _ => -- Do one unrolling: - let guard := .app () (.op () "Bool.Not" none) (.eq () (.app () (.op () "dict_str_any_length" none) (PyExprToCore default test).expr) (.intConst () 0)) + let guard := .app Strata.SourceRange.none (.op Strata.SourceRange.none "Bool.Not" none) (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "dict_str_any_length" none) (PyExprToCore default test).expr) (.intConst Strata.SourceRange.none 0)) ([.ite guard (ArrPyStmtToCore translation_ctx body.val).fst [] md], none) -- TODO: missing havoc | .Assert sr a _ => @@ -755,7 +755,7 @@ partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : Translati match lhs with | .Name _ n _ => let rhs := PyExprToCore translation_ctx rhs - let new_lhs := (.strConst () "DUMMY_FLOAT") + let new_lhs := (.strConst Strata.SourceRange.none "DUMMY_FLOAT") (rhs.stmts ++ [.set n.val new_lhs md], none) | _ => panic! s!"Expected lhs to be name: {repr lhs}" | .FloorDiv _ => @@ -763,7 +763,7 @@ partial def PyStmtToCore (jmp_targets: List String) (translation_ctx : Translati | .Name _ n _ => let lhs := PyExprToCore translation_ctx lhs let rhs := PyExprToCore translation_ctx rhs - let new_lhs := .app () (.app () (.op () "Int.Div" mty[int → (int → int)]) lhs.expr) rhs.expr + let new_lhs := .app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "Int.Div" mty[int → (int → int)]) lhs.expr) rhs.expr (rhs.stmts ++ [.set n.val new_lhs md], none) | _ => panic! s!"Expected lhs to be name: {repr lhs}" | _ => panic! s!"Unsupported AugAssign op: {repr op}" @@ -812,7 +812,7 @@ def pyTyStrToLMonoTy (ty_str: String) : Lambda.LMonoTy := def pythonFuncToCore (name : String) (args: List (String × String)) (body: Array (Python.stmt SourceRange)) (ret : Option (Python.expr SourceRange)) (spec : Core.Procedure.Spec) (translation_ctx : TranslationContext) : Core.Procedure := let inputs : List (Lambda.Identifier Unit × Lambda.LMonoTy) := args.map (λ p => (p.fst, pyTyStrToLMonoTy p.snd)) - let varDecls := collectVarDecls translation_ctx body ++ [(.init "exception_ty_matches" t[bool] (some (.boolConst () false)) .empty), (.havoc "exception_ty_matches" .empty)] + let varDecls := collectVarDecls translation_ctx body ++ [(.init "exception_ty_matches" t[bool] (some (.boolConst Strata.SourceRange.none false)) .empty), (.havoc "exception_ty_matches" .empty)] let stmts := (ArrPyStmtToCore translation_ctx body).fst let body := varDecls ++ [.block "end" stmts .empty] let constructor := name.endsWith "___init__" @@ -887,7 +887,7 @@ def pythonToCore (signatures : Python.Signatures) (pgm: Strata.Program) (prelude | .ClassDef _ _ _ _ _ _ _ => false | _ => true) - let globals := [(.var "__name__" (.forAll [] mty[string]) (some (.strConst () "__main__")))] + let globals := [(.var "__name__" (.forAll [] mty[string]) (some (.strConst Strata.SourceRange.none "__main__")))] let rec helper {α : Type} (f : Python.stmt SourceRange → TranslationContext → List Core.Decl × α) (update : TranslationContext → α → TranslationContext) diff --git a/Strata/Languages/Python/Regex/ReToCore.lean b/Strata/Languages/Python/Regex/ReToCore.lean index 51fa21db7..5bd7136eb 100644 --- a/Strata/Languages/Python/Regex/ReToCore.lean +++ b/Strata/Languages/Python/Regex/ReToCore.lean @@ -106,35 +106,35 @@ def RegexAST.hasNonAnchorContent (r : RegexAST) : Bool := Empty regex pattern; matches an empty string. -/ def Core.emptyRegex : Core.Expression.Expr := - mkApp () (.op () strToRegexFunc.name none) [strConst () ""] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none strToRegexFunc.name none) [strConst Strata.SourceRange.none ""] /-- Unmatchable regex pattern. -/ def Core.unmatchableRegex : Core.Expression.Expr := - mkApp () (.op () reNoneFunc.name none) [] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reNoneFunc.name none) [] -- Core regex expression builders. private abbrev mkReFromStr (s : String) : Core.Expression.Expr := - mkApp () (.op () strToRegexFunc.name none) [strConst () s] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none strToRegexFunc.name none) [strConst Strata.SourceRange.none s] private abbrev mkReRange (c1 c2 : Char) : Core.Expression.Expr := - mkApp () (.op () reRangeFunc.name none) [strConst () (toString c1), strConst () (toString c2)] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reRangeFunc.name none) [strConst Strata.SourceRange.none (toString c1), strConst Strata.SourceRange.none (toString c2)] private abbrev mkReAllChar : Core.Expression.Expr := - .op () reAllCharFunc.name none + .op Strata.SourceRange.none reAllCharFunc.name none private abbrev mkReComp (r : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () reCompFunc.name none) [r] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reCompFunc.name none) [r] private abbrev mkReUnion (a b : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () reUnionFunc.name none) [a, b] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reUnionFunc.name none) [a, b] private abbrev mkReConcat (a b : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () reConcatFunc.name none) [a, b] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reConcatFunc.name none) [a, b] private abbrev mkReInter (a b : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () reInterFunc.name none) [a, b] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reInterFunc.name none) [a, b] private abbrev mkReStar (r : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () reStarFunc.name none) [r] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reStarFunc.name none) [r] private abbrev mkRePlus (r : Core.Expression.Expr) : Core.Expression.Expr := - mkApp () (.op () rePlusFunc.name none) [r] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none rePlusFunc.name none) [r] private abbrev mkReLoop (r : Core.Expression.Expr) (lo hi : Nat) : Core.Expression.Expr := - mkApp () (.op () reLoopFunc.name none) [r, intConst () lo, intConst () hi] + mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reLoopFunc.name none) [r, intConst Strata.SourceRange.none lo, intConst Strata.SourceRange.none hi] /-- Shared body for `star` and `loop {0, m}` (m ≥ 2): @@ -300,7 +300,7 @@ def RegexAST.toCore (r : RegexAST) (atStart atEnd : Bool) : def pythonRegexToCore (pyRegex : String) (mode : MatchMode := .fullmatch) : Core.Expression.Expr × Option ParseError := match parseTop pyRegex with - | .error err => (mkApp () (.op () reAllFunc.name none) [], some err) + | .error err => (mkApp Strata.SourceRange.none (.op Strata.SourceRange.none reAllFunc.name none) [], some err) | .ok ast => -- `dotStar`: passed with `atStart=false`, `atEnd=false` since `anychar` -- ignores both. diff --git a/Strata/Transform/CallElimCorrect.lean b/Strata/Transform/CallElimCorrect.lean index f0ff6848c..bb1ab78c0 100644 --- a/Strata/Transform/CallElimCorrect.lean +++ b/Strata/Transform/CallElimCorrect.lean @@ -602,7 +602,7 @@ theorem EvalStatementContractInitVar : constructor constructor . apply Imperative.EvalCmd.eval_init <;> try assumption - have Hwfv := Hwf (Lambda.LExpr.fvar () v none) v σ + have Hwfv := Hwf (Lambda.LExpr.fvar Strata.SourceRange.none v none) v σ rw [Hwfv]; assumption simp [Imperative.HasFvar.getFvar] apply Imperative.InitState.init Hnone @@ -1132,8 +1132,8 @@ theorem Lambda.LExpr.substFvarCorrect : simp [Imperative.HasFvar.getFvar] case abs m ty e ih => specialize ih Hinv - have e2 := (e.substFvar fro (Lambda.LExpr.fvar () to none)) - have Hwfc := Hwfc.1 σ σ' e ((e.substFvar fro (Lambda.LExpr.fvar () to none))) + have e2 := (e.substFvar fro (Lambda.LExpr.fvar Strata.SourceRange.none to none)) + have Hwfc := Hwfc.1 σ σ' e ((e.substFvar fro (Lambda.LExpr.fvar Strata.SourceRange.none to none))) grind case quant m k ty tr e trih eih => simp [Imperative.invStores, Imperative.substStores, @@ -2018,7 +2018,7 @@ NormalizedOldExpr e → rename_i md tyy id v have HH2 := HH md tyy () id v simp_all - have Hnold' : ¬ IsOldPred (substOld h (Lambda.LExpr.fvar () h' none) fn) := by + have Hnold' : ¬ IsOldPred (substOld h (Lambda.LExpr.fvar Strata.SourceRange.none h' none) fn) := by intros Hold apply Hnold apply substOldIsOldPred' ?_ Hold @@ -2071,8 +2071,8 @@ theorem substOldExpr_cons: split <;> simp [*] simp_all [createOldVarsSubst, createFvar] rename_i _ fn e _ _ H - generalize H1: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar () h.fst.fst none) fn) = fn' - generalize H2: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar () h.fst.fst none) e) = e' + generalize H1: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar Strata.SourceRange.none h.fst.fst none) fn) = fn' + generalize H2: (OldExpressions.substOld h.snd (Lambda.LExpr.fvar Strata.SourceRange.none h.fst.fst none) e) = e' rw (occs := [3]) [Core.OldExpressions.substsOldExpr.eq_def] simp; split simp_all [Map.isEmpty]; rename_i H; split at H <;> simp_all @@ -3244,7 +3244,7 @@ theorem substsOldPostSubset: have ih := @ih post Hdisj have : (Imperative.HasVarsPure.getVars - (substsOldExpr ((h.snd, Lambda.LExpr.fvar () h.1.fst none) :: List.map createOldVarsSubst.go t) post)).Subset + (substsOldExpr ((h.snd, Lambda.LExpr.fvar Strata.SourceRange.none h.1.fst none) :: List.map createOldVarsSubst.go t) post)).Subset ((Imperative.HasVarsPure.getVars (substsOldExpr (List.map createOldVarsSubst.go t) post)) ++ [h.1.fst]) := by apply substOldExprPostSubset apply List.Subset.trans this diff --git a/Strata/Transform/CoreTransform.lean b/Strata/Transform/CoreTransform.lean index 0f67bb32b..73cc08da2 100644 --- a/Strata/Transform/CoreTransform.lean +++ b/Strata/Transform/CoreTransform.lean @@ -28,7 +28,7 @@ def createHavocs (ident : List Expression.Ident) (md : (Imperative.MetaData Expr def createFvar (ident : Expression.Ident) : Expression.Expr - := Lambda.LExpr.fvar ((): ExpressionMetadata) ident none + := Lambda.LExpr.fvar Strata.SourceRange.none ident none def createFvars (ident : List Expression.Ident) : List Expression.Expr @@ -226,7 +226,7 @@ def createInitVar (trip : (Expression.Ident × Expression.Ty) × Expression.Iden (md:Imperative.MetaData Expression) : Statement := match trip with - | ((v', ty), v) => Statement.init v' ty (some (Lambda.LExpr.fvar () v none)) md + | ((v', ty), v) => Statement.init v' ty (some (Lambda.LExpr.fvar Strata.SourceRange.none v none)) md def createInitVars (trips : List ((Expression.Ident × Expression.Ty) × Expression.Ident)) (md : (Imperative.MetaData Expression)) diff --git a/Strata/Transform/ProcedureInlining.lean b/Strata/Transform/ProcedureInlining.lean index c05a64a29..99ce9b750 100644 --- a/Strata/Transform/ProcedureInlining.lean +++ b/Strata/Transform/ProcedureInlining.lean @@ -99,7 +99,7 @@ private def renameAllLocalNames (c:Procedure) -- Do substitution let new_body := List.map (fun (s0:Statement) => var_map.foldl (fun (s:Statement) (old_id,new_id) => - let s := Statement.substFvar s old_id (.fvar () new_id .none) + let s := Statement.substFvar s old_id (.fvar Strata.SourceRange.none new_id .none) let s := Statement.renameLhs s old_id new_id Statement.replaceLabels s label_map) s0) c.body @@ -219,7 +219,7 @@ def inlineCallCmd let outs_lhs_and_sig := List.zip lhs out_vars List.map (fun (lhs_var,out_var) => - Statement.set lhs_var (.fvar () out_var (.none)) md) + Statement.set lhs_var (.fvar Strata.SourceRange.none out_var (.none)) md) outs_lhs_and_sig let stmts:List (Imperative.Stmt Core.Expression Core.Command) diff --git a/StrataMain.lean b/StrataMain.lean index a7291ab6a..a8b144080 100644 --- a/StrataMain.lean +++ b/StrataMain.lean @@ -19,6 +19,11 @@ import Strata.Languages.Python.CorePrelude import Strata.Backends.CBMC.GOTO.CoreToCProverGOTO import Strata.SimpleAPI +import Strata.Languages.Core.DDMTransform.ASTtoCST +import Strata.Languages.Core.CoreSMT.Verifier +import Strata.Languages.Core.CoreSMT.State +import Strata.DL.SMT.SolverInterface +import Strata.Languages.B3.Verifier open Core (VerifyOptions VerboseMode) @@ -293,7 +298,7 @@ def pyAnalyzeCommand : Command where match fr.file with | .file path => if path == pyPath then - let pos := (Lean.FileMap.ofString srcText).toPosition fr.range.start + let pos := (Lean.FileMap.ofString srcText).toPosition (fr.range).start -- For failures, show at beginning; for passes, show at end match vcResult.result with | .fail => (s!"Assertion failed at line {pos.line}, col {pos.column}: ", "") @@ -301,12 +306,12 @@ def pyAnalyzeCommand : Command where else -- From CorePrelude or other source, show byte offsets match vcResult.result with - | .fail => (s!"Assertion failed at byte {fr.range.start}: ", "") - | _ => ("", s!" (at byte {fr.range.start})") + | .fail => (s!"Assertion failed at byte {(fr.range).start}: ", "") + | _ => ("", s!" (at byte {(fr.range).start})") | none => match vcResult.result with - | .fail => (s!"Assertion failed at byte {fr.range.start}: ", "") - | _ => ("", s!" (at byte {fr.range.start})") + | .fail => (s!"Assertion failed at byte {(fr.range).start}: ", "") + | _ => ("", s!" (at byte {(fr.range).start})") | none => ("", "") s := s ++ s!"\n{locationPrefix}{vcResult.obligation.label}: {Std.format vcResult.result}{locationSuffix}\n" IO.println s @@ -373,10 +378,106 @@ def buildPySpecPrelude (pyspecPaths : Array String) : IO PySpecPrelude := do let pyPrelude : Core.Program := { decls := preludeDecls.toList } return { corePrelude := pyPrelude, overloads := allOverloads } +/-- Verify a Core program using the incremental CoreSMT engine. + Prints per-procedure results with diagnosis details inline. -/ +private def verifyIncremental + (programDecls : List Core.Decl) + (pySourceOpt : Option (String × String)) : IO (Array Core.VCResult) := do + let solver ← Strata.B3.Verifier.createInteractiveSolver Core.defaultSolver + let solverInterface ← Strata.SMT.mkSolverInterfaceFromSolver solver + let state := Strata.Core.CoreSMT.CoreSMTState.init solverInterface { accumulateErrors := true } + let procs := programDecls.filterMap fun d => match d with + | .proc p _ => + if p.header.inputs.isEmpty && p.header.outputs.isEmpty then + let cleaned := Strata.Core.CoreSMT.removeUnusedVarsStmts p.body + some (p.header.name.name, Imperative.Stmt.block p.header.name.name cleaned .empty) + else none + | _ => none + let mut allResults : Array Core.VCResult := #[] + let mut state := state + let mut smtCtx := Core.SMT.Context.default + for (procName, block) in procs do + IO.println s!"procedure {procName}:" + let (state', smtCtx', results) ← Strata.Core.CoreSMT.verify state Core.Env.init [block] smtCtx + state := state' + smtCtx := smtCtx' + for r in results do + let marker := match r.result with + | .pass => "✅ pass" + | .fail => "❌ fail" + | .unknown => "❓ unknown" + | .implementationError msg => s!"🚨 {msg}" + let suffix := match Imperative.getFileRange r.obligation.metadata with + | some fr => + if fr.range.isNone then "" + else match pySourceOpt with + | some (pyPath, srcText) => + match fr.file with + | .file path => + if path == pyPath then + let pos := (Lean.FileMap.ofString srcText).toPosition (fr.range).start + s!" (line {pos.line}, col {pos.column})" + else s!" (byte {(fr.range).start})" + | none => s!" (byte {(fr.range).start})" + | none => "" + IO.println s!" {r.obligation.label}: {marker}{suffix}" + if let some diag := r.diagnosis then + for failure in diag.diagnosedFailures do + let failureKind := if failure.isRefuted then "it is impossible that" else "could not prove" + let exprStr := (Strata.Core.formatExprs [failure.expression]).pretty + IO.println s!" └─ {failureKind} {exprStr}" + let assumptions := failure.report.context.pathCondition + if !assumptions.isEmpty then + IO.println s!" under the assumptions" + for assumption in assumptions do + IO.println s!" {(Strata.Core.formatExprs [assumption]).pretty}" + allResults := allResults ++ results.toArray + return allResults + +/-- Verify a Core program using the batch SMT file approach. + Prints results in the ==== Verification Results ==== format. -/ +private def verifyBatch + (coreProgram : Core.Program) + (pySourceOpt : Option (String × String)) : IO (Array Core.VCResult) := do + let vcResults ← IO.FS.withTempDir (fun tempDir => + EIO.toIO + (fun f => IO.Error.userError (toString f)) + (Core.verify coreProgram tempDir .none + { VerifyOptions.default with stopOnFirstError := false, verbose := .quiet, solver := "z3" })) + IO.println "\n==== Verification Results ====" + let mut s := "" + for vcResult in vcResults do + let (locationPrefix, locationSuffix) := match Imperative.getFileRange vcResult.obligation.metadata with + | some fr => + if fr.range.isNone then ("", "") + else + match pySourceOpt with + | some (pyPath, srcText) => + match fr.file with + | .file path => + if path == pyPath then + let pos := (Lean.FileMap.ofString srcText).toPosition (fr.range).start + match vcResult.result with + | .fail => (s!"Assertion failed at line {pos.line}, col {pos.column}: ", "") + | _ => ("", s!" (at line {pos.line}, col {pos.column})") + else + match vcResult.result with + | .fail => (s!"Assertion failed at byte {(fr.range).start}: ", "") + | _ => ("", s!" (at byte {(fr.range).start})") + | none => + match vcResult.result with + | .fail => (s!"Assertion failed at byte {(fr.range).start}: ", "") + | _ => ("", s!" (at byte {(fr.range).start})") + | none => ("", "") + s := s ++ s!"{locationPrefix}{vcResult.obligation.label}: {Std.format vcResult.result}{locationSuffix}\n" + IO.println s + return vcResults + def pyAnalyzeLaurelCommand : Command where name := "pyAnalyzeLaurel" args := [ "file" ] flags := [{ name := "verbose", help := "Enable verbose output." }, + { name := "incremental", help := "Use the incremental (in-memory) CoreSMT verification engine." }, { name := "pyspec", help := "Add PySpec-derived Laurel declarations.", takesArg := .repeat "ion_file" }, @@ -464,50 +565,14 @@ def pyAnalyzeLaurelCommand : Command where -- dbg_trace (toString (Std.Format.pretty (Strata.Core.formatProgram coreProgram) 100)) -- dbg_trace "=================================" - -- Verify using Core verifier - let baseOptions : VerifyOptions := - { VerifyOptions.default with stopOnFirstError := false, verbose := .quiet, solver := "z3" } - let options : VerifyOptions := match pflags.getString "vc-directory" with - | .some dir => { baseOptions with vcDirectory := some (dir : System.FilePath) } - | .none => baseOptions - let runVerification tempDir := - EIO.toIO - (fun f => IO.Error.userError (toString f)) - (Core.verify coreProgram tempDir .none options) - let vcResults ← match options.vcDirectory with - | .none => IO.FS.withTempDir runVerification - | .some vcDir => do - IO.FS.createDirAll vcDir - runVerification vcDir - - -- Print results - IO.println "\n==== Verification Results ====" - let mut s := "" - for vcResult in vcResults do - let (locationPrefix, locationSuffix) := match Imperative.getFileRange vcResult.obligation.metadata with - | some fr => - if fr.range.isNone then ("", "") - else - match pySourceOpt with - | some (pyPath, srcText) => - match fr.file with - | .file path => - if path == pyPath then - let pos := (Lean.FileMap.ofString srcText).toPosition fr.range.start - match vcResult.result with - | .fail => (s!"Assertion failed at line {pos.line}, col {pos.column}: ", "") - | _ => ("", s!" (at line {pos.line}, col {pos.column})") - else - match vcResult.result with - | .fail => (s!"Assertion failed at byte {fr.range.start}: ", "") - | _ => ("", s!" (at byte {fr.range.start})") - | none => - match vcResult.result with - | .fail => (s!"Assertion failed at byte {fr.range.start}: ", "") - | _ => ("", s!" (at byte {fr.range.start})") - | none => ("", "") - s := s ++ s!"{locationPrefix}{vcResult.obligation.label}: {Std.format vcResult.result}{locationSuffix}\n" - IO.println s + -- Verify using incremental CoreSMT engine or batch Core verifier + let incremental := pflags.getBool "incremental" + let vcResults ← + if incremental then + verifyIncremental programDecls pySourceOpt + else + verifyBatch coreProgram pySourceOpt + -- Output in SARIF format if requested if outputSarif then let files := match pySourceOpt with diff --git a/StrataTest/DL/Imperative/FormatStmtTest.lean b/StrataTest/DL/Imperative/FormatStmtTest.lean index 97e14aee7..59908de9a 100644 --- a/StrataTest/DL/Imperative/FormatStmtTest.lean +++ b/StrataTest/DL/Imperative/FormatStmtTest.lean @@ -16,16 +16,16 @@ private abbrev Ss := List S private abbrev E := Expression.Expr private def intTy : Expression.Ty := .forAll [] .int -private def x : E := .fvar () (⟨"x", ()⟩) (some .int) -private def y : E := .fvar () (⟨"y", ()⟩) (some .int) -private def tt : E := .boolConst () true -private def int0 : E := .intConst () 0 -private def int1 : E := .intConst () 1 -private def int2 : E := .intConst () 2 -private def int42 : E := .intConst () 42 -private def xEq0 : E := .eq () x int0 -private def xEq5 : E := .eq () x (.intConst () 5) -private def xEq1 : E := .eq () x int1 +private def x : E := .fvar Strata.SourceRange.none (⟨"x", ()⟩) (some .int) +private def y : E := .fvar Strata.SourceRange.none (⟨"y", ()⟩) (some .int) +private def tt : E := .boolConst Strata.SourceRange.none true +private def int0 : E := .intConst Strata.SourceRange.none 0 +private def int1 : E := .intConst Strata.SourceRange.none 1 +private def int2 : E := .intConst Strata.SourceRange.none 2 +private def int42 : E := .intConst Strata.SourceRange.none 42 +private def xEq0 : E := .eq Strata.SourceRange.none x int0 +private def xEq5 : E := .eq Strata.SourceRange.none x (.intConst Strata.SourceRange.none 5) +private def xEq1 : E := .eq Strata.SourceRange.none x int1 -- 1. cmd: init /-- info: init (x : int) := #0 -/ diff --git a/StrataTest/Languages/B3/Verifier/TranslationTests.lean b/StrataTest/Languages/B3/Verifier/TranslationTests.lean index 9253f0f39..264a7dfdf 100644 --- a/StrataTest/Languages/B3/Verifier/TranslationTests.lean +++ b/StrataTest/Languages/B3/Verifier/TranslationTests.lean @@ -68,11 +68,9 @@ def testSMTGeneration (prog : Program) : IO Unit := do --------------------------------------------------------------------- /-- -info: (declare-fun abs (Int) Int) -(assert (forall ((x Int)) (! (= (abs x) (ite (>= x 0) x (- x))) :pattern ((abs x))))) +info: (define-fun abs ((x Int)) Int (ite (>= x 0) x (- x))) (push 1) -(assert (not (= (abs (- 5)) 5))) -(check-sat) +(check-sat-assuming ((not (= (abs (- 5)) 5)))) (pop 1) -/ #guard_msgs in @@ -86,13 +84,10 @@ procedure test() { #end /-- -info: (declare-fun isEven (Int) Int) -(declare-fun isOdd (Int) Int) -(assert (forall ((n Int)) (! (= (isEven n) (ite (= n 0) 1 (isOdd (- n 1)))) :pattern ((isEven n))))) -(assert (forall ((n Int)) (! (= (isOdd n) (ite (= n 0) 0 (isEven (- n 1)))) :pattern ((isOdd n))))) +info: (define-fun isEven ((n Int)) Int (ite (= n 0) 1 (isOdd (- n 1)))) +(define-fun isOdd ((n Int)) Int (ite (= n 0) 0 (isEven (- n 1)))) (push 1) -(assert (not (= (isEven 4) 1))) -(check-sat) +(check-sat-assuming ((not (= (isEven 4) 1)))) (pop 1) -/ #guard_msgs in @@ -110,10 +105,9 @@ procedure test() { /-- info: (declare-fun f (Int) Int) -(assert (forall ((x Int)) (! (=> (> x 0) (> (f x) 0)) :pattern ((f x))))) +(assert (forall ((x Int)) (=> (> x 0) (> (f x) 0)))) (push 1) -(assert (not (=> (> 5 0) (> (f 5) 0)))) -(check-sat) +(check-sat-assuming ((not (=> (> 5 0) (> (f 5) 0))))) (pop 1) -/ #guard_msgs in @@ -126,12 +120,10 @@ procedure test() { #end /-- -info: (declare-fun f (Int) Bool) +info: (define-fun f ((x Int)) Bool (= (+ x 1) 6)) (declare-fun g (Int Int) Bool) -(assert (forall ((x Int)) (! (= (f x) (= (+ x 1) 6)) :pattern ((f x))))) (push 1) -(assert (not (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (= 5 5) (not (= 3 4))) (< 2 3)) (<= 2 2)) (> 4 3)) (>= 4 4)) (= (+ 1 2) 4)) (= (- 5 2) 3)) (= (* 3 4) 12)) (= (div 10 2) 5)) (= (mod 7 3) 1)) (= (- 5) (- 0 5))) (=> true true)) (or false true)) (ite true true false)) (f 5)) (g 1 2)) (forall ((y Int)) (! (or (f y) (not (f y))) :pattern ((f y))))) (forall ((y Int)) (or (> y 0) (<= y 0)))))) -(check-sat) +(check-sat-assuming ((not (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and true (not false)) (< 2 3)) (<= 2 2)) (> 4 3)) (>= 4 4)) (= (+ 1 2) 4)) (= (- 5 2) 3)) (= (* 3 4) 12)) (= (div 10 2) 5)) (= (mod 7 3) 1)) (= (- 5) (- 0 5))) (=> true true)) (or false true)) true) (f 5)) (g 1 2)) (forall ((y Int)) (or (f y) (not (f y))))) (forall ((y Int)) (or (> y 0) (<= y 0))))))) (pop 1) -/ #guard_msgs in @@ -167,11 +159,9 @@ procedure test_all_expressions() { -- The test below should return an error and the SMT code. /-- -info: error: Invalid pattern each pattern expression must be a function application -(declare-fun f (Int) Bool) +info: (declare-fun f (Int) Bool) (push 1) -(assert (not (forall ((y Int)) (! (> y 0) :pattern (y))))) -(check-sat) +(check-sat-assuming ((not (forall ((y Int)) (> y 0))))) (pop 1) -/ #guard_msgs in diff --git a/StrataTest/Languages/B3/Verifier/VerifierTests.lean b/StrataTest/Languages/B3/Verifier/VerifierTests.lean index a07c8e27f..87e407789 100644 --- a/StrataTest/Languages/B3/Verifier/VerifierTests.lean +++ b/StrataTest/Languages/B3/Verifier/VerifierTests.lean @@ -5,6 +5,8 @@ -/ import Strata.Languages.B3.Verifier +import Strata.Languages.B3.Format +import Strata.Languages.B3.FromCore import Strata.Languages.B3.DDMTransform.ParseCST import Strata.Languages.B3.DDMTransform.Conversion import Strata.DL.SMT.Solver @@ -128,134 +130,107 @@ def testVerification (prog : Program) : IO Unit := do let ast ← match result with | .ok ast => pure ast | .error msg => throw (IO.userError s!"Parse error: {msg}") - -- Create a fresh solver for each test to avoid state issues - let solver ← createInteractiveSolver "cvc5" - let reports ← programToSMT ast solver - -- Don't call exit - let the solver process terminate naturally + let solver ← Solver.spawn "cvc5" #["--quiet", "--lang", "smt", "--incremental", "--produce-models"] + let reports ← B3.Verifier.programToSMT ast solver for report in reports do - for (result, diagnosis) in report.results do - match result.context.decl with - | .procedure _ name _ _ _ => - let marker := if result.result.isError then "✗" else "✓" - let description := match result.result with - | .error .counterexample => "counterexample found" - | .error .unknown => "unknown" - | .error .refuted => "refuted" - | .success .verified => "verified" - | .success .reachable => "reachable" - | .success .reachabilityUnknown => "reachability unknown" - - IO.println s!"{name.val}: {marker} {description}" - if result.result.isError then - let baseOffset := match prog.commands.toList with - | [op] => op.ann.start - | _ => { byteIdx := 0 } - - let stmt := result.context.stmt - IO.println s!" {formatStatementError prog stmt}" - - -- Display diagnosis with VC for each failure, or top-level VC if no diagnosis - match diagnosis with - | some diag => - if !diag.diagnosedFailures.isEmpty then - -- Show diagnosis with assumptions for each failure - for failure in diag.diagnosedFailures do - let exprLoc := formatExpressionLocation prog failure.expression - let exprFormatted := formatExpressionOnly prog failure.expression - let diagnosisPrefix := match failure.report.result with - | .error .refuted => MSG_IMPOSSIBLE - | .error .counterexample | .error .unknown => MSG_COULD_NOT_PROVE - | .success _ => MSG_COULD_NOT_PROVE -- Shouldn't happen - - -- Get statement location for comparison - let stmtLoc := match stmt with - | .check m _ | .assert m _ | .reach m _ => formatSourceLocation baseOffset m - | _ => "" - - -- Only show location if different from statement location - if exprLoc == stmtLoc then - IO.println s!" └─ {diagnosisPrefix} {exprFormatted}" - else - IO.println s!" └─ {exprLoc}: {diagnosisPrefix} {exprFormatted}" - - -- Show assumptions for this failure (from report context) - if !failure.report.context.pathCondition.isEmpty then - IO.println s!" {MSG_UNDER_ASSUMPTIONS}" - for expr in failure.report.context.pathCondition.reverse do - -- Flatten conjunctions to show each on separate line - for conjunct in flattenConjunction expr do - let formatted := formatExpressionOnly prog conjunct - IO.println s!" {formatted}" - else - -- No specific diagnosis - use same format with └─ - if !result.context.pathCondition.isEmpty then - match stmt with - | .check m expr | .assert m expr => - let exprLoc := formatSourceLocation baseOffset m - let formatted := formatExpressionOnly prog expr - IO.println s!" └─ {exprLoc}: {MSG_COULD_NOT_PROVE} {formatted}" - IO.println s!" {MSG_UNDER_ASSUMPTIONS}" - for expr in result.context.pathCondition.reverse do - -- Flatten conjunctions to show each on separate line - for conjunct in flattenConjunction expr do - let formatted := formatExpressionOnly prog conjunct - IO.println s!" {formatted}" - | .reach m expr => - let exprLoc := formatSourceLocation baseOffset m - let formatted := formatExpressionOnly prog expr - IO.println s!" └─ {exprLoc}: {MSG_IMPOSSIBLE} {formatted}" - IO.println s!" {MSG_UNDER_ASSUMPTIONS}" - for expr in result.context.pathCondition.reverse do - -- Flatten conjunctions to show each on separate line - for conjunct in flattenConjunction expr do - let formatted := formatExpressionOnly prog conjunct - IO.println s!" {formatted}" - | _ => pure () - | none => - -- No diagnosis - use same format with └─ - if !result.context.pathCondition.isEmpty then - match stmt with - | .check m expr | .assert m expr => - let exprLoc := formatSourceLocation baseOffset m - let formatted := formatExpressionOnly prog expr - IO.println s!" └─ {exprLoc}: {MSG_COULD_NOT_PROVE} {formatted}" - IO.println s!" {MSG_UNDER_ASSUMPTIONS}" - for expr in result.context.pathCondition.reverse do - -- Flatten conjunctions to show each on separate line - for conjunct in flattenConjunction expr do - let formatted := formatExpressionOnly prog conjunct - IO.println s!" {formatted}" - | .reach m expr => - let exprLoc := formatSourceLocation baseOffset m - let formatted := formatExpressionOnly prog expr - IO.println s!" └─ {exprLoc}: {MSG_IMPOSSIBLE} {formatted}" - IO.println s!" {MSG_UNDER_ASSUMPTIONS}" - for expr in result.context.pathCondition.reverse do - -- Flatten conjunctions to show each on separate line - for conjunct in flattenConjunction expr do - let formatted := formatExpressionOnly prog conjunct - IO.println s!" {formatted}" - | _ => pure () - | _ => pure () + for result in report.results do + let marker := match result.outcome with + | .pass => "✓" + | .fail => "✗" + | .unknown => "✗" + | .implementationError _ => "✗" + + let description := match result.outcome with + | .pass => "verified" + | .fail => "counterexample found" + | .unknown => "unknown" + | .implementationError msg => s!"error: {msg}" + + IO.println s!"{result.label}: {marker} {description}" + if result.outcome != .pass then + -- Show the statement (obligation expression converted to B3) + match result.obligation with + | some obl => + match B3.FromCore.exprFromCore obl.obligation with + | .ok b3Stmt => + -- Use statement source range from metadata if available, else expression location + let stmtLoc := match Imperative.getFileRange obl.metadata with + | some fr => formatSourceLocation (match prog.commands.toList with + | [op] => op.ann.start | _ => { byteIdx := 0 }) fr.range + | none => formatExpressionLocation prog b3Stmt + let stmtFormatted := formatExpressionOnly prog b3Stmt + let stmtKind := if obl.property == .cover then "reach" + else match obl.metadata.find? (·.fld == .label "stmtKind") with + | some { value := .msg k, .. } => k + | _ => "check" + IO.println s!" {stmtLoc}: {stmtKind} {stmtFormatted}" + | .error _ => pure () + | none => pure () + -- Show diagnosis if available + match result.diagnosis with + | some diag => + -- Show full obligation as first diagnosis line + let fullFormatted ← match result.obligation with + | some obl => + match B3.FromCore.exprFromCore obl.obligation with + | .ok b3Full => + let fullLoc := formatExpressionLocation prog b3Full + let fullStr := formatExpressionOnly prog b3Full + let fullPrefix := if obl.property == .cover then MSG_IMPOSSIBLE else MSG_COULD_NOT_PROVE + IO.println s!" └─ {fullLoc}: {fullPrefix} {fullStr}" + -- Show state path conditions (from assume statements) for the full obligation + if !diag.statePathCondition.isEmpty then + IO.println s!" {MSG_UNDER_ASSUMPTIONS}" + for assumption in diag.statePathCondition.reverse do + match B3.FromCore.exprFromCore assumption with + | .ok b3Assumption => IO.println s!" {formatExpressionOnly prog b3Assumption}" + | .error _ => IO.println s!" " + pure (some fullStr) + | .error _ => pure none + | none => pure none + -- Show sub-expressions that differ from the full obligation + for failure in diag.diagnosedFailures do + let diagnosisPrefix := match failure.report.result with + | .error .refuted => MSG_IMPOSSIBLE + | .error .counterexample | .error .unknown => MSG_COULD_NOT_PROVE + | .ok _ => MSG_COULD_NOT_PROVE + match B3.FromCore.exprFromCore failure.expression with + | .ok b3Expr => + let exprFormatted := formatExpressionOnly prog b3Expr + -- Skip if identical to full obligation (single-expression check) + if fullFormatted != some exprFormatted then + let exprLoc := formatExpressionLocation prog b3Expr + IO.println s!" └─ {exprLoc}: {diagnosisPrefix} {exprFormatted}" + -- Show path conditions for this sub-expression + if !failure.report.context.pathCondition.isEmpty then + IO.println s!" {MSG_UNDER_ASSUMPTIONS}" + for assumption in failure.report.context.pathCondition.reverse do + match B3.FromCore.exprFromCore assumption with + | .ok b3Assumption => IO.println s!" {formatExpressionOnly prog b3Assumption}" + | .error _ => IO.println s!" " + | .error _ => + IO.println s!" └─ {diagnosisPrefix} " + | none => pure () --------------------------------------------------------------------- -- Example from Verifier.lean Documentation --------------------------------------------------------------------- /-- -info: Statement: check 8 == 8 && f(5) == 7 -✗ Unknown - Path condition: - forall x : int pattern f(x) f(x) == x + 1 - Found 1 diagnosed failures -Failing expression: f(5) == 7 -✗ Refuted (proved false/unreachable) - Path condition: - 8 == 8 - forall x : int pattern f(x) f(x) == x + 1 +info: test: ✗ counterexample found + (0,61): check 8 == 8 && f(5) == 7 + └─ (0,67): could not prove 8 == 8 && f(5) == 7 + └─ (0,77): it is impossible that f(5) == 7 + under the assumptions + 8 == 8 -/ #guard_msgs in -#eval exampleVerification +#eval testVerification $ #strata program B3CST; + function f(x : int) : int { x + 1 } + procedure test() { + check 8 == 8 && f(5) == 7 + } +#end --------------------------------------------------------------------- -- Check Statement Tests @@ -263,20 +238,20 @@ Failing expression: f(5) == 7 /-- info: test_checks_are_not_learned: ✗ unknown - (0,113): check f(5) > 1 - └─ (0,113): could not prove f(5) > 1 + (0,110): check f(5) > 1 + └─ (0,116): could not prove f(5) > 1 under the assumptions - forall x : int pattern f(x) f(x) > 0 + forall x : int pattern x f(x) > 0 test_checks_are_not_learned: ✗ unknown - (0,130): check f(5) > 1 - └─ (0,130): could not prove f(5) > 1 + (0,127): check f(5) > 1 + └─ (0,133): could not prove f(5) > 1 under the assumptions - forall x : int pattern f(x) f(x) > 0 + forall x : int pattern x f(x) > 0 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_checks_are_not_learned() { check f(5) > 1 check f(5) > 1 @@ -298,6 +273,7 @@ procedure test() { /-- info: test_fail: ✗ counterexample found (0,52): check 5 == 5 && f(5) == 10 + └─ (0,58): could not prove 5 == 5 && f(5) == 10 └─ (0,68): could not prove f(5) == 10 under the assumptions 5 == 5 @@ -312,27 +288,15 @@ procedure test_fail() { /-- -info: test_all_expressions: ✗ unknown - (0,127): check (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern f(y) f(y) || !f(y)) && (forall y : int y > 0 || y <= 0) +info: test_all_expressions: ✗ counterexample found + (0,127): check (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern y f(y) || !f(y)) && (forall y : int pattern y y > 0 || y <= 0) + └─ (0,133): could not prove (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern y f(y) || !f(y)) && (forall y : int pattern y y > 0 || y <= 0) └─ (0,213): could not prove notalwaystrue(1, 2) under the assumptions - forall x : int pattern f(x) f(x) == (x + 1 == 6) - false || true - if true true else false - f(5) + (false || true) && (if true true else false) && f(5) └─ (0,353): it is impossible that 1 + 2 == 4 under the assumptions - forall x : int pattern f(x) f(x) == (x + 1 == 6) - false || true - if true true else false - f(5) - notalwaystrue(1, 2) - 5 == 5 - !(3 == 4) - 2 < 3 - 2 <= 2 - 4 > 3 - 4 >= 4 + (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; @@ -369,16 +333,16 @@ procedure test_all_expressions() { -- Assertions are assumed so further checks pass /-- info: test_assert_helps: ✗ unknown - (0,103): assert f(5) > 1 - └─ (0,103): could not prove f(5) > 1 + (0,100): assert f(5) > 1 + └─ (0,107): could not prove f(5) > 1 under the assumptions - forall x : int pattern f(x) f(x) > 0 + forall x : int pattern x f(x) > 0 test_assert_helps: ✓ verified -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_assert_helps() { assert f(5) > 1 check f(5) > 1 @@ -387,17 +351,16 @@ procedure test_assert_helps() { /-- info: test_assert_with_trace: ✗ unknown - (0,138): assert f(5) > 10 - └─ (0,138): could not prove f(5) > 10 + (0,135): assert f(5) > 10 + └─ (0,142): could not prove f(5) > 10 under the assumptions - forall x : int pattern f(x) f(x) > 0 - f(1) > 0 - f(4) > 0 + forall x : int pattern x f(x) > 0 + f(1) > 0 && f(4) > 0 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_assert_with_trace() { assume f(1) > 0 && f(4) > 0 assert f(5) > 10 @@ -409,46 +372,49 @@ procedure test_assert_with_trace() { --------------------------------------------------------------------- /-- -info: test_reach_bad: ✗ refuted - (0,100): reach f(5) < 0 - └─ (0,100): it is impossible that f(5) < 0 +info: test_reach_bad: ✗ counterexample found + (0,97): reach f(5) < 0 + └─ (0,103): it is impossible that f(5) < 0 under the assumptions - forall x : int pattern f(x) f(x) > 0 + forall x : int pattern x f(x) > 0 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_reach_bad() { reach f(5) < 0 } #end /-- -info: test_reach_good: ✓ reachability unknown +info: test_reach_good: ✗ unknown + (0,98): reach f(5) > 5 + └─ (0,104): it is impossible that f(5) > 5 + under the assumptions + forall x : int pattern x f(x) > 0 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_reach_good() { reach f(5) > 5 } #end /-- -info: test_reach_with_trace: ✗ refuted - (0,137): reach f(5) < 0 - └─ (0,137): it is impossible that f(5) < 0 +info: test_reach_with_trace: ✗ counterexample found + (0,134): reach f(5) < 0 + └─ (0,140): it is impossible that f(5) < 0 under the assumptions - forall x : int pattern f(x) f(x) > 0 - f(1) > 0 - f(4) > 0 + forall x : int pattern x f(x) > 0 + f(1) > 0 && f(4) > 0 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_reach_with_trace() { assume f(1) > 0 && f(4) > 0 reach f(5) < 0 @@ -460,17 +426,20 @@ procedure test_reach_with_trace() { --------------------------------------------------------------------- /-- -info: test_reach_diagnosis: ✗ refuted - (0,106): reach f(5) > 5 && f(5) < 0 - └─ (0,124): it is impossible that f(5) < 0 +info: test_reach_diagnosis: ✗ counterexample found + (0,103): reach f(5) > 5 && f(5) < 0 + └─ (0,109): it is impossible that f(5) > 5 && f(5) < 0 + under the assumptions + forall x : int pattern x f(x) > 0 + └─ (0,121): it is impossible that f(5) < 0 under the assumptions - forall x : int pattern f(x) f(x) > 0 + forall x : int pattern x f(x) > 0 f(5) > 5 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; function f(x : int) : int -axiom forall x : int pattern f(x) f(x) > 0 +axiom forall x : int pattern x f(x) > 0 procedure test_reach_diagnosis() { reach f(5) > 5 && f(5) < 0 } @@ -479,21 +448,12 @@ procedure test_reach_diagnosis() { /-- -info: test_all_expressions: ✗ refuted - (0,127): reach (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern f(y) f(y) || !f(y)) && (forall y : int y > 0 || y <= 0) +info: test_all_expressions: ✗ counterexample found + (0,127): reach (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern y f(y) || !f(y)) && (forall y : int pattern y y > 0 || y <= 0) + └─ (0,133): it is impossible that (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 && 1 + 2 == 4 && 5 - 2 == 3 && 3 * 4 == 12 && 10 div 2 == 5 && 7 mod 3 == 1 && -5 == 0 - 5 && notalwaystrue(3, 4) && (true ==> true) && (forall y : int pattern y f(y) || !f(y)) && (forall y : int pattern y y > 0 || y <= 0) └─ (0,353): it is impossible that 1 + 2 == 4 under the assumptions - forall x : int pattern f(x) f(x) == (x + 1 == 6) - false || true - if true true else false - f(5) - notalwaystrue(1, 2) - 5 == 5 - !(3 == 4) - 2 < 3 - 2 <= 2 - 4 > 3 - 4 >= 4 + (false || true) && (if true true else false) && f(5) && notalwaystrue(1, 2) && 5 == 5 && !(3 == 4) && 2 < 3 && 2 <= 2 && 4 > 3 && 4 >= 4 -/ #guard_msgs in #eval testVerification $ #strata program B3CST; @@ -526,8 +486,9 @@ procedure test_all_expressions() { /-- -info: test_all_expressions: ✗ refuted +info: test_all_expressions: ✗ counterexample found (0,85): reach notalwaystrue(1, 2) && !notalwaystrue(1, 2) && 5 == 4 + └─ (0,91): it is impossible that notalwaystrue(1, 2) && !notalwaystrue(1, 2) && 5 == 4 └─ (0,122): it is impossible that !notalwaystrue(1, 2) under the assumptions notalwaystrue(1, 2) diff --git a/StrataTest/Languages/Core/Tests/ExprEvalTest.lean b/StrataTest/Languages/Core/Tests/ExprEvalTest.lean index f27e19bca..65a91fc13 100644 --- a/StrataTest/Languages/Core/Tests/ExprEvalTest.lean +++ b/StrataTest/Languages/Core/Tests/ExprEvalTest.lean @@ -111,27 +111,27 @@ private def mkRandConst (ty:LMonoTy): IO (Option (LExpr CoreLParams.mono)) match ty with | .tcons "int" [] => let i <- pickInterestingValue 1 [0,1,-1] (pickRandInt 2147483648) - return (.some (.intConst () i)) + return (.some (.intConst Strata.SourceRange.none i)) | .tcons "bool" [] => let rand_flag <- IO.rand 0 1 let rand_flag := rand_flag == 0 - return (.some (.boolConst () rand_flag)) + return (.some (.boolConst Strata.SourceRange.none rand_flag)) | .tcons "real" [] => let i <- pickInterestingValue 1 [0,1,-1] (pickRandInt 2147483648) let n <- IO.rand 1 2147483648 - return (.some (.realConst () (mkRat i n))) + return (.some (.realConst Strata.SourceRange.none (mkRat i n))) | .tcons "string" [] => -- TODO: random string generator - return (.some (.strConst () "a")) + return (.some (.strConst Strata.SourceRange.none "a")) | .tcons "regex" [] => -- TODO: random regex generator - return (.some (.app () - (.op () (⟨"Str.ToRegEx", ()⟩) .none) (.strConst () ".*"))) + return (.some (.app Strata.SourceRange.none + (.op Strata.SourceRange.none (⟨"Str.ToRegEx", ()⟩) .none) (.strConst Strata.SourceRange.none ".*"))) | .bitvec n => let specialvals := [0, 1, -1, Int.ofNat n, (Int.pow 2 (n-1)) - 1, -(Int.pow 2 (n-1))] let i <- pickInterestingValue 3 specialvals (IO.rand 0 ((Nat.pow 2 n) - 1)) - return (.some (.bitvecConst () n (BitVec.ofInt n i))) + return (.some (.bitvecConst Strata.SourceRange.none n (BitVec.ofInt n i))) | _ => return .none @@ -163,8 +163,8 @@ def checkFactoryOps (verbose:Bool): IO Unit := do break else let args := List.map (Option.get!) args - let expr := List.foldl (fun e arg => (.app () e arg)) - (LExpr.op () (⟨e.name.name, ()⟩) .none) args + let expr := List.foldl (fun e arg => (.app Strata.SourceRange.none e arg)) + (LExpr.op Strata.SourceRange.none (⟨e.name.name, ()⟩) .none) args let res <- checkValid expr if ¬ res then if cnt_skipped = 0 then @@ -190,7 +190,7 @@ open Lambda.LTy.Syntax #guard_msgs in #eval (checkValid eb[if #1 == #2 then #false else #true]) /-- info: true -/ #guard_msgs in #eval (checkValid - (.app () (.app () (.op () (⟨"Int.Add", ()⟩) .none) eb[#100]) eb[#50])) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none (⟨"Int.Add", ()⟩) .none) eb[#100]) eb[#50])) -- This may take a while diff --git a/StrataTest/Languages/Core/Tests/FunctionTests.lean b/StrataTest/Languages/Core/Tests/FunctionTests.lean index 11a51e21f..8a335990b 100644 --- a/StrataTest/Languages/Core/Tests/FunctionTests.lean +++ b/StrataTest/Languages/Core/Tests/FunctionTests.lean @@ -20,7 +20,7 @@ open LTy.Syntax LExpr.SyntaxMono typeArgs := ["a", "b"], inputs := [(⟨"w", ()⟩, mty[int]), (⟨"x", ()⟩, mty[%a]), (⟨"y", ()⟩, mty[%b]), (⟨"z", ()⟩, mty[%a])], output := mty[%a], - body := some (LExpr.fvar () (⟨"x", ()⟩) none) } : Function) + body := some (LExpr.fvar Strata.SourceRange.none (⟨"x", ()⟩) none) } : Function) return format type end Core diff --git a/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean b/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean index 1f852aaf4..fe3a34b42 100644 --- a/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean +++ b/StrataTest/Languages/Core/Tests/SMTEncoderDatatypeTest.lean @@ -24,6 +24,8 @@ This file contains unit tests for SMT datatype encoding. namespace Core +private abbrev sr := Strata.SourceRange.none + section DatatypeTests open Lambda @@ -118,7 +120,7 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int]))) + (.fvar sr (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int]))) [optionDatatype] -- Test 2: Recursive datatype (List) - using List type @@ -132,7 +134,7 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int]))) + (.fvar sr (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int]))) [listDatatype] -- Test 3: Multiple constructors - Tree with Leaf and Node @@ -146,7 +148,7 @@ info: (declare-datatype TestTree (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"tree", ()⟩) (.some (.tcons "TestTree" [.bool]))) + (.fvar sr (⟨"tree", ()⟩) (.some (.tcons "TestTree" [.bool]))) [treeDatatype] -- Test 4: Parametric datatype instantiation - List Int @@ -160,7 +162,7 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"intList", ()⟩) (.some (.tcons "TestList" [.int]))) + (.fvar sr (⟨"intList", ()⟩) (.some (.tcons "TestList" [.int]))) [listDatatype] -- Test 5: Parametric datatype instantiation - List Bool (should reuse same datatype) @@ -174,7 +176,7 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"boolList", ()⟩) (.some (.tcons "TestList" [.bool]))) + (.fvar sr (⟨"boolList", ()⟩) (.some (.tcons "TestList" [.bool]))) [listDatatype] -- Test 6: Multi-field constructor - Tree with 3 fields @@ -188,7 +190,7 @@ info: (declare-datatype TestTree (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"intTree", ()⟩) (.some (.tcons "TestTree" [.int]))) + (.fvar sr (⟨"intTree", ()⟩) (.some (.tcons "TestTree" [.int]))) [treeDatatype] -- Test 7: Nested parametric types - List of Option (should declare both datatypes) @@ -205,7 +207,7 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"listOfOption", ()⟩) (.some (.tcons "TestList" [.tcons "TestOption" [.int]]))) + (.fvar sr (⟨"listOfOption", ()⟩) (.some (.tcons "TestList" [.tcons "TestOption" [.int]]))) [optionDatatype, listDatatype] /-! ## Constructor Application Tests -/ @@ -219,7 +221,7 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.op () (⟨"None", ()⟩) (.some (.tcons "TestOption" [.int]))) + (.op sr (⟨"None", ()⟩) (.some (.tcons "TestOption" [.int]))) [optionDatatype] -- Test 9: Some constructor (single-argument) @@ -231,7 +233,7 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"Some", ()⟩) (.some (.arrow .int (.tcons "TestOption" [.int])))) (.intConst () 42)) + (.app sr (.op sr (⟨"Some", ()⟩) (.some (.arrow .int (.tcons "TestOption" [.int])))) (.intConst sr 42)) [optionDatatype] -- Test 10: Cons constructor (multi-argument) @@ -244,10 +246,10 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () - (.app () (.op () (⟨"Cons", ()⟩) (.some (.arrow .int (.arrow (.tcons "TestList" [.int]) (.tcons "TestList" [.int]))))) - (.intConst () 1)) - (.op () (⟨"Nil", ()⟩) (.some (.tcons "TestList" [.int])))) + (.app sr + (.app sr (.op sr (⟨"Cons", ()⟩) (.some (.arrow .int (.arrow (.tcons "TestList" [.int]) (.tcons "TestList" [.int]))))) + (.intConst sr 1)) + (.op sr (⟨"Nil", ()⟩) (.some (.tcons "TestList" [.int])))) [listDatatype] /-! ## Tester Function Tests -/ @@ -264,8 +266,8 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"TestOption..isNone", ()⟩) (.some (.arrow (.tcons "TestOption" [.int]) .bool))) - (.fvar () (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int])))) + (.app sr (.op sr (⟨"TestOption..isNone", ()⟩) (.some (.arrow (.tcons "TestOption" [.int]) .bool))) + (.fvar sr (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int])))) [optionDatatype] -- Test 12: isCons tester @@ -280,8 +282,8 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"TestList..isCons", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) .bool))) - (.fvar () (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) + (.app sr (.op sr (⟨"TestList..isCons", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) .bool))) + (.fvar sr (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) [listDatatype] /-! ## Destructor Function Tests -/ @@ -298,8 +300,8 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"TestOption..val", ()⟩) (.some (.arrow (.tcons "TestOption" [.int]) .int))) - (.fvar () (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int])))) + (.app sr (.op sr (⟨"TestOption..val", ()⟩) (.some (.arrow (.tcons "TestOption" [.int]) .int))) + (.fvar sr (⟨"x", ()⟩) (.some (.tcons "TestOption" [.int])))) [optionDatatype] -- Test 14: Cons head destructor @@ -314,8 +316,8 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"TestList..head", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) .int))) - (.fvar () (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) + (.app sr (.op sr (⟨"TestList..head", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) .int))) + (.fvar sr (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) [listDatatype] -- Test 15: Cons tail destructor @@ -330,8 +332,8 @@ info: (declare-datatype TestList (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.app () (.op () (⟨"TestList..tail", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) (.tcons "TestList" [.int])))) - (.fvar () (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) + (.app sr (.op sr (⟨"TestList..tail", ()⟩) (.some (.arrow (.tcons "TestList" [.int]) (.tcons "TestList" [.int])))) + (.fvar sr (⟨"xs", ()⟩) (.some (.tcons "TestList" [.int])))) [listDatatype] /-! ## Dependency Order Tests -/ @@ -395,7 +397,7 @@ info: (declare-datatype Root ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypes - (.fvar () (⟨"diamondVar", ()⟩) (.some (.tcons "Diamond" []))) + (.fvar sr (⟨"diamondVar", ()⟩) (.some (.tcons "Diamond" []))) [rootDatatype, rightDatatype, leftDatatype, diamondDatatype] -- Test 17: Mutually recursive datatypes (RoseTree/Forest) @@ -436,7 +438,7 @@ info: (declare-datatypes ((RoseTree 1) (Forest 1)) -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypeBlocks - (.fvar () (⟨"tree", ()⟩) (.some (.tcons "RoseTree" [.int]))) + (.fvar sr (⟨"tree", ()⟩) (.some (.tcons "RoseTree" [.int]))) [[roseTreeDatatype, forestDatatype]] -- Test 19: Mix of mutual and non-mutual datatypes @@ -454,7 +456,7 @@ info: (declare-datatype TestOption (par (α) ( -/ #guard_msgs in #eval format <$> toSMTStringWithDatatypeBlocks - (.fvar () (⟨"optionTree", ()⟩) (.some (.tcons "TestOption" [.tcons "RoseTree" [.int]]))) + (.fvar sr (⟨"optionTree", ()⟩) (.some (.tcons "TestOption" [.tcons "RoseTree" [.int]]))) [[optionDatatype], [roseTreeDatatype, forestDatatype]] /-! ## Recursive Function Axiom Tests -/ @@ -472,12 +474,12 @@ def intListDatatype : LDatatype Unit := private def intListTy := LMonoTy.tcons "IntList" [] private def listLenBody : LExpr CoreLParams.mono := - let xs := LExpr.fvar () ⟨"xs", ()⟩ (.some intListTy) - let isNil_xs := LExpr.app () (LExpr.op () ⟨"isNil", ()⟩ (.some (LMonoTy.arrow intListTy .bool))) xs - let tl_xs := LExpr.app () (LExpr.op () ⟨"IntList..tl", ()⟩ (.some (LMonoTy.arrow intListTy intListTy))) xs - let listLen_tl := LExpr.app () (LExpr.op () ⟨"listLen", ()⟩ (.some (LMonoTy.arrow intListTy .int))) tl_xs - let one_plus := LExpr.app () (LExpr.app () (LExpr.op () ⟨"Int.Add", ()⟩ (.some (LMonoTy.arrow .int (LMonoTy.arrow .int .int)))) (LExpr.intConst () 1)) listLen_tl - LExpr.ite () isNil_xs (LExpr.intConst () 0) one_plus + let xs := LExpr.fvar sr ⟨"xs", ()⟩ (.some intListTy) + let isNil_xs := LExpr.app sr (LExpr.op sr ⟨"isNil", ()⟩ (.some (LMonoTy.arrow intListTy .bool))) xs + let tl_xs := LExpr.app sr (LExpr.op sr ⟨"IntList..tl", ()⟩ (.some (LMonoTy.arrow intListTy intListTy))) xs + let listLen_tl := LExpr.app sr (LExpr.op sr ⟨"listLen", ()⟩ (.some (LMonoTy.arrow intListTy .int))) tl_xs + let one_plus := LExpr.app sr (LExpr.app sr (LExpr.op sr ⟨"Int.Add", ()⟩ (.some (LMonoTy.arrow .int (LMonoTy.arrow .int .int)))) (LExpr.intConst sr 1)) listLen_tl + LExpr.ite sr isNil_xs (LExpr.intConst sr 0) one_plus private def listLenFunc : Lambda.LFunc CoreLParams := { name := "listLen", @@ -534,8 +536,8 @@ info: (declare-datatype IntList ( -/ #guard_msgs in #eval format <$> toSMTStringWithRecFunc - (.app () (.op () "listLen" (.some (LMonoTy.arrow intListTy .int))) - (.op () "Nil" (.some intListTy))) + (.app sr (.op sr "listLen" (.some (LMonoTy.arrow intListTy .int))) + (.op sr "Nil" (.some intListTy))) [[intListDatatype]] listLenFunc diff --git a/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean b/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean index a9340a0c4..10f55d9b1 100644 --- a/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean +++ b/StrataTest/Languages/Core/Tests/SMTEncoderTests.lean @@ -16,25 +16,25 @@ open Strata.SMT /-- info: "(define-fun t0 () Bool (forall ((n Int)) (exists ((m Int)) (= n m))))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "n" (.some .int) (LExpr.noTrigger ()) - (.quant () .exist "m" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 1) (.bvar () 0)))) +(.quant Strata.SourceRange.none .all "n" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.quant Strata.SourceRange.none .exist "m" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 1) (.bvar Strata.SourceRange.none 0)))) /-- info: "; x\n(declare-const x Int)\n(define-fun t0 () Bool (exists ((i Int)) (= i x)))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .exist "i" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 0) (.fvar () "x" (.some .int)))) +(.quant Strata.SourceRange.none .exist "i" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 0) (.fvar Strata.SourceRange.none "x" (.some .int)))) /-- info: "; f\n(declare-fun f (Int) Int)\n; x\n(declare-const x Int)\n(define-fun t0 () Bool (exists ((i Int)) (! (= i x) :pattern ((f i)))))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .exist "i" (.some .int) (.app () (.fvar () "f" (.some (.arrow .int .int))) (.bvar () 0)) - (.eq () (.bvar () 0) (.fvar () "x" (.some .int)))) +(.quant Strata.SourceRange.none .exist "i" (.some .int) (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))) (.bvar Strata.SourceRange.none 0)) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 0) (.fvar Strata.SourceRange.none "x" (.some .int)))) /-- @@ -42,23 +42,23 @@ info: "; f\n(declare-fun f (Int) Int)\n; x\n(declare-const x Int)\n(define-fun t -/ #guard_msgs in #eval toSMTTermString - (.quant () .exist "i" (.some .int) (.app () (.fvar () "f" (.some (.arrow .int .int))) (.bvar () 0)) - (.eq () (.app () (.fvar () "f" (.some (.arrow .int .int))) (.bvar () 0)) (.fvar () "x" (.some .int)))) +(.quant Strata.SourceRange.none .exist "i" (.some .int) (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))) (.bvar Strata.SourceRange.none 0)) + (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))) (.bvar Strata.SourceRange.none 0)) (.fvar Strata.SourceRange.none "x" (.some .int)))) /-- info: "Cannot encode expression (f %0)" -/ #guard_msgs in #eval toSMTTermString - (.quant () .exist "i" (.some .int) (.app () (.fvar () "f" (.none)) (.bvar () 0)) - (.eq () (.app () (.fvar () "f" (.some (.arrow .int .int))) (.bvar () 0)) (.fvar () "x" (.some .int)))) +(.quant Strata.SourceRange.none .exist "i" (.some .int) (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.none)) (.bvar Strata.SourceRange.none 0)) + (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))) (.bvar Strata.SourceRange.none 0)) (.fvar Strata.SourceRange.none "x" (.some .int)))) /-- info: "; f\n(declare-const f (arrow Int Int))\n; f\n(declare-fun f@1 (Int) Int)\n; x\n(declare-const x Int)\n(define-fun t0 () Bool (exists ((i Int)) (! (= (f@1 i) x) :pattern (f))))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .exist "i" (.some .int) - (mkTriggerExpr [[.fvar () "f" (.some (.arrow .int .int))]]) - (.eq () (.app () (.fvar () "f" (.some (.arrow .int .int))) (.bvar () 0)) (.fvar () "x" (.some .int)))) +(.quant Strata.SourceRange.none .exist "i" (.some .int) + (mkTriggerExpr [[.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))]]) + (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.fvar Strata.SourceRange.none "f" (.some (.arrow .int .int))) (.bvar Strata.SourceRange.none 0)) (.fvar Strata.SourceRange.none "x" (.some .int)))) (ctx := SMT.Context.default) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -72,8 +72,8 @@ info: "; f\n(declare-fun f (Int Int) Int)\n; x\n(declare-const x Int)\n(define-f -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "m" (.some .int) (.bvar () 0) (.quant () .all "n" (.some .int) (.app () (.app () (.op () "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar () 0)) (.bvar () 1)) - (.eq () (.app () (.app () (.op () "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar () 0)) (.bvar () 1)) (.fvar () "x" (.some .int))))) +(.quant Strata.SourceRange.none .all "m" (.some .int) (.bvar Strata.SourceRange.none 0) (.quant Strata.SourceRange.none .all "n" (.some .int) (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar Strata.SourceRange.none 0)) (.bvar Strata.SourceRange.none 1)) + (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar Strata.SourceRange.none 0)) (.bvar Strata.SourceRange.none 1)) (.fvar Strata.SourceRange.none "x" (.some .int))))) (ctx := SMT.Context.mk #[] #[UF.mk "f" ((TermVar.mk "m" TermType.int) ::(TermVar.mk "n" TermType.int) :: []) TermType.int] #[] #[] [] #[] {} []) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -90,8 +90,8 @@ info: "; f\n(declare-fun f (Int Int) Int)\n; x\n(declare-const x Int)\n(define-f -/ #guard_msgs in -- No valid trigger #eval toSMTTermString - (.quant () .all "m" (.some .int) (.bvar () 0) (.quant () .all "n" (.some .int) (.bvar () 0) - (.eq () (.app () (.app () (.op () "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar () 0)) (.bvar () 1)) (.fvar () "x" (.some .int))))) +(.quant Strata.SourceRange.none .all "m" (.some .int) (.bvar Strata.SourceRange.none 0) (.quant Strata.SourceRange.none .all "n" (.some .int) (.bvar Strata.SourceRange.none 0) + (.eq Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "f" (.some (.arrow .int (.arrow .int .int)))) (.bvar Strata.SourceRange.none 0)) (.bvar Strata.SourceRange.none 1)) (.fvar Strata.SourceRange.none "x" (.some .int))))) (ctx := SMT.Context.mk #[] #[UF.mk "f" ((TermVar.mk "m" TermType.int) ::(TermVar.mk "n" TermType.int) :: []) TermType.int] #[] #[] [] #[] {} []) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -112,9 +112,9 @@ info: "; m\n(declare-const m (Array Int Int))\n(define-fun t0 () (Array Int Int) -/ #guard_msgs in #eval toSMTTermString - (.app () (.app () (.op () "select" (.some (.arrow (mapTy .int .int) (.arrow .int .int)))) - (.fvar () "m" (.some (mapTy .int .int)))) - (.fvar () "i" (.some .int))) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "select" (.some (.arrow (mapTy .int .int) (.arrow .int .int)))) + (.fvar Strata.SourceRange.none "m" (.some (mapTy .int .int)))) + (.fvar Strata.SourceRange.none "i" (.some .int))) (useArrayTheory := true) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -129,10 +129,10 @@ info: "; m\n(declare-const m (Array Int Int))\n(define-fun t0 () (Array Int Int) -/ #guard_msgs in #eval toSMTTermString - (.app () (.app () (.app () (.op () "update" (.some (.arrow (mapTy .int .int) (.arrow .int (.arrow .int (mapTy .int .int)))))) - (.fvar () "m" (.some (mapTy .int .int)))) - (.fvar () "i" (.some .int))) - (.fvar () "v" (.some .int))) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "update" (.some (.arrow (mapTy .int .int) (.arrow .int (.arrow .int (mapTy .int .int)))))) + (.fvar Strata.SourceRange.none "m" (.some (mapTy .int .int)))) + (.fvar Strata.SourceRange.none "i" (.some .int))) + (.fvar Strata.SourceRange.none "v" (.some .int))) (useArrayTheory := true) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -147,12 +147,12 @@ info: "; m\n(declare-const m (Array Int Int))\n(define-fun t0 () (Array Int Int) -/ #guard_msgs in #eval toSMTTermString - (.app () (.app () (.op () "select" (.some (.arrow (mapTy .int .int) (.arrow .int .int)))) - (.app () (.app () (.app () (.op () "update" (.some (.arrow (mapTy .int .int) (.arrow .int (.arrow .int (mapTy .int .int)))))) - (.fvar () "m" (.some (mapTy .int .int)))) - (.fvar () "i" (.some .int))) - (.fvar () "v" (.some .int)))) - (.fvar () "j" (.some .int))) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "select" (.some (.arrow (mapTy .int .int) (.arrow .int .int)))) + (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.app Strata.SourceRange.none (.op Strata.SourceRange.none "update" (.some (.arrow (mapTy .int .int) (.arrow .int (.arrow .int (mapTy .int .int)))))) + (.fvar Strata.SourceRange.none "m" (.some (mapTy .int .int)))) + (.fvar Strata.SourceRange.none "i" (.some .int))) + (.fvar Strata.SourceRange.none "v" (.some .int)))) + (.fvar Strata.SourceRange.none "j" (.some .int))) (useArrayTheory := true) (E := {Env.init with exprEnv := { Env.init.exprEnv with @@ -165,35 +165,35 @@ info: "; m\n(declare-const m (Array Int Int))\n(define-fun t0 () (Array Int Int) /-- info: "(define-fun t0 () Bool (forall (($__bv0 Int)) (exists (($__bv1 Int)) (= $__bv0 $__bv1))))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "" (.some .int) (LExpr.noTrigger ()) - (.quant () .exist "" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 1) (.bvar () 0)))) + (.quant Strata.SourceRange.none .all "" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.quant Strata.SourceRange.none .exist "" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 1) (.bvar Strata.SourceRange.none 0)))) -- Test name clash between two nested quantifiers with same name -- Expected: Inner x should be disambiguated to x@1 /-- info: "(define-fun t0 () Bool (forall ((x Int)) (exists ((x@1 Int)) (= x x@1))))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "x" (.some .int) (LExpr.noTrigger ()) - (.quant () .exist "x" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 1) (.bvar () 0)))) + (.quant Strata.SourceRange.none .all "x" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.quant Strata.SourceRange.none .exist "x" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 1) (.bvar Strata.SourceRange.none 0)))) -- Test x, x, x@1 scenario: nested quantifiers both named "x", then bvar named "x@1" -- Expected: outer x stays x, inner x becomes x@1, bvar "x@1" becomes x@2 /-- info: "(define-fun t0 () Bool (forall ((x Int) (x@1 Int) (x@2 Int)) (= x@2 x)))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "x" (.some .int) (LExpr.noTrigger ()) - (.quant () .all "x" (.some .int) (LExpr.noTrigger ()) - (.quant () .all "x@1" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 0) (.bvar () 2))))) + (.quant Strata.SourceRange.none .all "x" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.quant Strata.SourceRange.none .all "x" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.quant Strata.SourceRange.none .all "x@1" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 0) (.bvar Strata.SourceRange.none 2))))) /-- info: "; x\n(declare-const x Int)\n(define-fun t0 () Bool (forall ((x@1 Int)) (= x@1 x)))\n" -/ #guard_msgs in #eval toSMTTermString - (.quant () .all "x" (.some .int) (LExpr.noTrigger ()) - (.eq () (.bvar () 0) (.fvar () "x" (.some .int)))) + (.quant Strata.SourceRange.none .all "x" (.some .int) (LExpr.noTrigger Strata.SourceRange.none) + (.eq Strata.SourceRange.none (.bvar Strata.SourceRange.none 0) (.fvar Strata.SourceRange.none "x" (.some .int)))) end ArrayTheory diff --git a/StrataTest/Languages/Core/Tests/SarifOutputTests.lean b/StrataTest/Languages/Core/Tests/SarifOutputTests.lean index 4f8a4d6bf..67e243343 100644 --- a/StrataTest/Languages/Core/Tests/SarifOutputTests.lean +++ b/StrataTest/Languages/Core/Tests/SarifOutputTests.lean @@ -51,7 +51,7 @@ def makeObligation (label : String) (md : MetaData Expression := #[]) : ProofObl { label := label property := .assert assumptions := [] - obligation := Lambda.LExpr.boolConst () true + obligation := Lambda.LExpr.boolConst Strata.SourceRange.none true metadata := md } /-- Create a VCResult for testing -/ @@ -247,7 +247,7 @@ def makeVCResult (label : String) (outcome : Outcome) let cex : List (Core.Expression.Ident × Strata.SMT.Term) := [({ name := "x", metadata := () }, .prim (.int 42))] let lexprCex : LExprModel := - [({ name := "x", metadata := () }, .intConst () 42)] + [({ name := "x", metadata := () }, .intConst Strata.SourceRange.none 42)] let md := makeMetadata "/test/cex.st" 25 3 let files := makeFilesMap "/test/cex.st" let vcr := makeVCResult "cex_obligation" .fail (.sat cex) md lexprCex diff --git a/StrataTest/Languages/Python/expected_incremental/test_incremental_simple.expected b/StrataTest/Languages/Python/expected_incremental/test_incremental_simple.expected new file mode 100644 index 000000000..76c041744 --- /dev/null +++ b/StrataTest/Languages/Python/expected_incremental/test_incremental_simple.expected @@ -0,0 +1,9 @@ +procedure __main__: + non-CoreSMT: 🚨 Statement not in CoreSMT subset: if-then-else statement is not in the CoreSMT subset +procedure main: + assert(16): ✅ pass (line 2, col 4) + assert(53): ❌ fail (line 4, col 4) + └─ it is impossible that x == 3 + under the assumptions + 5 == 3 + x + x == 2 diff --git a/StrataTest/Languages/Python/run_py_analyze.sh b/StrataTest/Languages/Python/run_py_analyze.sh index 75bfc4efd..34a660345 100755 --- a/StrataTest/Languages/Python/run_py_analyze.sh +++ b/StrataTest/Languages/Python/run_py_analyze.sh @@ -1,19 +1,49 @@ #!/bin/bash -# Usage: ./run_py_analyze.sh [laurel] -# Run without arguments for pyAnalyze, with "laurel" for pyAnalyzeLaurel +# Usage: ./run_py_analyze.sh [--incremental] [laurel] +# Run without arguments for pyAnalyze +# --incremental: Use pyAnalyzeLaurel --incremental +# laurel: Use pyAnalyzeLaurel failed=0 -mode="${1:-core}" +incremental=false +mode="core" + +# Parse flags +while [[ $# -gt 0 ]]; do + case $1 in + --incremental) + incremental=true + shift + ;; + laurel) + mode="laurel" + shift + ;; + *) + echo "Unknown argument: $1" + exit 1 + ;; + esac +done if [ "$mode" = "laurel" ]; then command="pyAnalyzeLaurel" expected_dir="expected_laurel" skip_tests="test_datetime" + if [ "$incremental" = true ]; then + command="$command --incremental" + expected_dir="expected_incremental" + skip_tests="" + fi else command="pyAnalyze" expected_dir="expected_non_laurel" skip_tests="" + if [ "$incremental" = true ]; then + echo "Error: --incremental requires laurel mode" + exit 1 + fi fi (cd ../../.. && lake exe strata --help > /dev/null) diff --git a/StrataTest/Languages/Python/run_py_analyze_sarif.py b/StrataTest/Languages/Python/run_py_analyze_sarif.py index 3e39da832..fc639f9ec 100755 --- a/StrataTest/Languages/Python/run_py_analyze_sarif.py +++ b/StrataTest/Languages/Python/run_py_analyze_sarif.py @@ -19,7 +19,7 @@ f"tests/{p.name}" for p in (Path(__file__).resolve().parent / "tests").glob("test_*.py") ) -BOTH_SKIP = {"test_foo_client_folder", "test_invalid_client_type", "test_unsupported_config"} +BOTH_SKIP = {"test_foo_client_folder", "test_invalid_client_type", "test_unsupported_config", "test_incremental_simple"} SKIP_TESTS = BOTH_SKIP | {"test_class_field_use"} SKIP_TESTS_LAUREL = BOTH_SKIP | {"test_datetime"} diff --git a/StrataTest/Languages/Python/tests/test_incremental_simple.py b/StrataTest/Languages/Python/tests/test_incremental_simple.py new file mode 100644 index 000000000..0f3c195d2 --- /dev/null +++ b/StrataTest/Languages/Python/tests/test_incremental_simple.py @@ -0,0 +1,8 @@ +def main(): + assert 1 + 1 == 2 + x: int = 2 + assert 5 == 3 + x and x == 3 + + +if __name__ == "__main__": + main() diff --git a/StrataTest/Transform/ProcedureInlining.lean b/StrataTest/Transform/ProcedureInlining.lean index 3d38a17f9..b80945c60 100644 --- a/StrataTest/Transform/ProcedureInlining.lean +++ b/StrataTest/Transform/ProcedureInlining.lean @@ -64,18 +64,32 @@ private def IdMap.lblMapsTo (map:IdMap) (fr:String) (to:String): Bool := private def substExpr (e1:Expression.Expr) (map:Map String String) (isReverse: Bool) := map.foldl (fun (e:Expression.Expr) ((i1,i2):String × String) => - -- old_id has visibility of temp because the new local variables were - -- created by CoreGenM. - -- All variables now have Unit metadata; we substitute by name. - let old_id : Expression.Ident := { name := i1, metadata := () } - let new_expr : Expression.Expr := .fvar () { name := i2, metadata := () } .none + let old_id:Expression.Ident := { name := i1, metadata := () } + + let new_expr:Expression.Expr := .fvar Strata.SourceRange.none + { name := i2, metadata := () } .none e.substFvar old_id new_expr) e1 +/-- Normalize an expression for alpha-equivalence: erase types and metadata. -/ +private def normalizeExpr (e : Expression.Expr) : Expression.Expr := + -- eraseTypes preserves metadata; we additionally reset all metadata to none for comparison + let rec go : Expression.Expr → Expression.Expr + | .const _ c => .const Strata.SourceRange.none c + | .op _ o _ => .op Strata.SourceRange.none o none + | .fvar _ x _ => .fvar Strata.SourceRange.none x none + | .bvar _ i => .bvar Strata.SourceRange.none i + | .abs _ name ty e => .abs Strata.SourceRange.none name ty (go e) + | .quant _ qk name _ tr e => .quant Strata.SourceRange.none qk name .none (go tr) (go e) + | .app _ e1 e2 => .app Strata.SourceRange.none (go e1) (go e2) + | .ite _ c t f => .ite Strata.SourceRange.none (go c) (go t) (go f) + | .eq _ e1 e2 => .eq Strata.SourceRange.none (go e1) (go e2) + go e + private def alphaEquivExprs (e1 e2: Expression.Expr) (map:IdMap) : Bool := - (substExpr e1 (map.vars.fst) false).eraseTypes == e2.eraseTypes && - (substExpr e2 (map.vars.snd) true).eraseTypes == e1.eraseTypes + normalizeExpr (substExpr e1 (map.vars.fst) false) == normalizeExpr e2 && + normalizeExpr (substExpr e2 (map.vars.snd) true) == normalizeExpr e1 private def alphaEquivExprsOpt (e1 e2: Option Expression.Expr) (map:IdMap) : Except Format Bool := diff --git a/StrataVerify.lean b/StrataVerify.lean index b2b72642a..416fdede6 100644 --- a/StrataVerify.lean +++ b/StrataVerify.lean @@ -7,8 +7,12 @@ -- Executable for verifying a Strata program from a file. import Strata.Languages.Core.Verifier import Strata.Languages.Core.SarifOutput +import Strata.Languages.Core.CoreSMT.Verifier +import Strata.Languages.Core.CoreSMT.State import Strata.Languages.C_Simp.Verify -import Strata.Languages.B3.Verifier.Program +import Strata.Languages.B3.Verifier +import Strata.DL.SMT.Solver +import Strata.DL.SMT.SolverInterface import Strata.Util.IO import Std.Internal.Parsec @@ -40,6 +44,7 @@ def parseOptions (args : List String) : Except Std.Format (VerifyOptions × Stri | .none => .error f!"Invalid number of seconds: {secondsStr}" | .some n => go {opts with solverTimeout := n} rest procs | opts, "--reach-check" :: rest, procs => go {opts with reachCheck := true} rest procs + | opts, "--incremental" :: rest, procs => go {opts with incremental := true} rest procs | opts, [file], procs => pure (opts, file, procs) | _, [], _ => .error "StrataVerify requires a file as input" | _, args, _ => .error f!"Unknown options: {args}" @@ -96,25 +101,40 @@ def main (args : List String) : IO UInt32 := do C_Simp.verify pgm opts else if file.endsWith ".b3.st" || file.endsWith ".b3cst.st" then -- B3 verification (different model, handle inline) - let ast ← match B3.Verifier.programToB3AST pgm with + let ast ← match Strata.B3.Verifier.programToB3AST pgm with | Except.error msg => throw (IO.userError s!"Failed to convert to B3 AST: {msg}") | Except.ok ast => pure ast - let solver ← B3.Verifier.createInteractiveSolver opts.solver - let reports ← B3.Verifier.programToSMT ast solver + let solver ← Strata.B3.Verifier.createInteractiveSolver opts.solver + let reports ← Strata.B3.Verifier.programToSMT ast solver -- B3 uses a different result format, print directly and return empty array for report in reports do IO.println s!"\nProcedure: {report.procedureName}" - for (result, _) in report.results do - let marker := if result.result.isError then "✗" else "✓" - let desc := match result.result with - | .error .counterexample => "counterexample found" - | .error .unknown => "unknown" - | .error .refuted => "refuted" - | .success .verified => "verified" - | .success .reachable => "reachable" - | .success .reachabilityUnknown => "reachability unknown" + for result in report.results do + let marker := if result.outcome != .pass then "✗" else "✓" + let desc := match result.outcome with + | .fail => "counterexample found" + | .unknown => "unknown" + | .pass => "verified" + | .implementationError msg => s!"error: {msg}" IO.println s!" {marker} {desc}" pure #[] -- Return empty array since B3 prints directly + else if opts.incremental then + -- Interactive (in-memory) CoreSMT verification + let (coreProgram, errors) := Core.getProgram pgm inputCtx + if !errors.isEmpty then throw (IO.userError s!"DDM Transform Error: {repr errors}") + let solver ← Strata.B3.Verifier.createInteractiveSolver opts.solver + let solverInterface ← Strata.SMT.mkSolverInterfaceFromSolver solver + let config : Core.CoreSMT.CoreSMTConfig := { accumulateErrors := true } + let state := Core.CoreSMT.CoreSMTState.init solverInterface config + let stmts := coreProgram.decls.filterMap fun d => match d with + | .proc p _ => + if p.header.inputs.isEmpty && p.header.outputs.isEmpty then + some (Imperative.Stmt.block p.header.name.name + (Core.CoreSMT.removeUnusedVarsStmts p.body) .empty) + else none + | _ => none + let (_, _, results) ← Core.CoreSMT.verify state Core.Env.init stmts + pure results.toArray else verify pgm inputCtx proceduresToVerify opts catch e => diff --git a/Tools/monitor_pr.sh b/Tools/monitor_pr.sh new file mode 100755 index 000000000..98772f2e1 --- /dev/null +++ b/Tools/monitor_pr.sh @@ -0,0 +1,219 @@ +#!/usr/bin/env bash +# Copyright Strata Contributors +# +# SPDX-License-Identifier: Apache-2.0 OR MIT + +# Sentinel — Continuously monitor a PR's CI, merge conflicts, and comments. +# +# Runs silently until the agent needs to act. Only exits when: +# - CI failure (exit 1) — includes filtered error log +# - Merge conflict with main (exit 2) +# - New comments/reviews on the PR (exit 3) — includes the new comments +# On CI success, merges main if needed and keeps monitoring. +# +# Usage: +# ./Tools/monitor_pr.sh [OPTIONS] +# +# Options: +# -b, --branch BRANCH Branch name (default: current git branch) +# -r, --repo REPO GitHub repo owner/name (default: auto-detect from origin) +# -i, --interval SECS Poll interval in seconds (default: 30, 10 when CI is running) +# -n, --dry-run Don't merge/push, just report what would happen +# -h, --help Show this help + +set -euo pipefail + +BRANCH="" +REPO="" +INTERVAL=30 +DRY_RUN=false + +while [[ $# -gt 0 ]]; do + case "$1" in + -b|--branch) BRANCH="$2"; shift 2 ;; + -r|--repo) REPO="$2"; shift 2 ;; + -i|--interval) INTERVAL="$2"; shift 2 ;; + -n|--dry-run) DRY_RUN=true; shift ;; + -h|--help) sed -n '/^# Sentinel/,/^[^#]/{ /^#/{ s/^# \?//; p } }' "$0"; exit 0 ;; + *) echo "Unknown option: $1"; exit 4 ;; + esac +done + +if [[ -z "$BRANCH" ]]; then + BRANCH=$(git rev-parse --abbrev-ref HEAD) + [[ "$BRANCH" == "main" || "$BRANCH" == "HEAD" ]] && { echo "ERROR: Not on a feature branch. Use -b." >&2; exit 4; } +fi + +if [[ -z "$REPO" ]]; then + REPO=$(git remote get-url origin 2>/dev/null | sed -E 's#.+github\.com[:/]([^/]+/[^/.]+)(\.git)?$#\1#') + [[ -z "$REPO" ]] && { echo "ERROR: Cannot detect repo. Use -r." >&2; exit 4; } +fi + +GH=("gh" "-R" "$REPO") +PR_NUMBER=$("${GH[@]}" pr list --head "$BRANCH" --json number --jq '.[0].number' 2>/dev/null || true) +MY_LOGIN=$(gh api user --jq '.login' 2>/dev/null || echo "") + +echo "Monitoring: branch=$BRANCH repo=$REPO pr=#${PR_NUMBER:-none} interval=${INTERVAL}s dry-run=$DRY_RUN" +echo "The script is going to stop whenever: (1) a CI job fails, (2) a merge conflict with main is detected, or (3) new comments appear on the PR." +echo "On CI success, it merges main if needed and keeps monitoring silently." + +# --- Helpers --- +comment_count() { + [[ -z "$PR_NUMBER" ]] && { echo "0"; return; } + local a b c + a=$("${GH[@]}" pr view "$PR_NUMBER" --json comments --jq '.comments | length' 2>/dev/null || echo 0) + b=$(gh api "repos/$REPO/pulls/$PR_NUMBER/comments" --jq 'length' 2>/dev/null || echo 0) + c=$("${GH[@]}" pr view "$PR_NUMBER" --json reviews --jq '.reviews | length' 2>/dev/null || echo 0) + echo $((a + b + c)) +} + +print_new_comments() { + local since="$1" + echo "=== New PR comments ===" + "${GH[@]}" pr view "$PR_NUMBER" --json comments \ + --jq ".comments[] | select(.createdAt > \"$since\") | select(.author.login != \"$MY_LOGIN\") | \"[\(.author.login)] \(.body[0:200])\"" 2>/dev/null || true + echo "=== New inline comments ===" + gh api "repos/$REPO/pulls/$PR_NUMBER/comments" \ + --jq ".[] | select(.created_at > \"$since\") | select(.user.login != \"$MY_LOGIN\") | \"[\(.user.login)] \(.path):\(.line // \"general\") - \(.body[0:200])\"" 2>/dev/null || true + echo "=== New reviews ===" + "${GH[@]}" pr view "$PR_NUMBER" --json reviews \ + --jq ".reviews[] | select(.submittedAt > \"$since\") | select(.author.login != \"$MY_LOGIN\") | \"[\(.author.login)] \(.state) \(.body[0:200])\"" 2>/dev/null || true +} + +print_ci_failure() { + local run_id="$1" + "${GH[@]}" run view "$run_id" --json jobs \ + --jq '.jobs[] | select(.conclusion == "failure") | "FAILED job: \(.name)\n step: \(.steps[] | select(.conclusion == "failure") | .name)"' 2>/dev/null || true + echo "--- error log ---" + local log + log=$("${GH[@]}" run view "$run_id" --log-failed 2>/dev/null || true) + if echo "$log" | grep -q "still in progress"; then + echo "(Logs not yet available — run still in progress. Re-run this script after the run completes for full error details.)" + else + echo "$log" \ + | sed 's/^[^\t]*\t[^\t]*\t//; s/\x1b\[[0-9;]*m//g; s/^[0-9T:.Z-]* //' \ + | grep -E '\[FAIL\]|^error:|^- |^[+] |Error Message:|Assert\.|Expected:|Actual:|^Failed!|##\[error\]|^Some required' \ + | grep -v '##\[group\]' \ + | head -80 || true + fi +} + +INITIAL_COMMENTS=$(comment_count) +START_TIME=$(date -u +"%Y-%m-%dT%H:%M:%SZ") +MERGE_COUNT=0 + +stop() { + echo "(Merged with main $MERGE_COUNT time(s) during monitoring)" + echo "After addressing the above, re-run this script to continue monitoring." + exit "$1" +} + +GREEN_SHA="" + +# --- Main loop (silent until actionable) --- +while true; do + # 1. New comments? + if [[ -n "$PR_NUMBER" ]]; then + cur=$(comment_count) + if [[ "$cur" -gt "$INITIAL_COMMENTS" ]]; then + echo "NEW_COMMENTS ($INITIAL_COMMENTS -> $cur)" + print_new_comments "$START_TIME" + echo "ACTION: Review the comments above, address them, then commit and push." + stop 3 + fi + fi + + # 2. PR merged/closed? Merge conflict? (check before CI so conflicts aren't masked by old failures) + if [[ -n "$PR_NUMBER" ]]; then + PR_STATE=$("${GH[@]}" pr view "$PR_NUMBER" --json state,mergeable --jq '.state + "|" + .mergeable' 2>/dev/null || echo "UNKNOWN|UNKNOWN") + STATE="${PR_STATE%%|*}" + MERGEABLE="${PR_STATE##*|}" + if [[ "$STATE" == "MERGED" ]]; then + echo "PR_MERGED: PR #$PR_NUMBER has been merged." + echo "ACTION: No further action needed on this branch." + stop 0 + fi + if [[ "$STATE" == "CLOSED" ]]; then + echo "PR_CLOSED: PR #$PR_NUMBER has been closed." + echo "ACTION: Investigate why the PR was closed." + stop 0 + fi + if [[ "$MERGEABLE" == "CONFLICTING" ]]; then + echo "CONFLICT: Branch '$BRANCH' has merge conflicts with main." + echo "ACTION: Run 'git fetch origin main:main && git merge main', resolve conflicts, then commit and push." + stop 2 + fi + fi + + # 3. CI status (skip if last green run matches current HEAD) + LOCAL_SHA=$(git rev-parse HEAD 2>/dev/null) + if [[ "$GREEN_SHA" != "$LOCAL_SHA" ]]; then + RUN_JSON=$("${GH[@]}" run list --branch "$BRANCH" --limit 1 --json databaseId,status,conclusion,headSha 2>/dev/null || echo "[]") + RUN_ID=$(echo "$RUN_JSON" | jq -r '.[0].databaseId // empty') + + if [[ -n "$RUN_ID" ]]; then + STATUS=$(echo "$RUN_JSON" | jq -r '.[0].status') + CONCLUSION=$(echo "$RUN_JSON" | jq -r '.[0].conclusion') + RUN_SHA=$(echo "$RUN_JSON" | jq -r '.[0].headSha') + + # In-progress: check for early job failure + if [[ "$STATUS" != "completed" ]]; then + failed=$("${GH[@]}" run view "$RUN_ID" --json jobs \ + --jq '[.jobs[] | select(.conclusion == "failure")] | length' 2>/dev/null || echo 0) + if [[ "$failed" -gt 0 ]]; then + echo "CI_FAILURE: Run $RUN_ID on commit $RUN_SHA (in progress, $failed job(s) already failed)" + print_ci_failure "$RUN_ID" + echo "ACTION: Fix the failing test(s) above, commit and push." + stop 1 + fi + $DRY_RUN && { echo "DRY_RUN: CI in progress, no failures yet."; exit 0; } + sleep 10; continue + fi + + # Completed with failure + if [[ "$CONCLUSION" != "success" ]]; then + echo "CI_FAILURE: Run $RUN_ID on commit $RUN_SHA concluded '$CONCLUSION'" + print_ci_failure "$RUN_ID" + echo "ACTION: Fix the failing test(s) above, commit and push." + stop 1 + fi + + # Green — but only trust it if it ran against our current HEAD + if [[ "$RUN_SHA" == "$LOCAL_SHA" ]]; then + GREEN_SHA="$LOCAL_SHA" + fi + fi + fi + + # 3. CI is green (or no run yet) — check if main needs merging + if ! $DRY_RUN; then + # Safety: verify we're on the expected branch + CURRENT=$(git rev-parse --abbrev-ref HEAD 2>/dev/null) + if [[ "$CURRENT" != "$BRANCH" ]]; then + echo "UNEXPECTED: Local branch is '$CURRENT' but expected '$BRANCH'." + echo "ACTION: Investigate why the branch changed and re-run the script." + stop 4 + fi + # Pull remote changes to the branch + git pull --ff-only origin "$BRANCH" >/dev/null 2>&1 || true + # Merge main if ahead + git fetch origin main:main 2>/dev/null + if ! git merge-base --is-ancestor main HEAD 2>/dev/null; then + if git merge main --no-edit >/dev/null 2>&1; then + git push origin "$BRANCH" >/dev/null 2>&1 + MERGE_COUNT=$((MERGE_COUNT + 1)) + # New push triggers new CI; reset comment baseline + INITIAL_COMMENTS=$(comment_count) + START_TIME=$(date -u +"%Y-%m-%dT%H:%M:%SZ") + else + git merge --abort 2>/dev/null || true + echo "CONFLICT: Merge conflict when merging main into '$BRANCH'. Merge was aborted, repo is clean." + echo "ACTION: Run 'git merge main', resolve conflicts, then commit and push." + stop 2 + fi + fi + fi + + $DRY_RUN && { echo "DRY_RUN: One pass complete, no actionable issues found."; exit 0; } + sleep "$INTERVAL" +done