blob: e02bc74cb3575edbf0b11c2f4c9bc216cd816312 (
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 Data.Foldable (foldlM)
import DSL.Types
import DSL.Util
import DSL.Intrinsics
newMachine :: Machine
newMachine = Machine { ok=True, stack=[], pTable=[] }
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 -> Right <$> 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_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 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] -> Machine -> IO Machine
applyIf _ _ m@Machine{ ok=False } = return m
applyIf c b m = do
m' <- evalBlocks c m
case m' of
Machine{ ok=False } -> return m'
Machine{ stack=[] } -> hcf m' "IF: stack underflow"
Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
Machine{ stack=StackBool True:xs } -> evalBlocks b m'{ stack=xs }
Machine{ stack=_:_ } -> hcf m' "IF: type mis-match"
applyIfElse :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
applyIfElse _ _ _ m@Machine{ ok=False } = return m
applyIfElse c b1 b2 m = do
m' <- evalBlocks c m
case m' of
Machine{ ok=False } -> return m'
Machine{ stack=[] } -> hcf m' "IFELSE: stack underflow"
Machine{ stack=StackBool True:xs } -> evalBlocks b1 m'{ stack=xs }
Machine{ stack=StackBool False:xs } -> evalBlocks b2 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 b:bs) m = applyIf c b m >>= evalBlocks bs
evalBlocks (BIfElse c b1 b2:bs) m = applyIfElse c b1 b2 m >>= evalBlocks bs
evalBlocks (BWhile c b:bs) m = applyWhile c b m >>= evalBlocks bs
interpret :: ([ProcSpec], Program) -> IO ()
interpret (t, p) = evalBlocks p newMachine{ pTable=t } >> return ()
|
