ABC machine instructions

1 files changed, 36 insertions, 26 deletions

diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 5c13c48..925423c 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -2,7 +2,7 @@ implementation module Sil.Parse
 
 import StdBool
 import StdChar
-from StdFunc import o
+from StdFunc import flip, o
 import StdInt
 import StdList
 import StdString
@@ -13,8 +13,10 @@ import Control.Monad
 import Data.Error
 from Data.Func import $
 import Data.Functor
+import Data.List
 import Data.Maybe
-from Text import <+
+import qualified Text as T
+from Text import <+, class Text, instance Text String
 
 import GenEq
 
@@ -27,24 +29,26 @@ instance == Token where == a b = gEq{|*|} a b
 
 instance toString Token
 where
-	toString TParenOpen  = "("
-	toString TParenClose = ")"
-	toString TBraceOpen  = "{"
-	toString TBraceClose = "}"
-	toString TComma      = ","
-	toString TSemicolon  = ";"
-	toString TAssign     = ":="
-	toString (TLit l)    = toString l
-	toString TIf         = "if"
-	toString TWhile      = "while"
-	toString TReturn     = "return"
-	toString (TName s)   = s
+	toString TParenOpen       = "("
+	toString TParenClose      = ")"
+	toString TBraceOpen       = "{"
+	toString TBraceClose      = "}"
+	toString TComma           = ","
+	toString TSemicolon       = ";"
+	toString TAssign          = ":="
+	toString (TLit l)         = toString l
+	toString TIf              = "if"
+	toString TWhile           = "while"
+	toString TReturn          = "return"
+	toString (TMachineCode s) = "|~ " +++ s
+	toString (TName s)        = s
 
 instance name Token
 where
-	name (TLit _)  = "literal"
-	name (TName _) = "name"
-	name t         = toString t
+	name (TLit _)         = "literal"
+	name (TName _)        = "name"
+	name (TMachineCode _) = "machine code"
+	name t                = toString t
 
 instance toString ParseError
 where
@@ -67,8 +71,10 @@ where
 	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]
 	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]
+	tks ['T':'r':'u':'e'        :s:r] t | isSpace s = tks r [TLit $ BLit True :t]
 	tks ['F':'a':'l':'s':'e'    :s:r] t | isSpace s = tks r [TLit $ BLit False:t]
+	tks ['|':'~':r] t = tks r` [TMachineCode $ toString c:t]
+	where (c,r`) = span (not o flip isMember ['\r\n']) r
 	tks cs=:[h:_] t
 	| isSpace h          = tks (dropWhile isSpace cs) t
 	| isDigit h          = tks numrest [TLit $ ILit $ toInt $ toString num:t]
@@ -78,8 +84,8 @@ where
 		(name,namerest) = span isNameChar cs
 		(num,numrest)   = span isDigit cs
 
-	isNameChar :: (Char -> Bool)
-	isNameChar = isAlpha
+	isNameChar :: Char -> Bool
+	isNameChar c = isAlpha c || isMember c ['_\'']
 
 parse :: ([Token] -> MaybeError ParseError Program)
 parse = fst o runParser program
@@ -91,12 +97,12 @@ function :: Parser Token Function
 function =
 	type >>= \t ->
 	name >>= \n ->
-	item TParenOpen >>= \_ ->
+	item TParenOpen *>
 	seplist TComma arg >>= \args ->
-	item TParenClose >>= \_ ->
-	item TBraceOpen >>= \_ ->
+	item TParenClose *>
+	item TBraceOpen *>
 	codeblock >>= \cb ->
-	item TBraceClose >>= \_ -> pure
+	item TBraceClose *> pure
 		{ f_type = t
 		, f_name = n
 		, f_args = args
@@ -116,11 +122,11 @@ initialisation =
 	pure [{init_type=t, init_name=n} \\ n <- ns]
 
 statement :: Parser Token Statement
-statement = (declaration
+statement = ((declaration
 	<|> liftM Application application
 	<|> return
 /*	<|> if`
-	<|> while*/) <* item TSemicolon
+	<|> while*/) <* item TSemicolon) <|> machinecode
 where
 	declaration :: Parser Token Statement
 	declaration = liftM2 Declaration name (item TAssign *> application)
@@ -134,6 +140,10 @@ where
 	return :: Parser Token Statement
 	return = liftM Return (item TReturn *> optional application)
 
+	machinecode :: Parser Token Statement
+	machinecode = (\(TMachineCode s) -> MachineStm s) <$> satisfy isMachineCode
+	where isMachineCode (TMachineCode _) = True; isMachineCode _ = False
+
 name :: Parser Token Name
 name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
 where