Working fibonacci

5 files changed, 167 insertions, 53 deletions

diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 2609f7c..4c0d02d 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -40,21 +40,23 @@ 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]
-	, stackoffset :: Int
+	{ labels        :: ['ABC'.Label]
+	, addresses     :: 'M'.Map Name Address
+	, symbols       :: 'M'.Map Name FunctionSymbol
+	, returns       :: ['ABC'.Assembler]
+	, stackoffset   :: Int
+	, storedoffsets :: [Int]
 	}
 
 instance zero CompileState
 where
 	zero =
-		{ labels      = ["_l" <+ i \\ i <- [0..]]
-		, addresses   = 'M'.newMap
-		, symbols     = 'M'.newMap
-		, returns     = []
-		, stackoffset = 0
+		{ labels        = ["_l" <+ i \\ i <- [0..]]
+		, addresses     = 'M'.newMap
+		, symbols       = 'M'.newMap
+		, returns       = []
+		, stackoffset   = 0
+		, storedoffsets = []
 		}
 
 labels :: CompileState -> ['ABC'.Label]
@@ -84,12 +86,19 @@ peekReturn cs = hd cs.returns
 stackoffset :: CompileState -> Int
 stackoffset cs = cs.stackoffset
 
+storeStackOffset :: CompileState -> CompileState
+storeStackOffset cs = {cs & storedoffsets=[cs.stackoffset:cs.storedoffsets]}
+
+restoreStackOffset :: CompileState -> CompileState
+restoreStackOffset cs = {cs & stackoffset=so, storedoffsets=sos}
+where [so:sos] = cs.storedoffsets
+
 :: Gen a :== RWST () 'ABC'.Assembler CompileState (MaybeError CompileError) a
 
-fresh :: Gen 'ABC'.Label
-fresh = gets labels
+fresh :: a -> Gen 'ABC'.Label | toString a
+fresh n = gets labels
 	>>= \labs -> modify (\cs -> {cs & labels=tl labs})
-	*> pure (hd labs)
+	*> pure (n <+ hd labs)
 
 reserveVar :: Int Name -> Gen Int
 reserveVar i n = modify (\cs -> {cs & addresses='M'.put n i cs.addresses}) *> pure (i+1)
@@ -130,11 +139,14 @@ where
 		     , 'ABC'.Label f.f_name
 		     ] *>
 		foldM reserveVar locals [a.arg_name \\ a <- reverse f.f_args] *>
