eval call/cc }:)

golden/exec/map/source.scm

@@ -0,0 +1,7 @@
+(letrec ((my-map (λ (f l)
+                   (if (pair? l)
+                       (cons (f (car l))
+                             (my-map f (cdr l)))
+                       (list)))))
+  (my-map (λ (x) (* x x))
+          (list 0 1 2 3 4)))

src/Gyehoek/CPS/Eval.hs

@@ -29,7 +29,7 @@ import Data.IntMap.Strict qualified as IM
 import Data.Monoid
 import Control.Monad.State
 import Data.Traversable (for)
-import Data.Foldable (traverse_)
+import Data.Foldable (traverse_, foldrM)
 
 
 newtype Loc = MkLoc { getLoc :: Int }
@@ -118,10 +118,10 @@ wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
 
 orWrong
   :: Getting (First a) s a
-  -> s -> Text -> (a -> M Answer c) -> M Answer c
+  -> Text -> s -> M Answer a
-orWrong p s msg f = case getFirst . getConst $ p (Const . First . Just) s of
+orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
   Nothing -> wrong msg
-  Just x -> f x
+  Just x -> pure x
 
 bind :: Name -> Loc -> Env
 bind k = MkEnv . H.singleton k
@@ -225,8 +225,18 @@ eval g dps (ExpLetRec bs e) = do
   traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
   eval g' dps e
 
+eval g dps (ExpPrim (PrimCallCC withcc) k) = do
+  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
+    [i|call/cc: 함수가 아닌 것을 받았다|]
+  k' <- evalKexp g k
+  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
+  let cc = EProcedure \xs dps -> case unsnoc xs of
+        Just (xs',_) -> kproc xs' dps
+        Nothing -> wrong [i|call/cc: 잘못하는데!|]
+  withcc' [cc,k'] dps
+
 eval g dps (ExpPrim p k) = do
-  p' <- evalPrim g =<< traverse (evalVal g) p
+  p' <- evalPrim g dps =<< traverse (evalVal g) p
   evalKexp g k >>= \case
     EProcedure fp -> fp p' dps
     _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
@@ -240,26 +250,30 @@ eval g dps (ExpIf c t f) = do
 
 eval g dps e = error [i|unimplemented #{e}|]
 
-evalPrim :: Env -> Prim E -> M Answer (List E)
+evalPrim :: Env -> DynPoints -> Prim E -> M Answer (List E)
-evalPrim g = \case
+evalPrim g dps = \case
   PrimAdd x y -> arith2 (+) x y
   PrimMul x y -> arith2 (*) x y
   PrimSub x y -> arith2 (-) x y
   PrimDiv x y -> arith2 div x y
-  PrimZeroP x -> pure [EBool . isJust $ x ^? #EInt . only 0]
+  PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  PrimCons x y -> do
+  PrimCons x y -> pcons x y >>= pure1
-    (x',y') <- traverseOf both new' (x,y)
-    pure [EPair Mut x' y']
   PrimCar p -> cr p _2
   PrimCdr p -> cr p _3
+  PrimPairP p -> pure1 . EBool . maybe False (const True) $
+    p ^? #_EPair
   PrimValues xs -> pure xs
+  PrimList xs -> foldrM pcons ENull xs >>= pure1
   p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
   where
+    pure1 x = pure [x]
+    pcons x y = do
+      (x',y') <- traverseOf both new' (x,y)
+      pure $ EPair Mut x' y'
     arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
     arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
-    cr p l = orWrong (#_EPair . l) p
+    cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p
-      [i|car/cdr는 pair을 받지 않다|]
+      >>= fmap (:[]) . fetch
-      (fmap (:[]) . fetch)
 
 
 

src/Gyehoek/Scheme/Syntax.hs

@@ -90,6 +90,8 @@ data Prim e
   | PrimInvokeCC e (List e)
   | PrimValues (List e)
   | PrimCallWithValues e e
+  | PrimPairP e
+  | PrimList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -181,6 +183,8 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1' "invoke/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
+    $ S.With (. ht1 "pair?")
+    $ S.With (. ht0' "list")
     $ S.End
     where
       idn = S.el . S.sym . namefn