summaryrefslogtreecommitdiff
path: root/check.hs
diff options
context:
space:
mode:
Diffstat (limited to 'check.hs')
-rw-r--r--check.hs25
1 files changed, 25 insertions, 0 deletions
diff --git a/check.hs b/check.hs
index a869f18..dbbcfd8 100644
--- a/check.hs
+++ b/check.hs
@@ -160,6 +160,12 @@ typeCheck (Program decls) = Program <$> mapM (goD topLevelNames) decls
else Left $ "Cannot convert type '" ++ pshow argtype ++ "' to '" ++ pshow (snd ft !! i)
++ "' in call of function '" ++ n ++ "'"
return $ ExLit (LitCall n rargs) (Just (fst ft))
+ goE names (ExCast totype ex) = do
+ rex <- goE names ex
+ let fromtype = fromJust (exTypeOf rex)
+ if canCast fromtype totype
+ then return $ ExCast totype rex
+ else Left $ "Cannot cast type '" ++ pshow fromtype ++ "' to '" ++ pshow totype ++ "'"
goE names (ExBinOp bo e1 e2 _) = do
re1 <- goE names e1
re2 <- goE names e2
@@ -206,6 +212,21 @@ canConvert (TypeUInt _) TypeFloat = True
canConvert (TypeUInt _) TypeDouble = True
canConvert _ _ = False
+canCast :: Type -> Type -> Bool
+canCast t1 t2 = any (\f -> f t1 && f t2) [numberGroup, intptrGroup]
+ where
+ numberGroup (TypeInt _) = True
+ numberGroup (TypeUInt _) = True
+ numberGroup TypeFloat = True
+ numberGroup TypeDouble = True
+ numberGroup _ = False
+
+ intptrGroup (TypeInt _) = True
+ intptrGroup (TypeUInt _) = True
+ intptrGroup (TypePtr _) = True
+ intptrGroup (TypeFunc _ _) = True
+ intptrGroup _ = False
+
arithBO, compareBO, logicBO, complogBO :: [BinaryOperator]
arithBO = [Plus, Minus, Times, Divide, Modulo]
compareBO = [Equal, Unequal, Greater, Less, GEqual, LEqual]
@@ -373,6 +394,10 @@ mapProgram prog mapper = goP prog
goE (ExLit l mt) = do
rl <- goL l
h_e $ ExLit rl mt
+ goE (ExCast t e) = do
+ rt <- goT t
+ re <- goE e
+ h_e $ ExCast rt re
goE (ExBinOp bo e1 e2 mt) = do
rbo <- goBO bo
re1 <- goE e1