-		modify (newReturn cleanup) *>
+		modify (newReturn cleanup`) *>
 		gen f.f_code *>
+		cleanup *>
+		shrinkStack (args - 1) *>
+		tell ['ABC'.Rtn] *>
 		modify popReturn
 	where
-		cleanup = case f.f_args of
+		cleanup` = case f.f_args of
 			[] -> [ 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
 			      ]
 			_  -> [ 'ABC'.Comment "Cleanup"
@@ -147,13 +159,15 @@ where
 
 instance gen CodeBlock
 where
-	gen cb = foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
+	gen cb =
+		modify storeStackOffset *>
+		foldM reserveVar 0 [i.init_name \\ i <- cb.cb_init] *>
 		mapM_ gen cb.cb_init *>
 		modify (addToReturn cleanup`) *>
 		mapM_ gen cb.cb_content *>
-		cleanup *>
-		tell ['ABC'.Rtn] *>
-		modify (removeFromReturn $ length cleanup`)
+		tell cleanup` *>
+		modify (removeFromReturn $ length cleanup`) *>
+		modify restoreStackOffset
 	where
 		cleanup` = case cb.cb_init of
 			[] -> []
@@ -164,7 +178,7 @@ where
 
 instance gen Initialisation
 where
-	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create]
+	gen init = comment ("Initialise " <+ init.init_name) *> tell ['ABC'.Create] *> growStack 1
 
 instance gen Statement
 where
@@ -176,6 +190,28 @@ where
 	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]
+	gen (If c t Nothing) =
+		fresh "ifend" >>= \end ->
+		comment "condition" *>
+		gen c *>
+		toBStack 'ABC'.BT_Bool 1 *>
+		tell [ 'ABC'.JmpFalse end ] *>
+		comment "if-true" *>
+		gen t *>
+		tell [ 'ABC'.Label end ]
+	gen (If c t (Just e)) =
+		fresh "else" >>= \else -> fresh "ifend" >>= \end ->
+		comment "condition" *>
+		gen c *>
+		toBStack 'ABC'.BT_Bool 1 *>
+		tell [ 'ABC'.JmpFalse else ] *>
+		comment "if-true" *>
+		gen t *>
+		tell [ 'ABC'.Jmp end
+		     , 'ABC'.Label else ] *>
+		comment "if-false" *>
+		gen e *>
+		tell [ 'ABC'.Label end ]
 
 instance gen Application
 where
@@ -197,10 +233,10 @@ where
 				     , 'ABC'.Jsr n
 				     , 'ABC'.Annotation $ 'ABC'.OAnnot 1 []
 				     ] *>
-				shrinkStack fs.fs_arity
+				shrinkStack (fs.fs_arity - 1)
 			_ -> 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
+	gen (BuiltinApp op arg) = gen arg *> gen op
+	gen (BuiltinApp2 e1 op e2) = mapM gen [e1,e2] *> gen op
 
 instance gen Op1
 where
@@ -217,24 +253,38 @@ where
 	gen op =
 		toBStack 'ABC'.BT_Int 2 *>
 		tell [instr] *>
-		BtoAStack 'ABC'.BT_Int
+		BtoAStack rettype
 	where
 		instr = case op of
-			Add -> 'ABC'.AddI
-			Sub -> 'ABC'.SubI
-			Mul -> 'ABC'.MulI
-			Div -> 'ABC'.DivI
-			Rem -> 'ABC'.RemI
+			Add    -> 'ABC'.AddI
+			Sub    -> 'ABC'.SubI
+			Mul    -> 'ABC'.MulI
+			Div    -> 'ABC'.DivI
+			Rem    -> 'ABC'.RemI
+			Equals -> 'ABC'.EqI
+			LogOr  -> 'ABC'.AddI // TODO remove hack
+			LogAnd -> 'ABC'.MulI // TODO remove hack
+		rettype = case op of
+			Equals -> 'ABC'.BT_Bool
+			_      -> 'ABC'.BT_Int
 
 toBStack :: 'ABC'.BasicType Int -> Gen ()
-toBStack t n = tell [push i \\ i <- [0..n-1]] *> tell ['ABC'.Pop_a (n-1)]
+toBStack t n =
+	tell [push i \\ i <- [0..n-1]] *>
+	tell (if (n <> 0) ['ABC'.Pop_a n] []) *>
+	shrinkStack n
 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]
+BtoAStack t =
+	tell [ 'ABC'.Create
+	     , fill 0 0
+	     , 'ABC'.Pop_b 1
+	     ] *>
+	growStack 1
 where
 	fill = case t of
 		'ABC'.BT_Bool -> 'ABC'.FillB_b
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 6febca5..0d00969 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -21,8 +21,12 @@ from Sil.Syntax import :: Program, :: Literal
 	| TStar               //* *
 	| TSlash              //* /
 	| TPercent            //* %
+	| TDoubleEquals       //* ==
+	| TDoubleBar          //* ||
+	| TDoubleAmpersand    //* &&
 	| TLit Literal        //* True; False; integers
 	| TIf                 //* if
+	| TElse               //* else
 	| TWhile              //* while
 	| TReturn             //* return
 	| TMachineCode String //* |~ machine code
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index ec25c1f..092d3da 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -67,6 +67,10 @@ tokenise cs = reverse <$> tks cs []
 where
 	tks :: [Char] [Token] -> MaybeError ParseError [Token]
 	tks [] t = pure t
+	tks [':':'=':r] t = tks r [TAssign         :t]
+	tks ['=':'=':r] t = tks r [TDoubleEquals   :t]
+	tks ['|':'|':r] t = tks r [TDoubleBar      :t]
+	tks ['&':'&':r] t = tks r [TDoubleAmpersand:t]
 	tks ['(':r] t = tks r [TParenOpen :t]
 	tks [')':r] t = tks r [TParenClose:t]
 	tks ['{':r] t = tks r [TBraceOpen :t]
@@ -79,8 +83,8 @@ where
 	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 ['e':'l':'s':'e'        :s:r] t | isSpace s = tks r [TElse  :t]
 	tks ['w':'h':'i':'l':'e'    :s:r] t | isSpace s = tks r [TWhile :t]
 	tks ['r':'e':'t':'u':'r':'n':s:r] t | isSpace s = tks r [TReturn:t]
 	tks ['T':'r':'u':'e'        :s:r] t | isSpace s = tks r [TLit $ BLit True :t]
@@ -137,8 +141,8 @@ statement :: Parser Token Statement
 statement = ((declaration
 	<|> liftM Application application
 	<|> return
-/*	<|> if`
-	<|> while*/) <* item TSemicolon) <|> machinecode
+	<|> if`
+	/*<|> while*/) <* item TSemicolon) <|> machinecode
 where
 	declaration :: Parser Token Statement
 	declaration = liftM2 Declaration name (item TAssign *> application)
@@ -150,22 +154,36 @@ where
 	machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
 	where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
 
+	if` :: Parser Token Statement
+	if` = item TIf *>
+		parenthised application >>= \cond ->
+		braced codeblock >>= \iftrue ->
+		optional (item TElse *> braced codeblock) >>= \iffalse ->
+		pure $ If cond iftrue iffalse
+
 application :: Parser Token Application
 application
-	= leftAssoc
-		(   op TPlus    Add
-		<|> op TMinus   Sub
+	= rightAssoc (op TDoubleBar       LogOr)
+	$ rightAssoc (op TDoubleAmpersand LogAnd)
+	$ rightAssoc (op TDoubleEquals    Equals)
+	$ leftAssoc
+		(         op TPlus            Add
+		<|>       op TMinus           Sub
 		)
 	$ leftAssoc
-		(   op TStar    Mul
-		<|> op TSlash   Div
-		<|> op TPercent Rem
+		(         op TStar            Mul
+		<|>       op TSlash           Div
+		<|>       op TPercent         Rem
 		)
 	$ noInfix
 where
 	op :: Token Op2 -> Parser Token Op2
 	op token operator = item token *> pure operator
 
+	rightAssoc :: (Parser Token Op2) (Parser Token Application) -> Parser Token Application
+	rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
+		>>= pure o maybe e1 (\(op,e2) -> BuiltinApp2 e1 op e2)
+
 	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
@@ -202,3 +220,9 @@ where
 	isLit :: Token -> Bool
 	isLit (TLit _) = True
 	isLit _        = False
+
+parenthised :: (Parser Token a) -> Parser Token a
+parenthised p = item TParenOpen *> p <* item TParenClose
+
+braced :: (Parser Token a) -> Parser Token a
+braced p = item TBraceOpen *> p <* item TBraceClose
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index d6662ef..6df64a3 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,11 +47,14 @@ from Data.Maybe import :: Maybe
 	= Neg //* ~
 
 :: Op2
-	= Add //* +
-	| Sub //* -
-	| Mul //* *
-	| Div //* /
-	| Rem //* %
+	= Add    //* +
+	| Sub    //* -
+	| Mul    //* *
+	| Div    //* /
+	| Rem    //* %
+	| Equals //* ==
+	| LogOr  //* ||
+	| LogAnd //* &&
 
 :: Type
 	= TBool
diff --git a/Sil/Util.icl b/Sil/Util.icl
index ad7cfac..35b8522 100644
--- a/Sil/Util.icl
+++ b/Sil/Util.icl
@@ -22,6 +22,12 @@ import Sil.Syntax
 
 instance zero PrintState where zero = {indent=0}
 
+incIndent :: PrintState -> PrintState
+incIndent ps = {ps & indent=inc ps.indent}
+
+decIndent :: PrintState -> PrintState
+decIndent ps = {ps & indent=dec ps.indent}
+
 instance toString PrintState where toString st = {'\t' \\ _ <- [1..st.indent]}
 
 instance PrettyPrinter [Token]
@@ -83,14 +89,24 @@ instance PrettyPrinter Initialisation
 where
 	print st init = st <+ init.init_type <+ " " <+ init.init_name <+ ";"
 
-instance PrettyPrinter Statement where print st stm = st <+ stm <+ ";"
+instance PrettyPrinter Statement
+where
+	print st (If c t Nothing) = st <+ "if (" <+ c <+ ") {\r\n" <+
+		print (incIndent st) t <+ "\r\n" <+ st <+ "}"
+	print st (If c t (Just e)) = st <+ "if (" <+ c <+ ") {\r\n" <+
+		print st` t <+ "\r\n" <+ st <+ "} else {\r\n" <+
+		print st` e <+ "\r\n" <+ st <+ "}"
+	where st` = incIndent st
+	print st stm = st <+ stm
 
 instance toString Statement
 where
