blob: 34137a930fd6c2f489a4ddfb64604850a46192eb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
module DSL.Interpretation where
import qualified Data.Map.Strict as M
import Data.Bifunctor (first)
import Data.Foldable (foldlM)
import Data.Void
import DSL.Types
import DSL.Util
import DSL.Intrinsics
import DSL.StdLib (stdlib)
entrypoint :: ProcName
entrypoint = "MAIN"
newMachine :: Machine
newMachine = Machine { ok=True, stack=[], pTable=M.empty }
pushData :: Machine -> StackData -> Machine
pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
runModifier :: StackModifier -> Stack -> IO (Either String Stack)
runModifier sm s = case runChecks (smTypes sm) s of
Just err -> return $ Left $ smName sm ++ ": " ++ err
Nothing -> first absurd <$> smFunc sm s
applyIntrinsic :: Intrinsic -> Machine -> IO Machine
applyIntrinsic i m = do
res <- runModifier sm (stack m)
case res of
Left err -> hcf m err
Right s' -> return m{ stack=s' }
where
sm = case i of
I_DUMP -> dump
I_DROP -> drop'
I_SWAP -> swap
I_DUP -> dup
I_OVER -> over
I_ROT -> rot
I_PLUS -> plus
I_MINUS -> minus
I_TIMES -> times
I_DIVMOD -> divMod'
I_NOT -> not'
I_AND -> and'
I_OR -> or'
I_XOR -> xor
I_STRCAT -> strcat
I_EQUAL -> equal
I_LESSTHAN -> lessThan
I_GREATERTHAN -> greaterThan
applyCall :: ProcName -> Machine -> IO Machine
applyCall _ m@Machine{ ok=False } = return m
applyCall name m@Machine{ pTable=t } = case M.lookup name t of
Nothing -> hcf m $ "PROCCALL: undefined proc: " ++ name
Just bs -> evalBlocks bs m
applyOperation :: Machine -> Operation -> IO Machine
-- take no action if a previous step failed
applyOperation m@Machine{ ok=False } _ = return m
applyOperation m (OpPushData x) = return $ pushData m x
applyOperation m (OpIntrinsic i) = applyIntrinsic i m
applyOperation m (OpCall name) = applyCall name m
applyLinear :: Machine -> [Operation] -> IO Machine
applyLinear = foldlM applyOperation
applyIf :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
applyIf _ _ _ m@Machine{ ok=False } = return m
applyIf c t f m = do
m' <- evalBlocks c m
case m' of
Machine{ ok=False } -> return m'
Machine{ stack=[] } -> hcf m' "IF: stack underflow"
Machine{ stack=StackBool True:xs } -> evalBlocks t m'{ stack=xs }
Machine{ stack=StackBool False:xs } -> evalBlocks f m'{ stack=xs }
Machine{ stack=_:_ } -> hcf m' "IF: type mis-match"
applyWhile :: [Block] -> [Block] -> Machine -> IO Machine
applyWhile _ _ m@Machine{ ok=False } = return m
applyWhile c b m = do
m' <- evalBlocks c m
case m' of
Machine{ ok=False } -> return m'
Machine{ stack=[] } -> hcf m' "WHILE: stack underflow"
Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
Machine{ stack=StackBool True:xs } -> do
m'' <- evalBlocks b m'{ stack=xs }
applyWhile c b m''
Machine{ stack=_:_ } -> hcf m' "WHILE: type mis-match"
evalBlocks :: [Block] -> Machine -> IO Machine
evalBlocks _ m@Machine{ ok=False } = return m
evalBlocks [] m = return m
evalBlocks (BLinear b:bs) m = applyLinear m b >>= evalBlocks bs
evalBlocks (BIf c t f:bs) m = applyIf c t f m >>= evalBlocks bs
evalBlocks (BWhile c b:bs) m = applyWhile c b m >>= evalBlocks bs
interpret :: ProcTable -> IO ()
interpret t = case mergeProcTables stdlib t of
Left e -> putStrLn e
Right t' -> case M.lookup entrypoint t' of
Nothing -> putStrLn "No MAIN proc defined, aborting."
Just b -> () <$ evalBlocks b newMachine{ pTable=t' }
|
