X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=820e45df5b84f822bb0bd69cc232cc5e4cf71eb0;hb=3d569407ede8e77c5809a1076735dc3c58ab1922;hp=43df3a3b2aa89d7296352706afd7f7af1a3e8367;hpb=72fb877d00efbba5cc4540ee2e76fbb01c6f572d;p=cc1516.git

diff --git a/sem.icl b/sem.icl
index 43df3a3..820e45d 100644
--- a/sem.icl
+++ b/sem.icl
@@ -18,11 +18,11 @@ import StdString
 import StdTuple
 import StdList
 import StdBool
+import GenEq
 
 from Text import class Text(concat), instance Text String
 
 import AST
-from parse import :: ParserOutput, :: Error
 
 :: Gamma :== ('Map'.Map String Type, [String])
 :: Env a :== StateT Gamma (Either SemError) a
@@ -32,7 +32,7 @@ from parse import :: ParserOutput, :: Error
 instance MonadTrans (StateT Gamma) where
     liftT m = StateT \s-> m >>= \a-> return (a, s)
 
-get = gets id
+get :== gets id
 
 sem :: AST -> SemOutput
 sem (AST vd fd) = case runStateT m ('Map'.newMap, getRandomStream 1) of
@@ -40,10 +40,15 @@ sem (AST vd fd) = case runStateT m ('Map'.newMap, getRandomStream 1) of
     Right ((vds, fds), gamma) = Right ((AST vds fds), gamma)
 where 
     m :: Env ([VarDecl], [FunDecl])
-    m = mapM semVarDecl vd >>= \vds ->
-        mapM semFunDecl fd >>= \fds1 -> 
-        mapM semFunDecl fds1 >>= \fds2 -> 
-        pure (vds, fds2)
+    m = mapM semVarDecl vd >>= \vd1 ->
+        mapM semFunDecl fd >>= \fd1 -> 
+//    	mapM semVarDecl vd1 >>= \vd2 ->
+//        mapM semFunDecl fd1 >>= \fd2 -> 
+//    	mapM semVarDecl vd2 >>= \vd3 ->
+//        mapM semFunDecl fd2 >>= \fd3 -> 
+//    	mapM semVarDecl vd3 >>= \vd4 ->
+//        mapM semFunDecl fd3 >>= \fd4 ->  //Dit is puur om te proberen
+        pure (vd1, fd1)
 
 semFunDecl :: FunDecl -> Env FunDecl
 semFunDecl fd=:(FunDecl p f args mt vds stmts) = 
@@ -54,14 +59,37 @@ semFunDecl fd=:(FunDecl p f args mt vds stmts) =
  	matchFunctions args ft >>= \tres->
     mapM semVarDecl vds >>= \newvds->
     mapM (checkStmt tres) stmts >>= \newstmts->
-	pure IntType >>= \returntype->
+	inferReturnType stmts >>= \returntype`->
+	unify returntype` tres >>= \returntype->
 	case mt of
-		Nothing = reconstructType args returntype 
-    		>>= \ftype->restoreGamma gamma 
+		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) 
+			FunDecl p f args (Just ftype) 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 = unify t1 t2
+updateFunType (t1 ->> t2) t3 = t1 ->> (updateFunType t2 t3)
+
+inferReturnType :: [Stmt] -> Env Type
+inferReturnType [] = pure VoidType
+inferReturnType [ReturnStmt (Just t):rest] = typeExpr t 
+	>>= \tx->inferReturnType rest >>= \ty->unify tx ty
+inferReturnType [ReturnStmt _:rest] = 
+	inferReturnType rest >>= \tx-> unify VoidType tx
+inferReturnType [_:rest] = inferReturnType rest
 
 reconstructType :: [String] Type -> Env Type
 reconstructType [] t = pure t
@@ -76,12 +104,15 @@ genType [x:xs] = liftM2 (->>) (freshIdent >>= \fi->pure $ IdType fi)
 	(genType xs)
 
 matchFunctions :: [String] Type -> Env Type
