1 files changed, 109 insertions, 0 deletions
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
new file mode 100644
index 0000000..4313c0e
--- /dev/null
+++ b/Sil/Compile.icl
@@ -0,0 +1,109 @@
+implementation module Sil.Compile
+
+import StdList
+import StdString
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.RWST
+import Control.Monad.Trans
+import Data.Error
+from Data.Func import $
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Monoid
+from Text import <+
+
+import qualified ABC.Assembler as ABC
+
+import Sil.Syntax
+
+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."
+
+compile :: Program -> MaybeError CompileError 'ABC'.Assembler
+compile prog = case evalRWST start () zero of
+	Error e  -> Error e
+	Ok (_,p) -> Ok p
+where
+	start = mapM_ gen prog.p_funs
+
+:: Address
+	= LabelAddr String
+	| StackAddr Int
+
+:: CompileState =
+	{ labels    :: ['ABC'.Label]
+	, addresses :: 'M'.Map Name Address
+	}
+
+instance zero CompileState
+where
+	zero =
+		{ labels    = ["_l" <+ i \\ i <- [0..]]
+		, addresses = 'M'.newMap
+		}
+
+labels :: CompileState -> ['ABC'.Label]
+labels cs = cs.labels
+
+addresses :: CompileState -> 'M'.Map Name Address
+addresses cs = cs.addresses
+
+:: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
+
+fresh :: Gen 'ABC'.Label
+fresh = gets labels
+	>>= \labs -> modify (\cs -> {cs & labels=tl labs})
+	*> pure (hd labs)
+
+reserveVar :: Int Name -> Gen Int
+reserveVar i n = modify (\cs -> {cs & addresses='M'.put n (StackAddr i) cs.addresses}) *> pure (i + 1)
+
+class gen a :: a -> Gen ()
+
+instance gen Function
+where
+	gen f = tell ['ABC'.Label f.f_name] *> gen f.f_code
+
+instance gen CodeBlock
+where
+	gen cb = foldM reserveVar 1 [i.init_name \\ i <- cb.cb_init] *>
+		mapM_ gen cb.cb_init *>
+		mapM_ gen cb.cb_content
+
+instance gen Initialisation
+where
+	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]
+
+instance gen Statement
+where
+	gen (Declaration n app) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+		Just (StackAddr i) -> comment "Declaration" *> gen app *> tell ['ABC'.Fill_a 0 i]
+		Just (LabelAddr _) -> liftT $ Error VariableLabel
+		_                  -> liftT $ Error $ UndefinedName n
+	gen (Application app)   = comment "Application" *> gen app
+	gen (Return (Just app)) = comment "Return" *> gen app *> tell ['ABC'.Rtn]
+	gen (Return Nothing)    = comment "Return" *> tell ['ABC'.Rtn]
+
+instance gen Application
+where
+	gen (Name n) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+		Just (StackAddr i) -> comment "Retrieve name" *> tell ['ABC'.Push_a i]
+		Just (LabelAddr _) -> liftT $ Error VariableLabel
+		_                  -> liftT $ Error $ UndefinedName n
+	gen (Literal (BLit b)) = comment "Literal" *> tell ['ABC'.Create, 'ABC'.FillB b 0]
+	gen (Literal (ILit i)) = comment "Literal" *> tell ['ABC'.Create, 'ABC'.FillI i 0]
+	gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+		Just (LabelAddr l) ->
+			comment "Retrieve arguments" *> mapM gen args *>
+			comment "Apply function" *> tell ['ABC'.Jsr l]
+		Just (StackAddr _) -> liftT $ Error FunctionOnStack
+		_                  -> liftT $ Error $ UndefinedName n
+
+comment :: String -> Gen ()
+comment s = tell ['ABC'.Comment s]