cli, cps interpreter, stack vm, closure-conversion, fixes, tests, LOL

test/Gyehoek/Test/CPS/Eval.hs

@@ -0,0 +1,56 @@
+module Gyehoek.Test.CPS.Eval (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
+import Gyehoek.CPS.Eval qualified as Sut
+import Data.List (List)
+
+
+root :: IO TestTree
+root = pure . testGroup "cps interpreter" $
+  [ prim
+  , testCase "halt with constant" do
+      evalsTo [ObjImm (ImmInt 123)] [cps|
+        (continue halt 123)
+      |]
+  , testCase "identity cont" do
+      evalsTo [ObjImm (ImmInt 154)] [cps|
+        (letrec ((id (κ (x)
+                       (continue halt x))))
+          (continue id 154))
+      |]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 456)] [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 81)] [cps|
+        (letrec ((square (λ (x ktail)
+                           (prim (* x x)
+                             (κ (r) (continue ktail r))))))
+          (square 9 halt))
+      |]
+  ]
+
+evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
+evalsTo rs p = Sut.evalProgram p @?= rs
+
+prim = testGroup "primitives"
+  [ testGroup "arith"
+    [ testCase "basic 1" do
+        evalsTo [ObjImm (ImmInt 20)] [cps|
+          (prim (* 4 5)
+            (κ (x) (continue halt x)))
+          |]
+    , testCase "basic 2" do
+        evalsTo [ObjImm (ImmInt 35)] [cps|
+          (prim (* 2 16)
+            (κ (x) (prim (+ x 3)
+                      (κ (r) (continue halt r)))))
+          |]
+    ]
+  ]

test/Gyehoek/Test/Golden.hs

@@ -25,10 +25,11 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [ "adder"
-  , "let-fn"
-  , "callcc-nested1" -- requires closure-conversion
-  ]
+  []
+  -- [ "adder"
+  -- , "let-fn"
+  -- , "callcc-nested1" -- requires closure-conversion
+  -- ]
 
 root :: IO TestTree
 root = do

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -0,0 +1,27 @@
+module Gyehoek.Test.Scheme.Syntax (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.Scheme.Syntax (scm)
+import Gyehoek.Scheme.Syntax qualified as Sut
+
+
+root :: IO TestTree
+root = pure . testGroup "scheme syntax" $
+  [ freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testGroup "free"
+  [ testCase "lambda" do
+    Sut.free' [scm|
+      (lambda (x y z k) (f x b a))
+    |] @=? ["f","b","a"]
+  , testCase "exp" do
+    Sut.free' [scm|
+      (letrec ((x (lambda (r) (f a y)))
+               (y (lambda (r b) (f b x))))
+        (g x y z))
+    |] @=? ["f","a","g","z"]
+  ]

test/Main.hs

@@ -5,8 +5,10 @@ import Test.Tasty.Silver.Interactive (defaultMain)
 import qualified Gyehoek.Test.Golden
 import qualified Gyehoek.Test.Sexp
 import qualified Gyehoek.Test.CPS.Syntax
+import qualified Gyehoek.Test.Scheme.Syntax
 import qualified Gyehoek.Test.Stack.VM
 import qualified Gyehoek.Test.CPS.Stackify
+import qualified Gyehoek.Test.CPS.Eval
 
 
 main :: IO ()
@@ -17,7 +19,9 @@ root = testGroup "test" <$> sequenceA
   [ Gyehoek.Test.Golden.root
   , Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
+  , Gyehoek.Test.Scheme.Syntax.root
   , Gyehoek.Test.Stack.VM.root
   , Gyehoek.Test.CPS.Stackify.root
+  , Gyehoek.Test.CPS.Eval.root
   ]