Merge branch 'master' of github.com:dopefishh/cc1516

[cc1516.git] / sem.icl

diff --git a/sem.icl b/sem.icl
index 23fb04a..ef825e4 100644 (file)
--- a/sem.icl
+++ b/sem.icl
@@ -3,11 +3,13 @@ implementation module sem
 import qualified Data.Map as Map
 
 from Data.Func import $
-from StdFunc import o
+from StdFunc import o, flip, const, id
 
 import Control.Monad
 import Data.Either
+import Data.Maybe
 import Data.Monoid
+import Data.List 
 
 import StdString
 import StdList
@@ -31,13 +33,41 @@ import AST
        | OperatorError Pos Op2 Type
     | UndeclaredVariableError Pos String
     | ArgumentMisMatchError Pos String
+       | SanityError Pos String
        | Error String
 
 variableStream :: [String]
 variableStream = map toString [1..]
 
 sem :: AST -> SemOutput
-sem (AST fd) = Right (AST fd, 'Map'.newMap)
+sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd 
+               >>| foldM (const isNiceMain) () fd
+               >>| hasMain fd of
+       Left e = Left [e]
+       _ = pure (a, 'Map'.newMap)
+where
+               hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
+               hasNoDups fds (FunDecl p n _ _ _ _)
+               # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
+               = case catMaybes mbs of
+                       [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
+                       [x] = pure ()
+                       [_:x] = Left $ SanityError p (concat 
+                               [n, " multiply defined at ", toString p])
+
+               hasMain :: [FunDecl] -> Either SemError ()
+               hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
+               hasMain [_:fd] = hasMain fd
+               hasMain [] = Left $ SanityError zero "no main function defined"
+
+               isNiceMain :: FunDecl -> Either SemError ()
+               isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
+                       ([_:_], _) = Left $ SanityError p "main must have arity 0"
+                       ([], t) = (case t of
+                               Nothing = pure ()
+                               Just VoidType = pure ()
+                               _ = Left $ SanityError p "main has to return Void")
+               isNiceMain _ = pure ()
 
 instance toString Scheme where
        toString (Forall x t) = 
@@ -48,6 +78,8 @@ instance toString Gamma where
                concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 
 instance toString SemError where
+       toString (SanityError p e) = concat [toString p, 
+               "SemError: SanityError: ", e]
        toString se = "SemError: "
 
 uni :: Type Type -> Infer ()
@@ -58,8 +90,27 @@ inEnv (x, sc) m = local scope m
        where
                scope e = 'Map'.put x sc ('Map'.del x e )
 
+fresh :: Infer Type
+fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
+
 class infer a :: a -> Infer Type
 
+op2Type :: Op2 -> Infer Type
+op2Type op  | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
+                = pure (IntType ->> IntType ->> IntType)
+            | elem op [BiEquals, BiUnEqual]
+                = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
+            | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
+                = pure (IntType ->> IntType ->> BoolType)
+            | elem op [BiAnd, BiOr]
+                = pure (BoolType ->> BoolType ->> BoolType)
+            | op == BiCons 
+                = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
+
+op1Type :: Op1 -> Infer Type
+op1Type UnNegation = pure $ (BoolType ->> BoolType)
+op1Type UnMinus = pure $ (IntType ->> IntType)
+
 instance infer Expr where
        infer (VarExpr _ vd) = undef
        infer (Op2Expr _ e1 op e2) = case op of