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

src/Gyehoek/Stack/Syntax.hs

@@ -10,6 +10,7 @@ module Gyehoek.Stack.Syntax
   , Lit(..)
   , Obj(..)
   , Imm(..)
+  , Hob(..)
   , Prim(..)
   , Name
   , pattern ValLabel
@@ -34,6 +35,7 @@ import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
 import Control.DeepSeq (NFData)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
 
 
 newtype Program = MkProgram
@@ -79,18 +81,6 @@ data Val
 pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
-data Imm
-  = ImmInt Int
-  | ImmBool Bool
-  | ImmLabel Name
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
-data Obj
-  = ObjImm Imm
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
 
 --- sexp work
 
@@ -118,13 +108,6 @@ instance SexpIso Val where
     $ With (S.sexpIso >>>)
     $ End
 
-instance SexpIso Imm where
-  sexpIso = match
-    $ With (S.sexpIso @Int >>>)
-    $ With (Gyehoek.Sexp.schemeBool >>>)
-    $ With (labelName >>>)
-    $ End
-
 instance SexpIso Block where
   sexpIso = with (block >>>)
     where
@@ -143,8 +126,3 @@ regName :: S.SexpGrammar Name
 regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
   (S.expected "register")
   (prefixed @Name "%")
-
-labelName :: S.SexpGrammar Name
-labelName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
-        (S.expected "label")
-        (prefixed @Name "$")

src/Gyehoek/Stack/VM.hs

@@ -57,6 +57,18 @@ stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimMul x y -> arith_binop (*) x y
   PrimSub x y -> arith_binop (-) x y
   PrimDiv x y -> arith_binop div x y
+  PrimMakeClosure f env ->
+    case f of
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      _ -> error [i|expected label, got #{f}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
+      _ -> error [i|expected closure, got #{env}|]
+  PrimEnvRef env n ->
+    case env of
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
+      _ -> error [i|expected closure, got #{env}|]
   x -> error [i|unimplemented prim: #{p}|]
   where
     ret v = vm & #registers . at r ?~ v
@@ -69,8 +81,8 @@ stepI e vm (Pop r) = case vm ^. #stack of
   (x:xs) -> vm & #registers . at r ?~ x
                & #stack .~ xs
 
-stepI e vm (PopCont r) = case vm ^. #kstack of
-  [] -> error "empty stack"
+stepI e vm ins@(PopCont r) = case vm ^. #kstack of
+  [] -> error [i|empty cont stack: #{ins}|]
   (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
                & #kstack .~ xs
 
@@ -141,3 +153,5 @@ writeObj (ObjImm im) = case im of
   ImmBool True -> "#t"
   ImmBool False -> "#f"
   ImmLabel l -> "#<procedure>"
+writeObj (ObjHob h) = case h of
+  HobClosure code env -> "#<procedure>"