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

[cc1516.git] / sem.icl

diff --git a/sem.icl b/sem.icl
index f3d28c2..a58b2e1 100644 (file)
--- a/sem.icl
+++ b/sem.icl
@@ -59,20 +59,36 @@ semFunDecl fd=:(FunDecl p f args mt vds stmts) =
        matchFunctions args ft >>= \tres->
     mapM semVarDecl vds >>= \newvds->
     mapM (checkStmt tres) stmts >>= \newstmts->
+       inferReturnType stmts >>= \returntype`->
+       unify returntype` tres >>= \returntype->
        case mt of
-               Nothing = inferReturnType stmts
-                       >>= \returntype->reconstructType args tres 
+               Nothing = reconstructType args tres
+                       >>= \ftype`->recoverType ftype`
                        >>= \ftype->restoreGamma gamma 
                        >>| putIdent f ftype >>| pure (
                        FunDecl p f args (Just ftype) newvds newstmts)
-               Just t = restoreGamma gamma 
-                       >>| pure (FunDecl p f args mt newvds newstmts) 
+               Just t = restoreGamma gamma >>| updateFunType t returntype
+                       >>= \tt-> pure (FunDecl p f args (Just tt) newvds newstmts) 
+
+recoverType :: Type -> Env Type
+recoverType (IdType ident) = gets (\(st, r)->'Map'.get ident st)
+       >>= \mt->case mt of
+               Nothing = pure (IdType ident)
+               Just t = pure t
+recoverType (t1 ->> t2) = recoverType t1 >>= \t1`->recoverType t2 
+       >>= \t2`->pure (t1` ->> t2`) 
+recoverType t = pure t
+
+updateFunType :: Type Type -> Env Type
+updateFunType (t1 ->> t2) t3 = updateFunType t2 t3 >>= \t2`->pure $ t1 ->> t2`
+updateFunType t1 t2 = unify t1 t2
 
 inferReturnType :: [Stmt] -> Env Type
 inferReturnType [] = pure VoidType
 inferReturnType [ReturnStmt (Just t):rest] = typeExpr t 
        >>= \tx->inferReturnType rest >>= \ty->unify tx ty
-inferReturnType [ReturnStmt _:rest] = pure VoidType
+inferReturnType [ReturnStmt _:rest] = 
+       inferReturnType rest >>= \tx-> unify VoidType tx
 inferReturnType [_:rest] = inferReturnType rest
 
 reconstructType :: [String] Type -> Env Type
@@ -201,9 +217,9 @@ instance unify Type where
     unify (ListType t1) (ListType t2) = unify t1 t2 >>| (pure $ ListType t1)
     unify (ta1 ->> ta2) (tb1 ->> tb2) = unify ta1 tb1 >>= \ta-> unify ta2 tb2 
         >>= \tb-> pure (ta ->> tb)
+    unify VoidType VoidType = pure VoidType
     unify VoidType t = pure t
     unify t VoidType = pure t
-    unify VoidType VoidType = pure VoidType
        unify t1 t2 = liftT $ Left $ UnifyError zero t1 t2
 
 instance zero Pos where