From 407a0c8e7e14b96c2a0487cefe09cdc021f002b0 Mon Sep 17 00:00:00 2001
From: Camil Staps
Date: Wed, 19 Jul 2017 12:57:01 +0000
Subject: Add while and !, fix error in consecutive declarations

---
 Sil/Compile.icl | 19 ++++++++++++++++---
 Sil/Parse.dcl   |  1 +
 Sil/Parse.icl   | 40 ++++++++++++++++++++++++++--------------
 Sil/Syntax.dcl  |  1 +
 4 files changed, 44 insertions(+), 17 deletions(-)

(limited to 'Sil')

diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index b4854ba..ca375b1 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -184,7 +184,7 @@ 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]
+		          tell ['ABC'.Update_a 0 $ i+1, 'ABC'.Pop_a 1] *> shrinkStack 1
 		_      -> liftT $ Error $ UndefinedName n
 	gen (Application e)   = comment "Application" *> gen e *> tell ['ABC'.Pop_a 1]
 	gen (Return (Just e)) = comment "Return" *> gen e *> cleanup *> tell ['ABC'.Rtn]
@@ -208,6 +208,15 @@ where
 		genelse :: 'ABC'.Label (Maybe CodeBlock) -> Gen ()
 		genelse end Nothing   = tell ['ABC'.Label end]
 		genelse end (Just cb) = gen cb *> tell ['ABC'.Label end]
+	gen (While cond do) =
+		fresh "while" >>= \loop -> fresh "whileend" >>= \end ->
+		tell [ 'ABC'.Label loop ] *>
+		gen cond *>
+		toBStack 'ABC'.BT_Bool 1 *>
+		tell [ 'ABC'.JmpFalse end ] *>
+		gen do *>
+		tell [ 'ABC'.Jmp loop
+		     , 'ABC'.Label end ]
 
 instance gen Expression
 where
@@ -237,12 +246,16 @@ where
 instance gen Op1
 where
 	gen op =
-		toBStack 'ABC'.BT_Int 1 *>
+		toBStack type 1 *>
 		tell [instr] *>
-		BtoAStack 'ABC'.BT_Int
+		BtoAStack type
 	where
 		instr = case op of
 			Neg -> 'ABC'.NegI
+			Not -> 'ABC'.NotB
+		type = case op of
+			Neg -> 'ABC'.BT_Int
+			Not -> 'ABC'.BT_Bool
 
 instance gen Op2
 where
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 73f9ad3..0db10e6 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -16,6 +16,7 @@ from Sil.Util.Parser import class name
 	| TSemicolon          //* ;
 	| TAssign             //* :=
 	| TTilde              //* ~
+	| TExclamation        //* !
 	| TPlus               //* +
 	| TMinus              //* -
 	| TStar               //* *
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 2ee2bc1..806ac69 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -71,18 +71,19 @@ where
 	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]
-	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 [TParenOpen  :t]
+	tks [')':r] t = tks r [TParenClose :t]
+	tks ['{':r] t = tks r [TBraceOpen  :t]
+	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 [TExclamation: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 ['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]
@@ -142,7 +143,7 @@ statement = declaration
 	<|> liftM Application (expression <* item TSemicolon)
 	<|> return
 	<|> if`
-	//<|> while
+	<|> while
 	<|> machinecode
 where
 	declaration :: Parser Token Statement
@@ -168,6 +169,12 @@ where
 			braced codeblock >>= \block ->
 			pure (cond, block)
 
+	while :: Parser Token Statement
+	while = item TWhile *>
+		parenthised expression >>= \cond ->
+		braced codeblock >>= \do ->
+		pure $ While cond do
+
 expression :: Parser Token Expression
 expression
 	= rightAssoc (op TDoubleBar       LogOr)
@@ -198,9 +205,14 @@ where
 	noInfix :: Parser Token Expression
 	noInfix
 		=   liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
-		<|> liftM (BuiltinApp Neg) (item TTilde *> noInfix)
+		<|> op TTilde       Neg
+		<|> op TExclamation Not
 		<|> liftM Literal literal
 		<|> liftM Name name
+		<|> parenthised expression
+	where
+		op :: Token Op1 -> Parser Token Expression
+		op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
 
 name :: Parser Token Name
 name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 58515fe..aebe32c 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,6 +47,7 @@ from Data.Maybe import :: Maybe
 
 :: Op1
 	= Neg //* ~
+	| Not //* !
 
 :: Op2
 	= Add    //* +
-- 
cgit v1.2.3