3 files changed, 64 insertions, 4 deletions
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 43f8a37..50119f3 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -65,6 +65,9 @@ gatherGlobals ns defs =
 		]
 	}
 
+lookupConstructor :: !Namespace !ConstructorIdent !Globals -> ?ConstructorDef
+lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors
+
 lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
 lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions
 
@@ -77,6 +80,7 @@ compileDefinition ns globals (DataDef _ _ constructors) =
 	]
 compileDefinition ns globals (FunDef id args ret expr) =
 	[ StartSection "text"
+	, Global label
 	// TODO: Ideally we would use the following here:
 	//, Align 1
 	//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
@@ -87,10 +91,11 @@ compileDefinition ns globals (FunDef id args ret expr) =
 		(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
 		(length args << 8)) // arity
 	// instead... (end modification)
-	, Label (functionLabel ns NodeEntry id)
+	, Label label
 	: map Instr (compileExpr ns globals locals expr)
 	]
 where
+	label = functionLabel ns NodeEntry id
 	locals = 'Data.Map'.fromList
 		[ (id, Indirect FrontEvalPtr (offset*4))
 		\\ (id,_) <- args
@@ -99,12 +104,15 @@ where
 
 compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
 compileConstructor ns _ (ConstructorDef id args) =
-	[ Align 1
-	, Label (constructorLabel ns id)
+	[ Global label
+	, Align 1
+	, Label label
 	, RawByte (length args) // pointer arity
 	, RawByte 0 // basic value arity
 	, RawByte 0 // number of arguments still to be curried in
 	]
+where
+	label = constructorLabel ns id
 
 compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
 compileExpr ns globals locals expr = simulate $
@@ -127,6 +135,29 @@ simulator ns globals locals (Symbol id) = // TODO include locals
 					buildThunk (functionLabel ns NodeEntry id) 0
 				_ ->
 					abort "symbol with arity > 0\n" // TODO implement
+simulator ns globals locals expr=:(ExpApp _ _) =
+	case f of
+		Symbol id -> // TODO include locals
+			case lookupFunction ns id globals of
+				?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
+				?Just info | info.arity == length args ->
+					mapM_ (simulator ns globals locals) args >>|
+					buildThunk (functionLabel ns NodeEntry id) info.arity
+				_ -> abort ("arity mismatch in application\n") // TODO implement
+		Constructor id ->
+			case lookupConstructor ns id globals of
+				?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up
+				?Just (ConstructorDef _ arg_types) | length arg_types == length args ->
+					mapM_ (simulator ns globals locals) args >>|
+					buildCons (constructorLabel ns id) (length args)
+				_ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement
+		_ -> // TODO
+			abort "unexpected lhs of function application\n"
+where
+	(f, args) = linearizeApp expr []
+
+	linearizeApp (ExpApp f x) xs = linearizeApp f [x:xs]
+	linearizeApp e xs = (e, xs)
 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 9b938d5..a36dc0d 100644
--- a/snug-clean/src/Snug/Compile/Simulate.dcl
+++ b/snug-clean/src/Snug/Compile/Simulate.dcl
@@ -18,9 +18,16 @@ from Snug.Syntax import :: BasicValue
 
 simulate :: !(Simulator a) -> [Instruction]
 
+//* Build a constructor node with *n* arguments and push it to the stack.
 buildCons :: !Label !Int -> Simulator ()
+//* Build a thunk node with *n* arguments and push it to the stack.
 buildThunk :: !Label !Int -> Simulator ()
 
+//* Push a basic value to the stack.
 pushBasicValue :: !BasicValue -> Simulator ()
 
+/**
+ * Overwrite the node currently under evaluation with an indirection to the
+ * node on top of the stack, and continue evaluating that node instead.
+ */
 indirectAndEval :: Simulator ()
diff --git a/snug-clean/src/Snug/Parse.icl b/snug-clean/src/Snug/Parse.icl
index 63a9fda..75d9295 100644
--- a/snug-clean/src/Snug/Parse.icl
+++ b/snug-clean/src/Snug/Parse.icl
@@ -16,9 +16,11 @@ import Text.Parsers.Simple.Core
 import Snug.Syntax
 
 parseSnug :: ![Char] -> MaybeError String [Definition]
-parseSnug cs = case parse (many definition`) (lex cs) of
+parseSnug cs = case parse (many definition`) (filterComments (lex cs)) of
 	Left errors -> Error ('Text'.join "; " errors)
 	Right defs -> Ok defs
+where
+	filterComments tks = [t \\ t <- tks | not (t=:(TComment _))]
 
 definition` :: Parser Token Definition
 definition` = parenthesized def
@@ -146,6 +148,7 @@ nonEmpty p = p >>= \xs -> if (isEmpty xs) pFail (pure xs)
 	| TInt !Int
 	| TChar !Char
 
+	| TComment !String //* (# ... #)
 	| TError !Int !Int !String
 
 instance == Token
@@ -161,6 +164,8 @@ where
 	(==) (TInt _) _ = False
 	(==) (TChar x) (TChar y) = x == y
 	(==) (TChar _) _ = False
+	(==) (TComment x) (TComment y) = x == y
+	(==) (TComment _) _ = False
 	(==) (TError _ _ _) _ = False
 
 lex :: ![Char] -> [Token]
@@ -169,6 +174,23 @@ lex cs = lex` 0 0 cs
 lex` :: !Int !Int ![Char] -> [Token]
 lex` _ _ []
 	= []
+lex` line col ['(#':cs]
+	= stripComment line (col+2) cs 0 []
+where
+	stripComment line col ['#)':cs] 0 acc
+		= [TComment (toString (reverse acc)) : lex` line (col+2) cs]
+	stripComment line col ['(#':cs] n acc
+		= stripComment line (col+2) cs (n+1) ['#(':acc]
+	stripComment line col ['\r\n':cs] n acc
+		= stripComment (line+1) 0 cs n ['\n\r':acc]
+	stripComment line col ['\n\r':cs] n acc
+		= stripComment (line+1) 0 cs n ['\r\n':acc]
+	stripComment line col [c:cs] n acc
+		| c=='\n' || c=='\r'
+			= stripComment (line+1) 0 cs n [c:acc]
+			= stripComment line (col+1) cs n [c:acc]
+	stripComment line col [] _ _
+		= [TError line col "end of file while scanning comment"]
 /* This alternative is for characters that can never be part of identifiers: */
 lex` line col [c:cs]
 	| isJust mbToken