-matchFunctions [] (_ ->> _) = liftT $ Left $ Error "Not enough arguments"
-matchFunctions _ (VoidType ->> _) = liftT $ Left $ Error "Cannot have a void type in the middle of the function definition"
+matchFunctions [] (_ ->> _) = liftT $ Left $ 
+	ArgumentMisMatchError zero "Not enough arguments"
+matchFunctions _ (VoidType ->> _) = liftT $ Left $ 
+	ArgumentMisMatchError zero "Void can't be a non return type"
 matchFunctions [x:xs] (t1 ->> t2) = 
 	modify (\(st, r)->('Map'.put x t1 st, r)) >>| matchFunctions xs t2
 matchFunctions [] t = pure t
-matchFunctions _ t = liftT $ Left $ Error "Too much argumnts"
+matchFunctions _ t = liftT $ Left $ 
+	ArgumentMisMatchError zero "Too much argumnts"
 
 semVarDecl :: VarDecl -> Env VarDecl
 semVarDecl (VarDecl pos type ident ex) = unify type ex
@@ -128,7 +159,7 @@ typeExpr (VarExpr p (VarDef ident fs)) = gets (\(st, r)->'Map'.get ident st)
         Just t = unify t fs
 typeOp2 :: Expr Expr Op2 [Type] Type -> Env Type
 typeOp2 e1 e2 op ts ret = typeExpr e1 >>= \t1-> typeExpr e2 >>= \t2->
-    unify t1 t2 >>= \t3->if (isMember t3 ts) (pure ret)
+    unify t1 t2 >>= \t3->if (isMember t3 [IdType "":ts]) (pure ret)
         (liftT $ Left $ OperatorError (extrPos e1) op t3)
 
 buildFunctionType :: String [Expr] -> Env Type 
@@ -169,6 +200,8 @@ instance unify Expr where
 //			"Expression cannot be an polymorf type."
     unify VarType e = typeExpr e
     //we have to cheat to decorate the error, can be done nicer?
+	unify t=:(IdType id) e = typeExpr e >>= \tex->unify t tex
+		>>= \type->putIdent id type >>| pure type
     unify t e = StateT $ \s0 -> let res = runStateT m s0 in case res of
         Left err = Left $ decErr e err
         Right t = Right t //note, t :: (Type, Gamma) 
@@ -184,6 +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 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
@@ -247,15 +283,12 @@ replace ident type = get >>= \(st, fr)->put ('Map'.fromList $
         itupdate _ _ k = k
 
 instance toString SemError where
-    toString (ParseError p e) = concat [
-        toString p,"SemError: ParseError: ", e]
-    toString (Error e) = "SemError: " +++ e
-    toString (UnifyError p t1 t2) = concat [
-        toString p,
+    toString (ParseError p e) = concat [toString p,
+		"SemError: ParseError: ", e]
+    toString (UnifyError p t1 t2) = concat [ toString p,
         "SemError: Cannot unify types. Expected: ",
         toString t1, ". Given: ", toString t2]
-    toString (FieldSelectorError p t fs) = concat [
-        toString p,
+    toString (FieldSelectorError p t fs) = concat [ toString p,
         "SemError: Cannot select ", toString fs, " from type: ",
         toString t]
     toString (OperatorError p o t) = concat [
@@ -264,9 +297,17 @@ instance toString SemError where
         toString t]
     toString (UndeclaredVariableError p ident) = concat [
         toString p, "SemError: identifier: ", ident, " undefined."]
+    toString (ArgumentMisMatchError p s) = concat [toString p,
+		"SemError: Argument mismatch: ", s]
+    toString (Error e) = "SemError: " +++ e
 
 saveGamma :: Env Gamma
 saveGamma = get
 
 restoreGamma :: Gamma -> Env Void
 restoreGamma (oldstate, _) = gets snd >>= \newr->put (oldstate, newr)
+
+derive gEq Type
+instance == Type where 
+	(==) (IdType _) (IdType _) = True
+	(==) o1 o2 = gEq{|*|} o1 o2