Type checking

9 files changed, 234 insertions, 46 deletions

diff --git a/Sil/Check.icl b/Sil/Check.icl
index 37ee282..61f5ac7 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -15,6 +15,7 @@ import Data.Tuple
 from Text import <+
 
 import Sil.Syntax
+import Sil.Types
 
 instance toString CheckError
 where
diff --git a/Sil/Compile.dcl b/Sil/Compile.dcl
index 6407b67..4857ba9 100644
--- a/Sil/Compile.dcl
+++ b/Sil/Compile.dcl
@@ -7,12 +7,16 @@ from Data.Error import :: MaybeError
 
 from ABC.Assembler import :: Assembler, :: Statement, instance <<< Assembler
 
-from Sil.Syntax import :: Program, :: Name
+from Sil.Syntax import :: Program, :: Name, :: Expression
+from Sil.Types import :: Type, :: TypeError
 
 :: CompileError
 	= UndefinedName Name
 	| VariableLabel
 	| FunctionOnStack
+	| TypeError TypeError Expression
+	| CouldNotDeduceType Expression
+	| TypeMisMatch Type Expression
 	| UnknownError
 
 instance toString CompileError
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
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 806ac69..fb77def 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -21,6 +21,7 @@ from Text import <+, class Text, instance Text String
 import GenEq
 
 import Sil.Syntax
+import Sil.Types
 import Sil.Util.Parser
 import Sil.Util.Printer
 
@@ -119,7 +120,7 @@ function =
 	item TParenClose *>
 	item TBraceOpen *>
 	codeblock >>= \cb ->
