msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

works albeit comically inefficiently

Browse Source
This commit is contained in:
msyds
2026-08-30 02:12:16 -06:00
parent e7c0ae9161
commit a09c00badd
8 changed files with 185 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files
test/Gyehoek/Test/CPS/Stackify.hs
+25 -20
View File
@@ -20,42 +20,44 @@ test_stackify =
, procedure
]
evalsTo :: List Obj -> Sut.Exp -> Assertion
evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
where
e' = e & CPS.MkLambda [] "_ktail"
& CPS.MkProgram
& Sut.stackifyProgram & runGenSym & runPureEff
e' = e & Sut.stackifyProgram & runGenSym & runPureEff
trivialReturn = testGroup "trivial return"
[ testCase "return int" do
evalsTo [ObjImm (ImmInt 4)]
[cps|(continue halt 4)|]
[cps|(λ (ktail) (continue ktail 4))|]
, testCase "return bool" do
evalsTo [ObjImm (ImmBool True)]
[cps|(continue halt #t)|]
[cps|(λ (ktail) (continue ktail #t))|]
evalsTo [ObjImm (ImmBool False)]
[cps|(continue halt #f)|]
[cps|(λ (ktail) (continue ktail #f))|]
]
tailCall = testGroup "tail call"
[ testCase "square" do
evalsTo [ObjImm (ImmInt 16)]
[cps|(letrec ((square (λ (x ktail)
(prim (* x x)
(κ (x0) (continue ktail x0))))))
(square 4 halt))|]
evalsTo [ObjImm (ImmInt 16)] [cps|
(λ (ktail0)
(letrec ((square (λ (x ktail)
(prim (* x x)
(κ (x0) (continue ktail x0))))))
(square 4 halt)))
|]
]
prim = testGroup "prim"
[ testCase "multiply" do
evalsTo [ObjImm (ImmInt 20)]
[cps|(prim (* 4 5)
(κ (x) (continue halt x)))|]
[cps|(λ (ktail0)
(prim (* 4 5)
(κ (x) (continue ktail0 x))))|]
, testCase "add" do
evalsTo [ObjImm (ImmInt 9)]
[cps|(prim (+ 4 5)
(κ (x) (continue halt x)))|]
[cps|(λ (ktail0)
(prim (+ 4 5)
(κ (x) (continue ktail0 x))))|]
-- , testGroup "call/cc"
-- [ testCase "trivial" do
-- evalsTo [ObjImm (ImmInt 123)]
@@ -66,14 +68,17 @@ prim = testGroup "prim"
condition = testCase "if" do
evalsTo [ObjImm (ImmInt 123)]
[cps|(if #t (continue halt 123) (continue halt 456))|]
[cps|(λ (ktail0)
(if #t (continue ktail0 123) (continue ktail0 456)))|]
evalsTo [ObjImm (ImmInt 456)]
[cps|(if #f (continue halt 123) (continue halt 456))|]
[cps|(λ (ktail0)
(if #f (continue ktail0 123) (continue ktail0 456)))|]
procedure = testGroup "procedure"
[ testCase "factorial" do
evalsTo [ObjImm (ImmInt 720)]
[cps|(letrec ((fac (λ (n ktail)
[cps|(λ (ktail0)
(letrec ((fac (λ (n ktail)
(prim (zero? n)
(κ (x0)
(if x0
@@ -86,5 +91,5 @@ procedure = testGroup "procedure"
(κ (x3)
(continue ktail x3))))))
(fac x1 fac-k0))))))))))
(fac 6 halt))|]
(fac 6 halt)))|]
]
test/Gyehoek/Test/Stack/VM.hs
+6 -8
View File
@@ -76,8 +76,7 @@ test_root = testGroup "stack machine"
(tail-call 1))
(define $square
(pop! %x)
(prim %x2 (* %x %x))
(push! %x2)
(prim (* %x %x))
(return 1))
|]
, testGroup "factorial"
@@ -90,20 +89,19 @@ test_root = testGroup "stack machine"
(tail-call 1))
(define $fac
(load %n 0)
(prim %x0 (zero? %n))
(prim (zero? %n))
(pop! %x0)
(if %x0
(then (push! 1)
(return 1))
(else (prim %x1 (- %n 1))
(push! $fac-c0)
(else (push! $fac-c0)
(push! $fac)
(push! %x1)
(prim (- %n 1))
(call 1))))
(define $fac-c0
(pop! %x2)
(pop! %n)
(prim %x3 (* %n %x2))
(push! %x3)
(prim (* %n %x2))
(return 1))
|]
mkcase n = testCase [i|#{n}|] do