diff --git a/golden/exec/map/source.scm b/golden/exec/map/source.scm new file mode 100644 index 0000000..c6fd7cc --- /dev/null +++ b/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))) diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index d7df320..3f88796 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/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 -orWrong p s msg f = case getFirst . getConst $ p (Const . First . Just) s of + -> Text -> s -> M Answer a +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 g = \case +evalPrim :: Env -> DynPoints -> Prim E -> M Answer (List E) +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] - PrimCons x y -> do - (x',y') <- traverseOf both new' (x,y) - pure [EPair Mut x' y'] + PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0 + PrimCons x y -> pcons x y >>= pure1 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 - [i|car/cdr는 pair을 받지 않다|] - (fmap (:[]) . fetch) + cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p + >>= fmap (:[]) . fetch diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 49555b7..c6b599a 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/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