-	item TBraceClose *> pure
+	item TBraceClose $>
 		{ f_type = t
 		, f_name = n
 		, f_args = args
@@ -135,8 +136,8 @@ initialisation :: Parser Token [Initialisation]
 initialisation =
 	type >>= \t ->
 	seplist TComma name >>= \ns ->
-	item TSemicolon >>= \_ ->
-	pure [{init_type=t, init_name=n} \\ n <- ns]
+	item TSemicolon $>
+	[{init_type=t, init_name=n} \\ n <- ns]
 
 statement :: Parser Token Statement
 statement = declaration
@@ -192,7 +193,7 @@ expression
 	$ noInfix
 where
 	op :: Token Op2 -> Parser Token Op2
-	op token operator = item token *> pure operator
+	op token operator = item token $> operator
 
 	rightAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
 	rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
@@ -231,7 +232,7 @@ type
 	<|> type "Void" TVoid
 	<?> Expected "type"
 where
-	type s t = item (TName s) *> pure t
+	type s t = item (TName s) $> t
 
 literal :: Parser Token Literal
 literal = satisfy isLit >>= \(TLit lit) -> pure lit
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 1aa0c8b..1b3b44a 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -4,6 +4,8 @@ from StdOverloaded import class toString
 
 from Data.Maybe import :: Maybe
 
+from Sil.Types import :: Type
+
 :: Program =
 	{ p_funs :: [Function]
 	}
@@ -59,11 +61,6 @@ from Data.Maybe import :: Maybe
 	| LogOr  //* ||
 	| LogAnd //* &&
 
-:: Type
-	= TBool
-	| TInt
-	| TVoid
-
 :: Literal
 	= BLit Bool
 	| ILit Int
@@ -71,7 +68,6 @@ from Data.Maybe import :: Maybe
 :: Name :== String
 
 instance toString Statement
-instance toString Type
 instance toString Arg
 instance toString Expression
 instance toString Op1
@@ -92,8 +88,3 @@ instance allCodeBlocks Statement
 class allLocals a :: a -> [(Type, Name)]
 instance allLocals Function
 instance allLocals CodeBlock
-
-/**
- * Size of an expression on the stack
- */
-typeSize :: Type -> Int
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 8083eba..43d27fc 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -9,6 +9,7 @@ import Data.List
 import Data.Maybe
 import Text
 
+import Sil.Types
 import Sil.Util.Printer
 
 instance toString Statement
@@ -21,12 +22,6 @@ where
 	toString (MachineStm s)    = "|~" <+ s
 	toString _                 = "<<unimplemented Statement>>"
 
-instance toString Type
-where
-	toString TBool = "Bool"
-	toString TInt  = "Int"
-	toString TVoid = "Void"
-
 instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
 
 instance toString Expression
@@ -96,8 +91,3 @@ where
 
 instance allLocals CodeBlock
 where allLocals cb = [(i.init_type, i.init_name) \\ i <- cb.cb_init]
-
-typeSize :: Type -> Int
-typeSize TVoid = 0
-typeSize TBool = 1
-typeSize TInt  = 1
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
new file mode 100644
index 0000000..1659436
--- /dev/null
+++ b/Sil/Types.dcl
@@ -0,0 +1,36 @@
+definition module Sil.Types
+
+from StdOverloaded import class ==, class toString
+
+from Data.Error import :: MaybeError
+from Data.Maybe import :: Maybe
+
+from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
+
+:: Type
+	= TBool
+	| TInt
+	| TVoid
+	| (-->) infixr Type Type
+
+:: TypeError
+	= IllegalApplication Type Type
+
+instance == Type
+
+instance toString Type
+instance toString TypeError
+
+/**
+ * Size of an expression on the stack
+ */
+typeSize :: Type -> Int
+
+:: TypeResolver :== Name -> Maybe (MaybeError TypeError Type)
+
+class type a :: TypeResolver a -> Maybe (MaybeError TypeError Type)
+instance type Function
+instance type Expression
+instance type Name
+instance type Op1
+instance type Op2
diff --git a/Sil/Types.icl b/Sil/Types.icl
new file mode 100644
index 0000000..5f17956
--- /dev/null
+++ b/Sil/Types.icl
@@ -0,0 +1,87 @@
+implementation module Sil.Types
+
+import StdList
+import StdOverloaded
+import StdString
+
+import Control.Applicative
+import Control.Monad
+import Data.Error
+from Data.Func import $
+import Data.Maybe
+from Text import <+
+
+import GenEq
+
+import Sil.Syntax
+
+derive gEq Type
+instance == Type where == a b = gEq{|*|} a b
+
+instance toString Type
+where
+	toString TBool = "Bool"
+	toString TInt  = "Int"
+	toString TVoid = "Void"
+	toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
+
+instance toString TypeError
+where
+	toString (IllegalApplication ft et) = "Cannot apply a " <+ et <+ " to a " <+ ft <+ "."
+
+typeSize :: Type -> Int
+typeSize TVoid = 0
+typeSize TBool = 1
+typeSize TInt  = 1
+
+instance type Function
+where
+	type res f = Just $ Ok $ foldr (-->) f.f_type [a.arg_type \\ a <- f.f_args]
+
+instance type Expression
+where
+	type res (Name n) = type res n
+	type res (Literal lit) = case lit of
+		BLit _ -> Just $ Ok TBool
+		ILit _ -> Just $ Ok TInt
+	type res (App n args) =
+		mapM (type res) args >>= \ats ->
+		res n >>= \ft -> pure
+		( sequence ats >>= \ats ->
+		  ft           >>= \ft  -> foldM tryApply ft ats)
+	type res (BuiltinApp op e) =
+		type res e  >>= \te  ->
+		type res op >>= \top -> pure
+		( top >>= \top ->
+		  te  >>= \te  -> tryApply top te)
+	type res (BuiltinApp2 e1 op e2) =
+		type res e1 >>= \te1 ->
+		type res e2 >>= \te2 ->
+		type res op >>= \top -> pure
+		( top >>= \top ->
+		  te1 >>= \te1 ->
+		  te2 >>= \te2 -> foldM tryApply top [te1,te2])
+
+tryApply :: Type Type -> MaybeError TypeError Type
+tryApply ft=:(at --> rt) et
+| et == at     = Ok rt
+| otherwise    = Error $ IllegalApplication ft et
+tryApply ft et = Error $ IllegalApplication ft et
+
+instance type Name where type res n = res n
+
+instance type Op1
+where
+	type _ Neg = Just $ Ok $ TInt  --> TInt
+	type _ Not = Just $ Ok $ TBool --> TBool
+
+instance type Op2
+where
+	type _ Add    = Just $ Ok $ TInt  --> TInt  --> TInt
+	type _ Sub    = Just $ Ok $ TInt  --> TInt  --> TInt
+	type _ Mul    = Just $ Ok $ TInt  --> TInt  --> TInt
+	type _ Div    = Just $ Ok $ TInt  --> TInt  --> TInt
+	type _ Rem    = Just $ Ok $ TInt  --> TInt  --> TInt
+	type _ Equals = Just $ Ok $ TInt  --> TInt  --> TBool
+	type _ LogOr  = Just $ Ok $ TBool --> TBool --> TBool
+	type _ LogAnd = Just $ Ok $ TBool --> TBool --> TBool
diff --git a/Sil/Util/Printer.icl b/Sil/Util/Printer.icl
index d35281b..ff9c3f2 100644
--- a/Sil/Util/Printer.icl
+++ b/Sil/Util/Printer.icl
@@ -15,6 +15,7 @@ import Text
 
 import Sil.Parse
 import Sil.Syntax
+import Sil.Types
 
 :: PrintState =
 	{ indent :: Int