Pass errors using MonadFail, avoid aborts

3 files changed, 20 insertions, 11 deletions

diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 15e2aa8..645c9ed 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -3,6 +3,7 @@ implementation module Snug.Compile
 import StdEnv
 
 import Control.Monad
+import Data.Error
 import Data.Func
 import Data.List
 import qualified Data.Map
@@ -113,9 +114,12 @@ where
 	label = constructorLabel ns id
 
 compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
-compileExpr ns globals locals expr = simulate [SVRegOffset FrontEvalPtr 0] $
-	simulator ns globals locals expr >>|
-	indirectAndEval
+compileExpr ns globals locals expr =
+	case simulate [SVRegOffset FrontEvalPtr 0] expr` of
+		Error e -> abort ("Compiling an expression failed: " +++ e +++ "\n")
+		Ok instrs -> instrs
+where
+	expr` = simulator ns globals locals expr >>| indirectAndEval
 
 simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
 simulator _ _ _ (BasicValue bv) =
diff --git a/snug-clean/src/Snug/Compile/Simulate.dcl b/snug-clean/src/Snug/Compile/Simulate.dcl
index bf01675..b131f34 100644
--- a/snug-clean/src/Snug/Compile/Simulate.dcl
+++ b/snug-clean/src/Snug/Compile/Simulate.dcl
@@ -7,13 +7,14 @@ from Control.Monad.Identity import :: Identity, instance Functor Identity,
 from Control.Monad.State import :: State, :: StateT,
 	instance Functor (StateT s m), instance Monad (StateT s m),
 	instance pure (StateT s m), instance <*> (StateT s m)
+from Data.Error import :: MaybeError
 from Data.Functor import class Functor
 
 from MIPS.MIPS32 import :: Immediate, :: Instruction, :: Label, :: Offset,
 	:: Register
 from Snug.Syntax import :: BasicValue
 
-:: Simulator a :== State SimulationState a
+:: Simulator a :== StateT SimulationState (MaybeError String) a
 
 :: SimulationState
 
@@ -24,7 +25,7 @@ from Snug.Syntax import :: BasicValue
 	/* for internal use only: */
 	| SVImmediate !Immediate
 
-simulate :: ![StackValue] !(Simulator a) -> [Instruction]
+simulate :: ![StackValue] !(Simulator a) -> MaybeError String [Instruction]
 
 stackSize :: Simulator Int
 
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
index 672b47e..af72277 100644
--- a/snug-clean/src/Snug/Compile/Simulate.icl
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -3,8 +3,10 @@ implementation module Snug.Compile.Simulate
 import StdEnv
 
 import Control.Monad
+import Control.Monad.Fail
 import Control.Monad.Identity
 import Control.Monad.State
+import Data.Error
 import Data.Functor
 
 import MIPS.MIPS32
@@ -17,11 +19,13 @@ import Snug.Syntax
 	, stack     :: ![StackValue]
 	}
 
-simulate :: ![StackValue] !(Simulator a) -> [Instruction]
-simulate stack sim = flatten (reverse (execState sim initial).instrs)
+simulate :: ![StackValue] !(Simulator a) -> MaybeError String [Instruction]
+simulate stack sim =
+	execStateT sim initial >>= \state ->
+	if (length state.stack == length stack)
+		(pure (flatten (reverse state.instrs)))
+		(fail "stack size changed")
 where
-	// TODO: when finishing:
-	// - check that the stack is empty
 	initial =
 		{ instrs = []
 		, hp_offset = 0
@@ -113,7 +117,7 @@ pushArg i j =
 		SVRegOffset reg offset ->
 			push (SVIndirect (offset + (j+1)*4) reg)
 		_ ->
-			abort "unexpected reference in pushArg\n"
+			fail "unexpected reference in pushArg\n"
 
 indirectAndEval :: Simulator ()
 indirectAndEval =
@@ -136,4 +140,4 @@ indirectAndEval =
 				[ AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
 				]
 		_ ->
-			abort "unexpected top of stack in indirect\n"
+			fail "unexpected top of stack in indirect\n"