Type checking

1 files changed, 95 insertions, 18 deletions

diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index afdfe90..e930c44 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,7 +1,7 @@
 implementation module Sil.Compile
 
 import StdEnum
-from StdFunc import o
+from StdFunc import const, flip, o
 import StdList
 import StdString
 
@@ -11,6 +11,7 @@ import Control.Monad.RWST
 import Control.Monad.Trans
 import Data.Error
 from Data.Func import $
+import Data.Functor
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
@@ -19,14 +20,24 @@ from Text import <+
 import qualified ABC.Assembler as ABC
 
 import Sil.Syntax
+import Sil.Types
 import Sil.Util.Printer
 
 instance toString CompileError
 where
-	toString (UndefinedName n) = "Undefined name '" <+ n <+ "'."
-	toString VariableLabel     = "Variable stored at label."
-	toString FunctionOnStack   = "Function stored on the stack."
-	toString UnknownError      = "Unknown error."
+	toString (UndefinedName n)      = "Undefined name '" <+ n <+ "'."
+	toString VariableLabel          = "Variable stored at label."
+	toString FunctionOnStack        = "Function stored on the stack."
+	toString (TypeError err e)      = "Type error in '" <+ e <+ "': " <+ err
+	toString (CouldNotDeduceType e) = "Could not deduce type of '" <+ e <+ "'."
+	toString (TypeMisMatch t e)     = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
+	toString UnknownError           = "Unknown error."
+
+error :: CompileError -> RWST r w s (MaybeError CompileError) a
+error e = RWST \_ _ -> Error e
+
+nop :: RWST r w s m () | Monoid w & Monad m
+nop = RWST \_ s -> pure ((), s, mempty)
 
 compile :: Program -> MaybeError CompileError 'ABC'.Assembler
 compile prog = case evalRWST (gen prog) () zero of
@@ -47,6 +58,7 @@ compile prog = case evalRWST (gen prog) () zero of
 	, returns       :: ['ABC'.Assembler]
 	, stackoffset   :: Int
 	, storedoffsets :: [Int]
+	, typeresolvers :: [TypeResolver]
 	}
 
 instance zero CompileState
@@ -58,6 +70,7 @@ where
 		, returns       = []
 		, stackoffset   = 0
 		, storedoffsets = []
+		, typeresolvers = []
 		}
 
 labels :: CompileState -> ['ABC'.Label]
@@ -94,15 +107,30 @@ restoreStackOffset :: CompileState -> CompileState
 restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos}
 where [so:sos] = cs.storedoffsets
 
+typeresolvers :: CompileState -> [TypeResolver]
+typeresolvers cs = cs.typeresolvers
+
+pushTypeResolver :: TypeResolver CompileState -> CompileState
+pushTypeResolver tr cs = {cs & typeresolvers=[tr:cs.typeresolvers]}
+
+popTypeResolver :: CompileState -> CompileState
+popTypeResolver cs = {cs & typeresolvers=tl cs.typeresolvers}
+
 :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
 
 fresh :: a -> Gen 'ABC'.Label | toString a
 fresh n = gets labels
 	>>= \labs -> modify (\cs -> {cs & labels=tl labs})
-	*> pure (n <+ hd labs)
+	$> n <+ hd labs
+
+getTypeResolver :: Gen TypeResolver
+getTypeResolver = gets typeresolvers >>= \trs -> pure $ \n ->
+	case catMaybes $ map (flip ($) n) trs of
+		[t:_] -> Just t
+		[]    -> Nothing
 
 reserveVar :: Int Name -> Gen Int
-reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
+reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) $> (i+1)
 
 addFunction :: Function -> Gen ()
 addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
@@ -120,6 +148,18 @@ growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})
 shrinkStack :: (Int -> Gen ())
 shrinkStack = growStack o ((-) 0)
 
+checkType :: Type Expression -> Gen ()
+checkType t e = getTypeResolver >>= \tr -> case type tr e of
+	Nothing          -> error $ CouldNotDeduceType e
+	Just (Error err) -> error $ TypeError err e
+	Just (Ok t`)     -> if (t == t`) nop (error $ TypeMisMatch t e)
+
+checkTypeName :: Name Expression -> Gen ()
+checkTypeName n e = getTypeResolver >>= \tr -> case type tr n of
+	Nothing          -> error $ CouldNotDeduceType $ Name n
+	Just (Error err) -> error $ TypeError err $ Name n
+	Just (Ok t`)     -> checkType t` e
+
 class gen a :: a -> Gen ()
 
 instance gen Program
@@ -134,8 +174,15 @@ where
 		     , 'ABC'.Fill "_" 0 "main" 0
 		     , 'ABC'.Jmp "_driver"
 		     ] *>