-	toString (Declaration n a) = n <+ " " <+ TAssign <+ " " <+ a
-	toString (Application app) = toString app
-	toString (Return Nothing)  = "return"
-	toString (Return (Just a)) = "return " <+ a <+ ""
+	toString (Declaration n a) = n <+ " " <+ TAssign <+ " " <+ a <+ ";"
+	toString (Application app) = toString app <+ ";"
+	toString (Return Nothing)  = "return;"
+	toString (Return (Just a)) = "return " <+ a <+ ";"
+	toString (If c t e)        = "if (" <+ c <+ ") ..."
+	toString (MachineStm s)    = "|~" <+ s
 	toString _                 = "<<unimplemented Statement>>"
 
 instance toString Type
@@ -103,9 +119,26 @@ instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
 
 instance toString Application
 where
-	toString (Name n)      = n
-	toString (Literal lit) = toString lit
-	toString (App n args)  = n <+ "(" <+ printersperse ", " args <+ ")"
+	toString (Name n)               = n
+	toString (Literal lit)          = toString lit
+	toString (App n args)           = n <+ "(" <+ printersperse ", " args <+ ")"
+	toString (BuiltinApp op e)      = op <+ "(" <+ e <+ ")"
+	toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
+
+instance toString Op1
+where
+	toString Neg = "~"
+
+instance toString Op2
+where
+	toString Add    = "+"
+	toString Sub    = "-"
+	toString Mul    = "*"
+	toString Div    = "/"
+	toString Rem    = "%"
+	toString Equals = "=="
+	toString LogOr  = "||"
+	toString LogAnd = "&&"
 
 instance toString Literal
 where