Add compilation for symbols with arity 0

3 files changed, 48 insertions, 1 deletions

diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index c354950..43f8a37 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -34,13 +34,40 @@ compile :: !Namespace ![Definition] -> [Line]
 compile ns defs =
 	concatMap (compileDefinition ns globals) defs
 where
-	globals =
+	globals = combineGlobals
+		[ builtin
+		, gatherGlobals ns defs
+		]
+
+	builtin =
 		{ constructors = 'Data.Map'.fromList
 			[ ({ns="", id="INT"}, ConstructorDef "INT" [])
 			]
 		, functions = 'Data.Map'.newMap
 		}
 
+combineGlobals :: ![Globals] -> Globals
+combineGlobals sets =
+	{ constructors = 'Data.Map'.unions [g.constructors \\ g <- sets]
+	, functions = 'Data.Map'.unions [g.functions \\ g <- sets]
+	}
+
+gatherGlobals :: !Namespace ![Definition] -> Globals
+gatherGlobals ns defs =
+	{ constructors = 'Data.Map'.fromList
+		[ ({ns=ns, id=id}, cons)
+		\\ DataDef _ _ conses <- defs
+		, cons=:(ConstructorDef id _) <- conses
+		]
+	, functions = 'Data.Map'.fromList
+		[ ({ns=ns, id=id}, {arity=length args, type=foldr TyApp ret (map snd (reverse args))})
+		\\ FunDef id args ret _ <- defs
+		]
+	}
+
+lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
+lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions
+
 compileDefinition :: !Namespace !Globals !Definition -> [Line]
 compileDefinition _ _ (TypeDef _ _) =
 	[]
@@ -91,6 +118,15 @@ simulator _ _ _ (BasicValue bv) =
 where
 	label (BVInt _) = "INT"
 	label (BVChar _) = "CHAR"
+simulator ns globals locals (Symbol id) = // TODO include locals
+	case lookupFunction ns id globals of
+		?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
+		?Just info ->
+			case info.arity of
+				0 ->
+					buildThunk (functionLabel ns NodeEntry id) 0
+				_ ->
+					abort "symbol with arity > 0\n" // TODO implement
 simulator _ _ _ _ = // TODO
 	pushBasicValue (BVInt 0) >>|
 	buildCons (constructorLabel "" "INT") 1
diff --git a/snug-clean/src/Snug/Compile/Simulate.dcl b/snug-clean/src/Snug/Compile/Simulate.dcl
index a61d631..9b938d5 100644
--- a/snug-clean/src/Snug/Compile/Simulate.dcl
+++ b/snug-clean/src/Snug/Compile/Simulate.dcl
@@ -19,6 +19,7 @@ from Snug.Syntax import :: BasicValue
 simulate :: !(Simulator a) -> [Instruction]
 
 buildCons :: !Label !Int -> Simulator ()
+buildThunk :: !Label !Int -> Simulator ()
 
 pushBasicValue :: !BasicValue -> Simulator ()
 
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
index 620ec3e..b383936 100644
--- a/snug-clean/src/Snug/Compile/Simulate.icl
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -87,6 +87,16 @@ buildCons cons nargs =
 	mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>|
 	push addr
 
+buildThunk :: !Label !Int -> Simulator ()
+buildThunk cons 0 =
+	write_heap (SVImmediate (Address 0 cons)) >>= \addr ->
+	modify (\s -> {s & hp_offset=s.hp_offset+4}) >>| // reserve space to overwrite with indir
+	push addr
+buildThunk cons nargs =
+	write_heap (SVImmediate (Address 0 cons)) >>= \addr ->
+	mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>|
+	push addr
+
 pushBasicValue :: !BasicValue -> Simulator ()
 pushBasicValue val = push (SVImmediate (Immediate imm))
 where