dotted list and such

golden/exec/begin-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/exec/callcc-early-exit-6/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 12

golden/exec/callcc-early-exit-6/source.scm

@@ -0,0 +1,4 @@
+(* 2 (call/cc
+      (λ (k)
+        (begin (k 6)
+               3))))

golden/exec/complicated-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 155

golden/exec/complicated-1/source.scm

@@ -0,0 +1,10 @@
+(letrec ((factorial (λ (n)
+                      (if (zero? n)
+                          1
+                          (* n (factorial (- n 1)))))))
+  (letrec ((sum-of-factorials
+            (λ (n)
+              (if (zero? n)
+                  0
+                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
+    (+ 2 (sum-of-factorials 5))))

golden/exec/cons-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (6 . 7)

golden/exec/cons-1/source.scm

@@ -0,0 +1 @@
+(cons 6 7)

src/Gyehoek/CPS/Stackify.hs

@@ -47,21 +47,15 @@ stackify
   :: (GenSym :> es, Stackify :> es)
   => Env -> Exp -> Eff es BlockBuilder
 
-stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
-  let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
-  let ls = live g kap
-  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
-  emitRoutine $
-    Stk.MkRoutine f xs . buildBlock $
-      -- pop in the opposite order we push
-      Code [Stk.Pop x | x <- reverse ls] m'
-  let g' = g & #bound . at f ?~ Stk.ValLabel f
-             & #liveness . at f ?~ ls
-  stackify g' e
+stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
+  stackifyKappa g f kap \g' kap' -> do
+    emitRoutine kap'
+    stackify g' e
 
 stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  emitRoutine =<< stackifyLambda g f lam
-  stackify (g & #bound . at f ?~ Stk.ValLabel f) e
+  stackifyLambda g f lam \g' lam' -> do
+    emitRoutine lam'
+    stackify g' e
 
 stackify g (ExpIf c t f) = do
   let c' = stackifyVal g c
@@ -86,6 +80,15 @@ stackify g e@(ExpContinue k xs) = do
     ls = fold $ (k' ^? #ValImm . #ImmLabel)
       >>= \klbl -> g ^. #liveness . at klbl
 
+-- stackify g (ExpPrim (PrimCallCC withcc) cc) = do
+--   cc_l <- gensym' "cc"
+--   rcc_l <- gensym' "reified-cc"
+--   stackifyKappa g cc_l cc \g' rt -> do
+--     emitRoutine rt
+--     pure $
+--       Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $
+--       Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
+
 stackify g (ExpPrim p (MkKappa [x] e)) = do
   e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
   pure $
@@ -97,13 +100,32 @@ stackify _ e = error [i|unimplemented exp: #{e}|]
 _ValName :: Traversal' Val Name
 _ValName = failing #ValVar (#ValImm . #ImmLabel)
 
+stackifyKappa
+  :: (Stackify :> es, GenSym :> es)
+  => Env -> Name -> Kappa
+  -> (Env -> Stk.Routine -> Eff es r)
+  -> Eff es r
+stackifyKappa g name kap@(MkKappa xs m) w = do
+  let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
+  let ls = live g kap
+  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
+  let g' = g & #bound . at name ?~ Stk.ValLabel name
+             & #liveness . at name ?~ live g kap
+  let rt = Stk.MkRoutine name xs . buildBlock $
+       -- pop in the opposite order we push
+       Code [Stk.Pop x | x <- reverse ls] m'
+  w g' rt
+
 stackifyLambda
   :: (Stackify :> es, GenSym :> es)
-  => Env -> Name -> Lambda -> Eff es Stk.Routine
-stackifyLambda g name (MkLambda xs k m) = do
+  => Env -> Name -> Lambda
+  -> (Env -> Stk.Routine -> Eff es r)
+  -> Eff es r
+stackifyLambda g name (MkLambda xs k m) w = do
   let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
   m' <- stackify (g & #bound <>~ H.fromList vs) m
-  pure $ Stk.MkRoutine name (k:xs) (buildBlock m')
+  let g' = g & #bound . at name ?~ Stk.ValLabel name
+  w g' $ Stk.MkRoutine name (k:xs) (buildBlock m')
 
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
@@ -138,8 +160,8 @@ emptyEnv = MkEnv mempty mempty
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram lam) = do
   let g = emptyEnv
-  (start,p) <- runStackify $ stackifyLambda g "start" lam
-  pure $ p <> [ start ]
+  (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
+  pure p
 
 letfn :: Program
 letfn = [cps|

src/Gyehoek/CPS/Syntax.hs

@@ -80,6 +80,7 @@ data Obj
 -- | a heap object.
 data Hob
   = HobClosure { label :: Name, env :: List Obj }
+  | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -183,12 +184,14 @@ labelName = S.coproduct
 instance S.DatumIso Hob where
   datumIso = S.match
     $ S.With (. closure)
+    $ S.With (. conspair)
     $ S.End
     where
+      conspair = S.dottedList (S.el S.datumIso) S.datumIso
       -- closures can be printed, but not parsed.
       closure :: G (Datum :- t) (List Obj :- Name :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> [S.sx|(<closure> #{code} ##{env})|] :- t)
+        (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where

src/Gyehoek/Scheme/Syntax.hs

@@ -181,7 +181,6 @@ primDatumIso namefn a = S.match
       ht0' s = S.headTagged0' (namefn s) a
 
 instance DatumIso a => DatumIso (Prim a) where
-  -- datumIso = primDatumIso ("prim:"<>) datumIso
   datumIso = primDatumIso id S.datumIso
 
 instance DatumIso Lit where

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -41,7 +41,7 @@ module Gyehoek.Sexp.Grammar.Base
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike, headTagged2'
+  , beginLike, headTagged2', dottedList
   ) where
 
 import Data.InvertibleGrammar
@@ -56,6 +56,7 @@ import Data.Scientific (Scientific)
 import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
+import qualified Data.List.NonEmpty as NE
 
 
 -- $setup
@@ -105,6 +106,29 @@ list
   -> G (Datum :- t) t'
 list = listWithIndentation Ordinary
 
+-- |
+-- >>> decodeTest @(Int,Int) (with \g -> dottedList (el int) int >>> g) "(1 . 2)"
+dottedList
+  :: forall t t' t''. G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t') t''
+  -> G (Datum :- t) t''
+dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
+  where
+    begin = locate >>> Flip (PartialIso
+      (\(x:-MkListContext xs:-t) -> case NE.nonEmpty xs of
+          Just xs' -> DotList xs' x :- t
+          Nothing -> error "fuck")
+      (\case
+          DotList xs x :- t -> Right $ x :- MkListContext (NE.toList xs) :- t
+          _ -> Left $ expected "dotted list"))
+    end :: Grammar Ann (ListContext :- t') t'
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
 listWithIndentation
   :: Indentation
   -> G (ListContext :- t) (ListContext :- t')

src/Gyehoek/Sexp/Print.hs

@@ -14,7 +14,7 @@ import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
 import Gyehoek.Prelude hiding (Simple, (:<))
-import Data.Foldable (traverse_)
+import Data.Foldable (traverse_, toList)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
@@ -84,6 +84,13 @@ printDatumW w =
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
   Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
+  DotList xs x ->
+    pparen depth . group . align $
+      vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
+           , "."
+           , prettyDatum (depth+1) x
+           ]
+      
   List' indent xs ->
     case indent of
       NSpecial n | keyword:args <- xs ->

src/Gyehoek/Stack/VM.hs

@@ -77,6 +77,13 @@ stepI e vm (Prim r p) = case evalVal e vm <$> p of
     case env of
       ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
       _ -> error [i|expected closure, got #{env}|]
+  PrimCons x y -> ret $ ObjHob $ HobPair x y
+  PrimCar x -> case x of
+      ObjHob (HobPair car _) -> ret car
+      _ -> error [i|expected pair, got ${x}|]
+  PrimCdr x -> case x of
+      ObjHob (HobPair _ cdr) -> ret cdr
+      _ -> error [i|expected pair, got ${x}|]
   x -> error [i|unimplemented prim: #{p}|]
   where
     ret v = vm & #registers . at r ?~ v
@@ -160,13 +167,7 @@ trace p = initialVM & NE.unfoldr \vm ->
   where e = initialEnv p
 
 writeObj :: Obj -> Text
-writeObj (ObjImm im) = case im of
-  ImmInt n -> [i|#{n}|]
-  ImmBool True -> "#t"
-  ImmBool False -> "#f"
-  ImmLabel l -> "#<procedure>"
-writeObj (ObjHob h) = case h of
-  HobClosure code env -> "#<procedure>"
+writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso
 
 traceEval :: IOE :> es => Program -> Eff es (List Obj)
 traceEval p = do