Minor improvements; implement saturated function and constructor applications

7 files changed, 114 insertions, 22 deletions

diff --git a/driver.s b/driver.s
index 44520b2..d717270 100644
--- a/driver.s
+++ b/driver.s
@@ -1,11 +1,21 @@
 	.data
 
+	.align 2
+heap:
+	.space	0x80000	# 512KiB
+
 	.align 1
 _cINT:
 	.byte	0	# pointer arity
 	.byte	1	# basic value arity
 	.byte	0	# number of arguments that still have to be curried in
 
+	.align 1
+_cCHAR:
+	.byte	0	# pointer arity
+	.byte	1	# basic value arity
+	.byte	0	# number of arguments that still have to be curried in
+
 	.align 2
 PRINTROOT:
 	.word	_nroot
@@ -14,9 +24,6 @@ EVALROOT:
 	.word	_nroot
 	.word	0	# to be filled in
 
-	.align 2
-heap:
-
 	.text
 main:
 	la	$gp,heap
@@ -56,6 +63,8 @@ print_hnf:
 	lw	$t0,($s1)
 	la	$t1,_cINT
 	beq	$t0,$t1,print_int
+	la	$t1,_cCHAR
+	beq	$t0,$t1,print_char
 	li	$a0,'('
 	li	$v0,11	# print_char
 	syscall
@@ -76,6 +85,19 @@ print_int:
 	b	print_rewind
 	nop
 
+print_char:
+	li	$a0,39	# '
+	li	$v0,11	# print_char
+	syscall
+	lw	$a0,4($s1)
+	li	$v0,11	# print_char
+	syscall
+	li	$a0,39	# '
+	li	$v0,11	# print_char
+	syscall
+	b	print_rewind
+	nop
+
 print_rewind:
 	la	$t5,PRINTROOT
 	beq	$s0,$t5,print_rewind_root
diff --git a/example.txt b/example.txt
index 38041f0..26fc2d8 100644
--- a/example.txt
+++ b/example.txt
@@ -5,13 +5,6 @@
 	(Cons a (List a))))
 (type String (List Char))
 
-(fun length ((xs : List a)) : Int
-	(length_acc 0 xs))
-(fun length_acc ((n : Int) (xs : List a)) : Int
-	(case xs (
-		(Nil -> n)
-		(Cons _ xs -> length_acc (+ n 1) xs))))
-
 (data TypeIdent ((TI String)))
 (data TypeVarIdent ((TVI String)))
 (data ConstructorIdent ((CI String)))
@@ -39,7 +32,8 @@
 	(CaseAlternative Pattern Expression)))
 
 (data Expression (
-	(Ident SymbolIdent)
+	(BasicValue BasicValue)
+	(Symbol SymbolIdent)
 	(Case Expression (List CaseAlternative))
 	(ExpApp Expression Expression)))
 
@@ -60,12 +54,26 @@
 		(Cons (Tuple (Cons 'n' Nil) (Type (Cons 'I' (Cons 'n' (Cons 't' Nil)))))
 			(Cons (Tuple (Cons 'x' (Cons 's' Nil)) (TypeApp (Type (Cons 'L' (Cons 'i' (Cons 's' (Cons 't' Nil))))) (TypeVar (Cons 'a' Nil))))
 			Nil))
-		(Case (Ident (Cons 'x' (Cons 's' Nil)))
-			(Cons (CaseAlternative (ConstructorPattern (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil) (Ident (Cons 'n' Nil)))
-				(Cons (CaseAlternative (ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons Wildcard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil))))
-				Nil)))))
+		(Type (Cons 'I' (Cons 'n' (Cons 't' Nil))))
+		(Case (Symbol (Cons 'x' (Cons 's' Nil)))
+			(Cons (CaseAlternative
+				(ConstructorPattern (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil)
+				(Symbol (Cons 'n' Nil)))
+			(Cons (CaseAlternative
+				(ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons Wildcard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil)))
+				(ExpApp (ExpApp (Symbol (Cons 'l' (Cons 'e' (Cons 'n' (Cons 'g' (Cons 't' (Cons 'h' (Cons '_' (Cons 'a' (Cons 'c' (Cons 'c' Nil))))))))))) (ExpApp (ExpApp (Cons '+' Nil) (Cons 'n' Nil)) (BasicValue (BVInt 1)))) (Cons 'x' (Cons 's' Nil))))
+			Nil)))))
+
+(#
+(fun length ((xs : List a)) : Int
+	(length_acc 0 xs))
+(fun length_acc ((n : Int) (xs : List a)) : Int
+	(case xs (
+		(Nil -> n)
+		(Cons _ xs -> length_acc (+ n 1) xs))))
+#)
 
-(fun testb () : Int
-	37)
+(fun testb ((x : Int) (y : Int)) : Int
+	(Tuple 37 'a'))
 (fun test () : Int
-	(testb))
+	(testb 37 42))
diff --git a/snug-clean/src/MIPS/MIPS32.dcl b/snug-clean/src/MIPS/MIPS32.dcl
index a2c85dc..6e5ff44 100644
--- a/snug-clean/src/MIPS/MIPS32.dcl
+++ b/snug-clean/src/MIPS/MIPS32.dcl
@@ -6,6 +6,7 @@ from StdOverloaded import class toString
 	= StartSection !String
 	| Align !Int
 	| Label !Label
+	| Global !Label
 	| Instr !Instruction
 	| RawByte !Int
 	| RawWord !Int
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
index 6e602be..ca5cbee 100644
--- a/snug-clean/src/MIPS/MIPS32.icl
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -9,6 +9,7 @@ where
 	toString (StartSection s) = "\t." +++ s
 	toString (Align i) = "\t.align\t" +++ toString i
 	toString (Label l) = l +++ ":"
+	toString (Global l) = "\t.globl\t" +++ l
 	toString (Instr i) = "\t" +++ toString i
 	toString (RawByte i) = "\t.byte\t" +++ toString i
 	toString (RawWord i) = "\t.word\t" +++ toString i
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