X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=e2227d168fde2b92938604d92724d623d646070c;hb=a8348a333a567e5a469d1e5f8ec6c3dafc051c91;hp=475d09325f0c9df7ec978b8681de28005f3447c0;hpb=17a18d09526365443a710bb1fb7728d5c1f8ceea;p=cc1516.git diff --git a/sem.icl b/sem.icl index 475d093..e2227d1 100644 --- a/sem.icl +++ b/sem.icl @@ -41,10 +41,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 (vd4, fd4) semFunDecl :: FunDecl -> Env FunDecl semFunDecl fd=:(FunDecl p f args mt vds stmts) = @@ -57,10 +62,10 @@ semFunDecl fd=:(FunDecl p f args mt vds stmts) = mapM (checkStmt tres) stmts >>= \newstmts-> case mt of Nothing = inferReturnType stmts - >>= \returntype->reconstructType args returntype + >>= \returntype->reconstructType args tres >>= \ftype->restoreGamma gamma >>| putIdent f ftype >>| pure ( - FunDecl p f args (Just ftype) newvds newstmts) + FunDecl p f args (Just ftype) newvds newstmts) Just t = restoreGamma gamma >>| pure (FunDecl p f args mt newvds newstmts) @@ -176,6 +181,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) @@ -191,6 +198,7 @@ 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 t1 t2 = liftT $ Left $ UnifyError zero t1 t2 instance zero Pos where