Continue with cases WIP: todo is matching code for basic values and adding locals for constructor arguments in a patterncases

3 files changed, 44 insertions, 22 deletions

diff --git a/snug-clean/src/Snug/Compile/ABI.dcl b/snug-clean/src/Snug/Compile/ABI.dcl
index c7fe7ad..7d3a63a 100644
--- a/snug-clean/src/Snug/Compile/ABI.dcl
+++ b/snug-clean/src/Snug/Compile/ABI.dcl
@@ -1,5 +1,11 @@
 definition module Snug.Compile.ABI
 
+from StdBool import not, &&
+from StdClass import class Ord(<=)
+from StdInt import instance < Int
+from StdMisc import abort
+from StdOverloaded import class <(<)
+
 from MIPS.MIPS32 import :: Label, :: Register(GP,S,T)
 from Snug.Compile import :: Namespace
 from Snug.Syntax import :: ConstructorIdent, :: SymbolIdent
@@ -17,7 +23,7 @@ TextEndDataStart :== S 7
 
 HeapPtr :== GP
 
-TempImm :== T 0
+TempImm i :== if (0 <= i && i <= 1) (T i) (abort "TempImm out of range\n")
 
 constructorLabel :: !Namespace !ConstructorIdent -> Label
 functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
index 57f249c..ab13cde 100644
--- a/snug-clean/src/Snug/Compile/Simulate.icl
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -59,32 +59,32 @@ storeStackValue (SVImmediate (Immediate i)) doffset dreg
 		[ StoreWord R0 doffset dreg
 		]
 	| 0 <= i && i < 0x10000 = add
-		[ OrImmediate TempImm R0 (Immediate i)
-		, StoreWord TempImm doffset dreg
+		[ OrImmediate (TempImm 0) R0 (Immediate i)
+		, StoreWord (TempImm 0) doffset dreg
 		]
 	| 0 > i && i >= -0x8000 = add
-		[ AddImmediate Signed TempImm R0 (Immediate i)
-		, StoreWord TempImm doffset dreg
+		[ AddImmediate Signed (TempImm 0) R0 (Immediate i)
+		, StoreWord (TempImm 0) doffset dreg
 		]
 	| otherwise = add
-		[ LoadUpperImmediate TempImm (Immediate (i >> 16))
-		, OrImmediate TempImm TempImm (Immediate (i bitand 0xffff))
-		, StoreWord TempImm doffset dreg
+		[ LoadUpperImmediate (TempImm 0) (Immediate (i >> 16))
+		, OrImmediate (TempImm 0) (TempImm 0) (Immediate (i bitand 0xffff))
+		, StoreWord (TempImm 0) doffset dreg
 		]
 storeStackValue (SVImmediate imm=:(Address _ _)) doffset dreg = add
-	[ LoadAddress TempImm imm
-	, StoreWord TempImm doffset dreg
+	[ LoadAddress (TempImm 0) imm
+	, StoreWord (TempImm 0) doffset dreg
 	]
 storeStackValue (SVRegOffset reg 0) doffset dreg = add
 	[ StoreWord reg doffset dreg
 	]
 storeStackValue (SVRegOffset reg offset) doffset dreg = add
-	[ AddImmediate Signed TempImm reg (Immediate offset)
-	, StoreWord TempImm doffset dreg
+	[ AddImmediate Signed (TempImm 0) reg (Immediate offset)
+	, StoreWord (TempImm 0) doffset dreg
 	]
 storeStackValue (SVIndirect offset reg) doffset dreg = add
-	[ LoadWord TempImm offset reg
-	, StoreWord TempImm doffset dreg
+	[ LoadWord (TempImm 0) offset reg
+	, StoreWord (TempImm 0) doffset dreg
 	]
 
 buildCons :: !Label !Int -> Simulator ()
@@ -126,8 +126,8 @@ indirectAndEval =
 		SVRegOffset HeapPtr offset ->
 			add
 				// Build indirection
-				[ LoadAddress TempImm (Address 0 (functionLabel "" NodeEntry "indir"))
-				, StoreWord TempImm 0 FrontEvalPtr
+				[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
+				, StoreWord (TempImm 0) 0 FrontEvalPtr
 				] >>|
 			storeStackValue sv 4 FrontEvalPtr >>|
 			getState >>= \{hp_offset} ->
@@ -141,8 +141,8 @@ indirectAndEval =
 			// We only need to overwrite the descriptor with an indirection
 			getState >>= \{hp_offset} ->
 			add
-				[ LoadAddress TempImm (Address 0 (functionLabel "" NodeEntry "indir"))
-				, StoreWord TempImm 0 FrontEvalPtr
+				[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
+				, StoreWord (TempImm 0) 0 FrontEvalPtr
 				, Jump NoLink (Direct (Address 0 "eval"))
 				, AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
 				]
diff --git a/snug-clean/src/Snug/Compile/Typing.icl b/snug-clean/src/Snug/Compile/Typing.icl
index 5587da7..4d69aca 100644
--- a/snug-clean/src/Snug/Compile/Typing.icl
+++ b/snug-clean/src/Snug/Compile/Typing.icl
@@ -7,8 +7,24 @@ import Snug.Syntax
 instance type Expression
 where
 	type locals e = case e of
-		BasicValue bv -> type locals bv
+		BasicValue bv ->
+			type locals bv
 		Symbol sym -> // TODO
-		Constructor cons -> // TODO
-		Case _ alts -> checkSameTypes "case alternatives" [type locals e \\ CaseAlternative _ e <- alts]
-		ExpApp e1 e2 -> // TODO
+		Constructor cons ->
+			lookupConstructorM ns cons >>= \(ConstructorDef _ args ret) ->
+			foldr TyFun ret args
+		Case _ alts ->
+			checkSameTypes "case alternatives" [type locals e \\ CaseAlternative _ e <- alts]
+		ExpApp e1 e2 ->
+			type locals e1 >>= \t1 -> case t1 of
+				TyFun t1arg t1ret ->
+					type locals e2 >>= \t2 ->
+					unify t1arg t2 ->
+					resolve t1ret
+				TyVar _ ->
+					freshTyVar >>= \t1arg ->
+					freshTyVar >>= \t1ret ->
+					unify t1arg t2 ->
+					resolve t1ret
+				_ ->
+					fail "ExpApp: first argument cannot be unified with a function type"