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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
module DSL.Intrinsics where
import DSL.Types
import DSL.Util
dump :: StackModifier
dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f }
where
ts = [tAny]
f (x:xs) = putStrLn x' >> return (Right $ xs)
where
x' = case x of
StackString s -> "String:" ++ show s
StackInt i -> "Integer:" ++ show i
StackBool b -> "Boolean:" ++ show b
f _ = unreachable
drop' :: StackModifier
drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f }
where
ts = [tAny]
f (_:xs) = return $ Right xs
f _ = unreachable
swap :: StackModifier
swap = StackModifier { smName="SWAP", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny]
f (x:y:xs) = return $ Right $ y:x:xs
f _ = unreachable
dup :: StackModifier
dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f }
where
ts = [tAny]
f (x:xs) = return $ Right $ x:x:xs
f _ = unreachable
over :: StackModifier
over = StackModifier { smName="OVER", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny]
f (x:y:xs) = return $ Right $ y:x:y:xs
f _ = unreachable
rot :: StackModifier
rot = StackModifier { smName="ROT", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny, tAny]
f (x:y:z:xs) = return $ Right $ y:z:x:xs
f _ = unreachable
binArithmetic :: String -> (Integer -> Integer -> [Integer]) -> StackModifier
binArithmetic name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
where
ts = [tInt, tInt]
f' (StackInt x:StackInt y:xs) = return $ Right $ (StackInt <$> f x y) ++ xs
f' _ = unreachable
plus :: StackModifier
plus = binArithmetic "PLUS" $ \ x y -> [x + y]
minus :: StackModifier
minus = binArithmetic "MINUS" $ \ x y -> [x - y]
times :: StackModifier
times = binArithmetic "TIMES" $ \ x y -> [x * y]
divMod' :: StackModifier
divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y]
not' :: StackModifier
not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f }
where
ts = [tBool]
f (StackBool x:xs) = return $ Right $ StackBool (not x):xs
f _ = unreachable
binBoolean :: String -> (Bool -> Bool -> [Bool]) -> StackModifier
binBoolean name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
where
ts = [tBool, tBool]
f' (StackBool x:StackBool y:xs) = return $ Right $ (StackBool <$> f x y) ++ xs
f' _ = unreachable
and' :: StackModifier
and' = binBoolean "AND" $ \ x y -> [x && y]
or' :: StackModifier
or' = binBoolean "OR" $ \ x y -> [x || y]
xor :: StackModifier
xor = binBoolean "XOR" $ \ x y -> [x /= y]
strcat :: StackModifier
strcat = StackModifier { smName="STRCAT", smTypes=ts, smFunc=f }
where
ts = [tString, tString]
f (StackString x:StackString y:xs) = return $ Right $ StackString (x ++ y):xs
f _ = unreachable
equal :: StackModifier
equal = StackModifier { smName="EQUAL", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny]
f (x:y:xs) = return $ Right $ StackBool (x == y):xs
f _ = unreachable
lessThan :: StackModifier
lessThan = StackModifier { smName="LESSTHAN", smTypes=ts, smFunc=f }
where
ts = [tInt, tInt]
f (StackInt x:StackInt y:xs) = return $ Right $ StackBool(x < y):xs
f _ = unreachable
greaterThan :: StackModifier
greaterThan = StackModifier { smName="GREATERTHAN", smTypes=ts, smFunc=f }
where
ts = [tInt, tInt]
f (StackInt x:StackInt y:xs) = return $ Right $ StackBool(x > y):xs
f _ = unreachable
put :: StackModifier
put = StackModifier { smName="PUT", smTypes=[tAny], smFunc=f }
where
f (x:xs) = putStr x' >> return (Right xs)
where
x' = case x of
StackBool True -> "true"
StackBool False -> "false"
StackInt i -> show i
StackString s -> s
f _ = unreachable
|