+		modify (pushTypeResolver typeresolver) *>
 		mapM_ addFunction p.p_funs *>
-		mapM_ gen p.p_funs
+		mapM_ gen p.p_funs *>
+		modify popTypeResolver
+	where
+		typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+		typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
+			[]    -> Nothing
+			[f:_] -> type (const Nothing) f
 
 instance gen Function
 where
@@ -145,7 +192,9 @@ where
 		     ] *>
 		foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
 		modify (newReturn cleanup`) *>
+		modify (pushTypeResolver typeresolver) *>
 		gen f.f_code *>
+		modify popTypeResolver *>
 		cleanup *>
 		modify (\cs -> {cs & stackoffset=0}) *>
 		tell ['ABC'.Rtn] *>
@@ -163,6 +212,9 @@ where
 		args = length f.f_args
 		locals = length f.f_code.cb_init
 
+		typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+		typeresolver n = listToMaybe [Ok a.arg_type \\ a <- f.f_args | a.arg_name == n]
+
 instance gen CodeBlock
 where
 	gen cb =
@@ -170,7 +222,9 @@ where
 		foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
 		mapM_ gen cb.cb_init *>
 		modify (addToReturn cleanup`) *>
+		modify (pushTypeResolver typeresolver) *>
 		mapM_ gen cb.cb_content *>
+		modify popTypeResolver *>
 		tell cleanup` *>
 		modify (removeFromReturn $ length cleanup`) *>
 		modify restoreStackOffset
@@ -180,27 +234,49 @@ where
 			_  -> [ 'ABC'.Pop_a locals ]
 		locals = length cb.cb_init
 
+		typeresolver :: Name -> Maybe (MaybeError TypeError Type)
+		typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n]
+
 instance gen Initialisation
 where
 	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1
 
 instance gen Statement
 where
-	gen st=:(Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
-		Just i -> comment (toString st) *> gen app *>
-		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> shrinkStack 1
+	gen st=:(Declaration n e) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+		Just i -> checkTypeName n e *>
+		          comment (toString st) *>
+		          gen e *>
+		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> // TODO should depend on size of return type
+		          shrinkStack 1
 		_      -> liftT $ Error $ UndefinedName n
-	gen (Application e)   = comment "Application" *> gen e *> tell ['ABC'.Pop_a 1] *> shrinkStack 1
-	gen (Return (Just e)) = comment "Return" *> gen e *> cleanup *> tell ['ABC'.Rtn]
-	gen (Return Nothing)  = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
-	gen (MachineStm s)    = tell ['ABC'.Raw s]
-	gen (If blocks else)  =
+	gen (Application e) =
+		comment "Application" *>
+		gen e *>
+		getTypeResolver >>= \tr -> case fmap typeSize <$> type tr e of
+			Just (Ok 0)      -> nop
+			Just (Ok sz)     -> tell ['ABC'.Pop_a sz] *> shrinkStack sz
+			Just (Error err) -> error $ TypeError err e
+			Nothing          -> error $ CouldNotDeduceType e
+	gen (Return (Just e)) =
+		comment "Return" *>
+		gen e *>
+		cleanup *>
+		tell ['ABC'.Rtn]
+	gen (Return Nothing) =
+		comment "Return" *>
+		cleanup *>
+		tell ['ABC'.Rtn]
+	gen (MachineStm s) =
+		tell ['ABC'.Raw s]
+	gen (If blocks else) =
 		fresh "ifend" >>= \end ->
 		mapM_ (genifblock end) blocks *>
 		genelse end else
 	where
 		genifblock :: 'ABC'.Label (Expression, CodeBlock) -> Gen ()
 		genifblock end (cond, cb) =
+			checkType TBool cond *>
 			fresh "ifelse" >>= \else ->
 			gen cond *>
 			toBStack 'ABC'.BT_Bool 1 *>
@@ -213,6 +289,7 @@ where
 		genelse end Nothing   = tell ['ABC'.Label end]
 		genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
 	gen (While cond do) =
+		checkType TBool cond *>
 		fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
 		tell [ 'ABC'.Label loop ] *>
 		gen cond *>
@@ -240,9 +317,9 @@ where
 				comment "Apply function" *>
 				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
 				     , 'ABC'.Jsr n
-				     , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
+				     , 'ABC'.Annotation $ 'ABC'.OAnnot (typeSize fs.fs_rettype) []
 				     ] *>
-				shrinkStack (fs.fs_arity - 1)
+				shrinkStack (fs.fs_arity - typeSize fs.fs_rettype)
 			_ -> liftT $ Error $ UndefinedName n
 	gen (BuiltinApp op arg) = gen arg *> gen op
 	gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op