4 files changed, 75 insertions, 17 deletions
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
index 655219d..e8053e3 100644
--- a/snug-clean/src/MIPS/MIPS32.icl
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -153,13 +153,13 @@ checkOffset offset
 		= abort ("offset " +++ toString offset +++ " out of bounds\n")
 
 checkImmediate :: !Signedness !Immediate -> Immediate
-checkImmediate Signed (Immediate imm)
+checkImmediate Signed i=:(Immediate imm)
 	| 0 <= imm && imm <= 0x7fff
-		= Immediate imm
+		= i
 	| imm >= -0x8000
-		= Immediate (imm bitand 0xffff)
+		= i
 		= abort ("signed immediate " +++ toString imm +++ " out of bounds\n")
-checkImmediate Unsigned (Immediate imm)
+checkImmediate Unsigned i=:(Immediate imm)
 	| 0 <= imm && imm <= 0xffff
-		= Immediate imm
+		= i
 		= abort ("unsigned immediate " +++ toString imm +++ " out of bounds\n")
diff --git a/snug-clean/src/Snug/Parse.icl b/snug-clean/src/Snug/Parse.icl
index 9d58f23..4347c34 100644
--- a/snug-clean/src/Snug/Parse.icl
+++ b/snug-clean/src/Snug/Parse.icl
@@ -43,6 +43,11 @@ where
 			(simpleList (parenthesized typedArgument))
 			(pToken TColon *> type)
 			(pToken TColon *> expression)
+		<<|> liftM4 TestDef
+			(pToken (TIdent "test") *> string)
+			(pToken TColon *> type)
+			(pToken TColon *> simpleOrParenthesizedExpression)
+			string
 
 	simpleConstructorDef = liftM2 ConstructorDef constructorIdent (pure [])
 	constructorDef = liftM2 ConstructorDef constructorIdent (many simpleOrParenthesizedType)
@@ -101,6 +106,9 @@ basicValue
 	= (\(TInt i) -> BVInt i) <$> pSatisfy (\t -> t=:(TInt _))
 	<<|> (\(TChar c) -> BVChar c) <$> pSatisfy (\t -> t=:(TChar _))
 
+string :: Parser Token String
+string = (\(TString s) -> s) <$> pSatisfy (\t -> t=:(TString _))
+
 typeIdent :: Parser Token TypeIdent
 typeIdent = fromIdent <$> pSatisfy isUpperCaseIdent
 
@@ -152,6 +160,7 @@ nonEmpty p = p >>= \xs -> if (isEmpty xs) pFail (pure xs)
 	| TIdent !String
 	| TInt !Int
 	| TChar !Char
+	| TString !String
 
 	| TComment !String //* (# ... #)
 	| TError !Int !Int !String
@@ -169,6 +178,8 @@ where
 	(==) (TInt _) _ = False
 	(==) (TChar x) (TChar y) = x == y
 	(==) (TChar _) _ = False
+	(==) (TString x) (TString y) = x == y
+	(==) (TString _) _ = False
 	(==) (TComment x) (TComment y) = x == y
 	(==) (TComment _) _ = False
 	(==) (TError _ _ _) _ = False
@@ -238,15 +249,6 @@ lex` line col [c:cs]
 	| isSpace c
 		= lex` line (col+1) cs
 
-/* Identifiers*/
-lex` line col cs=:[c:_]
-	| isAlpha c
-		# (name,cs) = span isIdentChar cs
-		= [TIdent (toString name) : lex` line (col + length name) cs]
-	| isFunnySymbol c
-		# (name,cs) = span isFunnySymbol cs
-		= [TIdent (toString name) : lex` line (col + length name) cs]
-
 /* Basic values */
 lex` line col cs=:[c:_]
 	| isDigit c
@@ -258,6 +260,21 @@ lex` line col [c:cs]
 		= [TInt (0 - toInt (toString i)) : lex` line (col + 1 + length i) cs]
 lex` line col ['\'',c,'\'':cs] // TODO: escape sequences
 	= [TChar c : lex` line (col+3) cs]
