diff options
Diffstat (limited to 'src/Operators.hs')
-rw-r--r-- | src/Operators.hs | 58 |
1 files changed, 45 insertions, 13 deletions
diff --git a/src/Operators.hs b/src/Operators.hs index 051655a..c5812ea 100644 --- a/src/Operators.hs +++ b/src/Operators.hs | |||
@@ -9,19 +9,23 @@ import Parser | |||
9 | primitives :: [(String, [Expr] -> LispResult Expr)] | 9 | primitives :: [(String, [Expr] -> LispResult Expr)] |
10 | primitives = map (\(n, f) -> (n, f n)) | 10 | primitives = map (\(n, f) -> (n, f n)) |
11 | [ | 11 | [ |
12 | ("+" , arithmetic (+)) | 12 | ("+", arithmetic (+)) |
13 | , ("-" , arithmetic (-)) | 13 | , ("-", arithmetic (-)) |
14 | , ("*" , arithmetic (*)) | 14 | , ("*", arithmetic (*)) |
15 | , ("/" , arithmetic (/)) | 15 | , ("/", arithmetic (/)) |
16 | , (">" , comparator (>)) | 16 | , (">", comparator (>)) |
17 | , ("<" , comparator (<)) | 17 | , ("<", comparator (<)) |
18 | , (">=" , comparator (>=)) | 18 | , (">=", comparator (>=)) |
19 | , ("<=" , comparator (<=)) | 19 | , ("<=", comparator (<=)) |
20 | , ("=" , comparator (==)) | 20 | , ("=" , comparator (==)) |
21 | , ("!=" , comparator (/=)) | 21 | , ("!=" , comparator (/=)) |
22 | , ("not" , unaryBool not) | 22 | , ("not", unaryBool not) |
23 | , ("or" , naryBool (||)) | 23 | , ("or", naryBool (||)) |
24 | , ("and" , naryBool (&&)) | 24 | , ("and", naryBool (&&)) |
25 | , ("car", car) | ||
26 | , ("cdr", cdr) | ||
27 | , ("cons", cons) | ||
28 | , ("null?", isNull) | ||
25 | ] | 29 | ] |
26 | 30 | ||
27 | data LispNumber = I Integer | 31 | data LispNumber = I Integer |
@@ -90,3 +94,31 @@ wrapNum (F n) = FloatLiteral n | |||
90 | unwrapBool :: Expr -> LispResult Bool | 94 | unwrapBool :: Expr -> LispResult Bool |
91 | unwrapBool (BoolLiteral s) = return s | 95 | unwrapBool (BoolLiteral s) = return s |
92 | unwrapBool x = throwError $ TypeMismatch "boolean" x | 96 | unwrapBool x = throwError $ TypeMismatch "boolean" x |
97 | |||
98 | -- list primitives | ||
99 | |||
100 | car :: FName -> [Expr] -> LispResult Expr | ||
101 | car _ [List (x:xs)] = return x | ||
102 | car _ [DottedList (x:xs) _ ] = return x | ||
103 | car _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse | ||
104 | car fn mulArgs = throwError $ ArgCount fn 1 mulArgs | ||
105 | |||
106 | cdr :: FName -> [Expr] -> LispResult Expr | ||
107 | cdr _ [List (x:xs)] = return $ List xs | ||
108 | cdr _ [DottedList [_] tail] = return tail | ||
109 | cdr _ [DottedList (_:xs) t] = return $ DottedList xs t | ||
110 | cdr _ [somethingElse] = throwError $ TypeMismatch "pair" somethingElse | ||
111 | cdr fn mulArgs = throwError $ ArgCount fn 1 mulArgs | ||
112 | |||
113 | cons :: FName -> [Expr] -> LispResult Expr | ||
114 | cons _ [val, List []] = return $ List [val] | ||
115 | cons _ [val, List ls] = return $ List $ val:ls | ||
116 | cons _ [val, DottedList ls tail] = return $ DottedList (val:ls) tail | ||
117 | cons _ [v1, v2] = return $ DottedList [v1] v2 | ||
118 | cons fn mulArgs = throwError $ ArgCount fn 2 mulArgs | ||
119 | |||
120 | isNull :: FName -> [Expr] -> LispResult Expr | ||
121 | isNull _ [List []] = return $ BoolLiteral True | ||
122 | isNull _ [List _] = return $ BoolLiteral False | ||
123 | isNull _ [arg] = throwError $ TypeMismatch "pair" arg | ||
124 | isNull fn args = throwError $ ArgCount fn 1 args | ||