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
|
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 xs
where
x' = case x of
StackString s -> s
_ -> show x
f _ = unreachable
drop' :: StackModifier
drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f }
where
ts = [tAny]
f (_:xs) = return xs
f _ = unreachable
swap :: StackModifier
swap = StackModifier { smName="SWAP", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny]
f (x:y:xs) = return $ y:x:xs
f _ = unreachable
dup :: StackModifier
dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f }
where
ts = [tAny]
f (x:xs) = return $ x:x:xs
f _ = unreachable
over :: StackModifier
over = StackModifier { smName="OVER", smTypes=ts, smFunc=f }
where
ts = [tAny, tAny]
f (x:y:xs) = return $ 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 $ 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 $ (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 $ 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 $ (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 $ 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 $ 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 $ 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 $ StackBool(x > y):xs
f _ = unreachable
|