+lex` line col ['"':cs] // TODO: escape sequences; correctly compute new line/col in case of newlines
+	= [TString s : lex` line (col + 2 + size s) (tl rest)]
+where
+	(chars,rest) = span ((<>) '"') cs
+	s = {c \\ c <- chars}
+
+/* Identifiers (must come after basic values for correct lexing of negative
+ * integers) */
+lex` line col cs=:[c:_]
+	| isAlpha c
+		# (name,cs) = span isIdentChar cs
+		= [TIdent (toString name) : lex` line (col + length name) cs]
+	| isFunnySymbol c
+		# (name,cs) = span isFunnySymbol cs
+		= [TIdent (toString name) : lex` line (col + length name) cs]
 
 /* Unparseable input */
 lex` line col cs
diff --git a/snug-clean/src/Snug/Syntax.dcl b/snug-clean/src/Snug/Syntax.dcl
index d030df6..865d5f7 100644
--- a/snug-clean/src/Snug/Syntax.dcl
+++ b/snug-clean/src/Snug/Syntax.dcl
@@ -37,3 +37,4 @@ definition module Snug.Syntax
 	= DataDef !TypeIdent ![TypeVarIdent] ![ConstructorDef]
 	| TypeDef !TypeIdent !Type
 	| FunDef !SymbolIdent ![(SymbolIdent, Type)] !Type !Expression
+	| TestDef !String !Type !Expression !String
diff --git a/snug-clean/src/snug.icl b/snug-clean/src/snug.icl
index 45b39a1..e1b5e8a 100644
--- a/snug-clean/src/snug.icl
+++ b/snug-clean/src/snug.icl
@@ -4,15 +4,18 @@ import StdEnv
 import StdMaybe
 
 import Data.Error
+import Data.Func
 import Data.List
 import System.CommandLine
 import System.File
 import System.FilePath
+import System.Process
 import Text
 
 import MIPS.MIPS32
 import Snug.Compile
 import Snug.Parse
+import Snug.Syntax
 
 /* Note: after compiling with
  *   snug program.snug
@@ -31,11 +34,48 @@ Start w
 	# mbDefs = parseSnug input
 	  defs = fromOk mbDefs
 	| isError mbDefs = abort ("Failed to parse: " +++ fromError mbDefs +++ "\n")
+	| any (\d -> d=:TestDef _ _ _ _) defs
+		= doTests output defs w
+		= doCompile output defs w
+
+doTests :: !String ![Definition] !*World -> *World
+doTests output all_defs w = seqSt doTest tests w
+where
+	(tests,defs) = partition (\d -> d=:TestDef _ _ _ _) all_defs
+
+	doTest :: !Definition !*World -> *World
+	doTest (TestDef name type expr expected) w
+		# w = log 0 (concat3 "\033[36mTesting " name "...\033[0m\n") w
+		# w = doCompile output [FunDef "main" [] type expr : defs] w
+		# (mbResult,w) = callProcessAndCollectOutput "spim" ["-quiet","-delayed_branches",output] ?None w
+		  (exitCode,output,error) = fromOk mbResult
+		| isError mbResult = abort ("Failed to run spim: " +++ snd (fromError mbResult) +++ "\n")
+		# w = log 1 output w
+		# w = if (error <> "") (logErr 1 error w) w
+		| exitCode <> 0 || error <> "" || trim output <> expected
+			# w = log 0 (concat3 "\033[31mFailed; expected:\033[0m\n\t" expected "\n") w
+			= setReturnCode 1 w
+		= w
+	where
+		log indent s w
+			# (io,w) = stdio w
+			# io = io <<< {#c \\ c <- repeatn indent '\t'} <<< s
+			# (_,w) = fclose io w
+			= w
+		logErr indent s w
+			# err = stderr <<< {#c \\ c <- repeatn indent '\t'} <<< s
+			# (_,w) = fclose err w
+			= w
+
+doCompile :: !String ![Definition] !*World -> *World
+doCompile output defs w
 	# mbAssembly = compile "main" defs
-	  assembly = fromOk mbAssembly
+	  assembly = join "\n" (map toString (fromOk mbAssembly))
 	| isError mbAssembly = abort ("Failed to compile: " +++ fromError mbAssembly +++ "\n")
-	# assembly = join "\n" (map toString assembly)
-	# (mbErr,w) = writeFile output assembly w
+	# (mbDriver,w) = readFile "driver.s" w
+	  driver = fromJust mbDriver
+	| isNone mbDriver = abort "Failed to read driver code\n"
+	# (mbErr,w) = writeFile output ({c \\ c <- driver} +++ assembly) w
 	| isError mbErr = abort ("Failed to write output: " +++ toString (fromError mbErr) +++ "\n")
 	| otherwise = w