1 files changed, 110 insertions, 0 deletions
diff --git a/DSL/Intrinsics.hs b/DSL/Intrinsics.hs
new file mode 100644
index 0000000..11b37f3
--- /dev/null
+++ b/DSL/Intrinsics.hs
@@ -0,0 +1,110 @@
+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 (show x) >> return xs
+    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]
+
+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
+