Add +, -, *, /, %, ~

1 files changed, 72 insertions, 15 deletions

diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index baeb2fd..2609f7c 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,5 +1,7 @@
 implementation module Sil.Compile
 
+import StdEnum
+from StdFunc import o
 import StdList
 import StdString
 
@@ -38,19 +40,21 @@ compile prog = case evalRWST (gen prog) () zero of
 	}
 
 :: CompileState =
-	{ labels    :: ['ABC'.Label]
-	, addresses :: 'M'.Map Name Address
-	, symbols   :: 'M'.Map Name FunctionSymbol
-	, returns   :: ['ABC'.Assembler]
+	{ labels      :: ['ABC'.Label]
+	, addresses   :: 'M'.Map Name Address
+	, symbols     :: 'M'.Map Name FunctionSymbol
+	, returns     :: ['ABC'.Assembler]
+	, stackoffset :: Int
 	}
 
 instance zero CompileState
 where
 	zero =
-		{ labels    = ["_l" <+ i \\ i <- [0..]]
-		, addresses = 'M'.newMap
-		, symbols   = 'M'.newMap
-		, returns   = []
+		{ labels      = ["_l" <+ i \\ i <- [0..]]
+		, addresses   = 'M'.newMap
+		, symbols     = 'M'.newMap
+		, returns     = []
+		, stackoffset = 0
 		}
 
 labels :: CompileState -> ['ABC'.Label]
@@ -77,6 +81,9 @@ popReturn cs = {cs & returns=tl cs.returns}
 peekReturn :: CompileState -> 'ABC'.Assembler
 peekReturn cs = hd cs.returns
 
+stackoffset :: CompileState -> Int
+stackoffset cs = cs.stackoffset
+
 :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
 
 fresh :: Gen 'ABC'.Label
@@ -93,6 +100,12 @@ addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name {fs_arity=length f
 cleanup :: Gen ()
 cleanup = gets peekReturn >>= tell
 
+growStack :: Int -> Gen ()
+growStack n = modify (\cs -> {cs & stackoffset=cs.stackoffset + n})
+
+shrinkStack :: (Int -> Gen ())
+shrinkStack = growStack o ((-) 0)
+
 class gen a :: a -> Gen ()
 
 instance gen Program
@@ -159,18 +172,21 @@ where
 		Just i -> comment (toString st) *> gen app *>
 		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1]
 		_      -> liftT $ Error $ UndefinedName n
-	gen (Application app)   = comment "Application" *> gen app
+	gen (Application app)   = comment "Application" *> gen app *> tell ['ABC'.Pop_a 1]
 	gen (Return (Just app)) = comment "Return" *> gen app *> cleanup *> tell ['ABC'.Rtn]
 	gen (Return Nothing)    = comment "Return" *> cleanup *> tell ['ABC'.Rtn]
 	gen (MachineStm s)      = tell ['ABC'.Raw s]
 
 instance gen Application
 where
-	gen (Name n) = gets addresses >>= \addrs -> case 'M'.get n addrs of
-		Just i -> tell ['ABC'.Push_a i]
-		_      -> liftT $ Error $ UndefinedName n
-	gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0]
-	gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0]
+	gen (Name n) =
+		gets stackoffset >>= \so ->
+		gets addresses >>= \addrs ->
+		case 'M'.get n addrs of
+			Just i -> tell ['ABC'.Push_a $ i + so] *> growStack 1
+			_      -> liftT $ Error $ UndefinedName n
+	gen (Literal (BLit b)) = tell ['ABC'.Create, 'ABC'.FillB b 0] *> growStack 1
+	gen (Literal (ILit i)) = tell ['ABC'.Create, 'ABC'.FillI i 0] *> growStack 1
 	gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
 		Just i -> liftT $ Error FunctionOnStack
 		_      -> gets symbols >>= \syms -> case 'M'.get n syms of
@@ -180,8 +196,49 @@ where
 				tell [ 'ABC'.Annotation $ 'ABC'.DAnnot fs.fs_arity []
 				     , 'ABC'.Jsr n
 				     , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
-				     ]
+				     ] *>
+				shrinkStack fs.fs_arity
 			_ -> liftT $ Error $ UndefinedName n
+	gen (BuiltinApp op arg) = gen arg *> gen op *> growStack 1
+	gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op *> growStack 1
+
+instance gen Op1
+where
+	gen op =
+		toBStack 'ABC'.BT_Int 1 *>
+		tell [instr] *>
+		BtoAStack 'ABC'.BT_Int
+	where
+		instr = case op of
+			Neg -> 'ABC'.NegI
+
+instance gen Op2
+where
+	gen op =
+		toBStack 'ABC'.BT_Int 2 *>
+		tell [instr] *>
+		BtoAStack 'ABC'.BT_Int
+	where
+		instr = case op of
+			Add -> 'ABC'.AddI
+			Sub -> 'ABC'.SubI
+			Mul -> 'ABC'.MulI
+			Div -> 'ABC'.DivI
+			Rem -> 'ABC'.RemI
+
+toBStack :: 'ABC'.BasicType Int -> Gen ()
+toBStack t n = tell [push i \\ i <- [0..n-1]] *> tell ['ABC'.Pop_a (n-1)]
+where
+	push = case t of
+		'ABC'.BT_Bool -> 'ABC'.PushB_a
+		'ABC'.BT_Int  -> 'ABC'.PushI_a
+
+BtoAStack :: 'ABC'.BasicType -> Gen ()
+BtoAStack t = tell [fill 0 0, 'ABC'.Pop_b 1]
+where
+	fill = case t of
+		'ABC'.BT_Bool -> 'ABC'.FillB_b
+		'ABC'.BT_Int  -> 'ABC'.FillI_b
 
 comment :: String -> Gen ()
 comment s = tell ['ABC'.Comment s]