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

4 files changed, 129 insertions, 21 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]
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index a2f92cb..6febca5 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -15,6 +15,12 @@ from Sil.Syntax import :: Program, :: Literal
 	| TComma              //* ,
 	| TSemicolon          //* ;
 	| TAssign             //* :=
+	| TTilde              //* ~
+	| TPlus               //* +
+	| TMinus              //* -
+	| TStar               //* *
+	| TSlash              //* /
+	| TPercent            //* %
 	| TLit Literal        //* True; False; integers
 	| TIf                 //* if
 	| TWhile              //* while
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 925423c..ec25c1f 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -36,6 +36,12 @@ where
 	toString TComma           = ","
 	toString TSemicolon       = ";"
 	toString TAssign          = ":="
+	toString TTilde           = "~"
+	toString TPlus            = "+"
+	toString TMinus           = "-"
+	toString TStar            = "*"
+	toString TSlash           = "/"
+	toString TPercent         = "%"
 	toString (TLit l)         = toString l
 	toString TIf              = "if"
 	toString TWhile           = "while"
@@ -67,6 +73,12 @@ where
 	tks ['}':r] t = tks r [TBraceClose:t]
 	tks [',':r] t = tks r [TComma     :t]
 	tks [';':r] t = tks r [TSemicolon :t]
+	tks ['~':r] t = tks r [TTilde     :t]
+	tks ['+':r] t = tks r [TPlus      :t]
+	tks ['-':r] t = tks r [TMinus     :t]
+	tks ['*':r] t = tks r [TStar      :t]
+	tks ['/':r] t = tks r [TSlash     :t]
+	tks ['%':r] t = tks r [TPercent   :t]
 	tks [':':'=':r] t = tks r [TAssign    :t]
 	tks ['i':'f'                :s:r] t | isSpace s = tks r [TIf    :t]
 	tks ['w':'h':'i':'l':'e'    :s:r] t | isSpace s = tks r [TWhile :t]
@@ -131,12 +143,6 @@ where
 	declaration :: Parser Token Statement
 	declaration = liftM2 Declaration name (item TAssign *> application)
 
-	application :: Parser Token Application
-	application
-		=   liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
-		<|> liftM Literal literal
-		<|> liftM Name name
-
 	return :: Parser Token Statement
 	return = liftM Return (item TReturn *> optional application)
 
@@ -144,6 +150,33 @@ where
 	machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
 	where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
 
+application :: Parser Token Application
+application
+	= leftAssoc
+		(   op TPlus    Add
+		<|> op TMinus   Sub
+		)
+	$ leftAssoc
+		(   op TStar    Mul
+		<|> op TSlash   Div
+		<|> op TPercent Rem
+		)
+	$ noInfix
+where
+	op :: Token Op2 -> Parser Token Op2
+	op token operator = item token *> pure operator
+
+	leftAssoc :: (Parser Token Op2) (Parser Token Application) -> Parser Token Application
+	leftAssoc opp appp = appp >>= \e1 -> many (opp >>= \op -> appp >>= \e -> pure (op,e))
+		>>= foldM (\e (op,e2) -> pure $ BuiltinApp2 e op e2) e1
+
+	noInfix :: Parser Token Application
+	noInfix
+		=   liftM2 App name (item TParenOpen *> seplist TComma application <* item TParenClose)
+		<|> liftM (BuiltinApp Neg) (item TTilde *> noInfix)
+		<|> liftM Literal literal
+		<|> liftM Name name
+
 name :: Parser Token Name
 name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
 where
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 3fdb8f1..d6662ef 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -40,6 +40,18 @@ from Data.Maybe import :: Maybe
 	= Name Name
 	| Literal Literal
 	| App Name [Application]
+	| BuiltinApp Op1 Application
+	| BuiltinApp2 Application Op2 Application
+
+:: Op1
+	= Neg //* ~
+
+:: Op2
+	= Add //* +
+	| Sub //* -
+	| Mul //* *
+	| Div //* /
+	| Rem //* %
 
 :: Type
 	= TBool