Resolve #1: implement lists (tuples have been done earlier)

9 files changed, 127 insertions, 18 deletions

diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index e342a66..de3f47f 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -42,13 +42,18 @@ where
 	censor` = opt o filter isUseful
 
 	opt :: 'ABC'.Assembler -> 'ABC'.Assembler
+	// Equality checks for integers
 	opt ['ABC'.PushI i:'ABC'.Push_b l:'ABC'.EqI:ss] = ['ABC'.EqI_b i (l-1):opt ss]
 	opt ['ABC'.Push_b l:'ABC'.PushI i:'ABC'.EqI:ss] = ['ABC'.EqI_b i l    :opt ss]
+	// Delay pushing if we need to pop
 	opt ['ABC'.PushI i:'ABC'.Update_b 0 l:'ABC'.Pop_b n:ss] | l == n = ['ABC'.Pop_b n:'ABC'.PushI i:opt ss]
+	// Combine pops
 	opt ['ABC'.Pop_a i:'ABC'.Pop_a j:ss] = opt ['ABC'.Pop_a (i+j):ss]
 	opt ['ABC'.Pop_b i:'ABC'.Pop_b j:ss] = opt ['ABC'.Pop_b (i+j):ss]
+	// Remove unreachable code
 	opt ['ABC'.Rtn:ss] = ['ABC'.Rtn:opt $ skipUntilEntryPoint ss]
 	opt ['ABC'.Jmp l:ss] = ['ABC'.Jmp l:opt $ skipUntilEntryPoint ss]
+	// Base cases
 	opt [s:ss] = [s:opt ss]
 	opt []     = []
 
@@ -61,7 +66,7 @@ where
 	isUseful _                    = True
 
 	skipUntilEntryPoint :: 'ABC'.Assembler -> 'ABC'.Assembler
-	skipUntilEntryPoint ss
+	skipUntilEntryPoint ss=:[_:_]
 	| all (\t -> t =: ('ABC'.Annotation _)) before = ss
 	| otherwise                                    = skipUntilEntryPoint $ tl ss
 	where
@@ -220,11 +225,31 @@ getType e = getTypeResolver >>= \tr -> case type tr e of
 	Just (Ok t)      -> pure $ t
 
 checkType :: Type Expression -> Gen ()
-checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e)
+checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e t`)
 
 checkTypeName :: Name Expression -> Gen Type
 checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
 
+tellAbort :: String -> Gen ()
+tellAbort s = tell
+	[ 'ABC'.Raw $ "\tbuildAC\t\"" <+ quote s <+ "\\r\\n\""
+	, 'ABC'.Annotation $ 'ABC'.DAnnot 1 []
+	, 'ABC'.Jsr "print_string_"
+	, 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
+	, 'ABC'.Halt
+	]
+where
+	quote :: (String -> String)
+	quote = toString o q o fromString
+	where
+		q :: [Char] -> [Char]
+		q [] = []
+		q ['\\':cs] = ['\\':'\\':q cs]
+		q ['\r':cs] = ['\\':'r' :q cs]
+		q ['\n':cs] = ['\\':'n' :q cs]
+		q ['\t':cs] = ['\\':'t' :q cs]
+		q [c:cs]    = [c        :q cs]
+
 class gen a :: a -> Gen ()
 
 instance gen Program
@@ -483,6 +508,11 @@ where
 		     , 'ABC'.PushB False ] *>
 		growStack {zero & bsize=1} *>
 		tell [ 'ABC'.Label end ]
+	gen (BuiltinApp2 e1 Cons e2) =
+		genToAStack e2 *>
+		genToAStack e1 *>
+		tell [ 'ABC'.Raw "\tbuildh\t_Cons\t2" ] *>
+		shrinkStack {zero & asize=1}
 	gen (BuiltinApp2 e1 op e2) =
 		mapM gen [e2,e1] *>
 		gen op
@@ -491,6 +521,10 @@ where
 		mapM genToAStack (reverse es) *>
 		tell [ 'ABC'.Raw $ "\tbuildh\t_Tuple\t" <+ i ] *>
 		shrinkStack {zero & asize=i-1}
+	gen (List _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
+	gen (List t [e:es]) =
+		getType e >>= \te ->
+		gen (BuiltinApp2 e Cons (List (t <|> pure te) es))
 	gen e=:(Field f e`)
 	| isTuple =
 		getType e` >>= \t=:(TTuple arity tes) ->
@@ -498,12 +532,39 @@ where
 		tell [ 'ABC'.ReplArgs arity arity
 		     , 'ABC'.Pop_a (tupleEl - 1)
 		     , 'ABC'.Update_a 0 (arity - tupleEl)
-		     , 'ABC'.Pop_a (arity - tupleEl)
-		     ] *>
+		     , 'ABC'.Pop_a (arity - tupleEl) ] *>
 		if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *>
 		case typeSize $ tes!!(tupleEl - 1) of
 			{bsize=0} -> nop
 			{btypes} -> mapM (flip toBStack 1) btypes *> nop
+	| f == "hd" =
+		fresh "iscons" >>= \iscons ->
+		gen e` *>
+		tell [ 'ABC'.EqDescArity "_Cons" 2 0
+		     , 'ABC'.JmpTrue iscons ] *>
+		tellAbort "hd of empty list" *>
+		tell [ 'ABC'.Label iscons
+		     , 'ABC'.ReplArgs 2 2
+			 , 'ABC'.Update_a 0 1
+			 , 'ABC'.Pop_a 1 ] *>
+		getType e >>= \te ->
+		case typeSize te of
+			{bsize=0} -> nop
+			{btypes} -> mapM (flip toBStack 1) btypes *> nop
+	| f == "tl" =
+		fresh "iscons" >>= \iscons ->
+		gen e` *>
+		tell [ 'ABC'.EqDescArity "_Cons" 2 0
+		     , 'ABC'.JmpTrue iscons ] *>
+		tellAbort "tl of empty list" *>
+		tell [ 'ABC'.Label iscons
+		     , 'ABC'.ReplArgs 2 2
+			 , 'ABC'.Pop_a 1 ]
+	| f == "nil" =
+		gen e` *>
+		tell [ 'ABC'.EqDescArity "_Nil" 0 0
+		     , 'ABC'.Pop_a 1 ] *>
+		growStack {asize=(-1), bsize=1, btypes=['ABC'.BT_Bool]}
 	| otherwise =
 		error $ C_UndefinedField f
 	where
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index 15a660a..7df1976 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -21,7 +21,7 @@ from Sil.Types import :: Type
 	| C_FunctionOnStack
 	| C_TypeError Error Expression
 	| C_CouldNotDeduceType Expression
-	| C_TypeMisMatch Type Expression
+	| C_TypeMisMatch Type Expression Type
 	| C_BasicInitWithoutValue String
 	// Miscellaneous
 	| UnknownError String
diff --git a/Sil/Error.icl b/Sil/Error.icl
index 6a9d07e..9c48ecc 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -21,7 +21,7 @@ where
 	toString C_FunctionOnStack            = "Function stored on the stack."
 	toString (C_TypeError err e)          = "Type error in '" <+ e <+ "': " <+ err
 	toString (C_CouldNotDeduceType e)     = "Could not deduce type of '" <+ e <+ "'."
-	toString (C_TypeMisMatch t e)         = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'."
+	toString (C_TypeMisMatch t e t`)      = "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ t` <+ "."
 	toString (C_BasicInitWithoutValue n)  = "Basic value '" <+ n <+ "' must have an initial value."
 	toString (UnknownError e)             = "Unknown error: " <+ e <+ "."
 
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 441bf9e..378586a 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -11,9 +11,12 @@ from Sil.Util.Parser import class name
 :: Token
 	= TParenOpen          //* (
 	| TParenClose         //* )
+	| TBrackOpen          //* [
+	| TBrackClose         //* ]
 	| TBraceOpen          //* {
 	| TBraceClose         //* }
 	| TComma              //* ,
+	| TColon              //* :
 	| TSemicolon          //* ;
 	| TField String       //* . and field name
 	| TAssign             //* :=
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index c9521bf..cdd117f 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -33,9 +33,12 @@ instance toString Token
 where
 	toString TParenOpen       = "("
 	toString TParenClose      = ")"
+	toString TBrackOpen       = "["
+	toString TBrackClose      = "]"
 	toString TBraceOpen       = "{"
 	toString TBraceClose      = "}"
 	toString TComma           = ","
+	toString TColon           = ":"
 	toString TSemicolon       = ";"
 	toString (TField f)       = "." +++ f
 	toString TAssign          = ":="
@@ -78,9 +81,12 @@ where
 	tks ['&':'&':r] t = tks r [TDoubleAmpersand:t]
 	tks ['(':r] t = tks r [TParenOpen  :t]
 	tks [')':r] t = tks r [TParenClose :t]
+	tks ['[':r] t = tks r [TBrackOpen  :t]
+	tks [']':r] t = tks r [TBrackClose :t]
 	tks ['{':r] t = tks r [TBraceOpen  :t]
 	tks ['}':r] t = tks r [TBraceClose :t]
 	tks [',':r] t = tks r [TComma      :t]
+	tks [':':r] t = tks r [TColon      :t]
 	tks [';':r] t = tks r [TSemicolon  :t]
 	tks ['!':r] t = tks r [TExclamation:t]
 	tks ['~':r] t = tks r [TTilde      :t]
@@ -192,15 +198,12 @@ expression
 	= rightAssoc (op TDoubleBar       LogOr)
 	$ rightAssoc (op TDoubleAmpersand LogAnd)
 	$ rightAssoc (op TDoubleEquals    Equals)
-	$ leftAssoc
-		(         op TPlus            Add
-		<|>       op TMinus           Sub
-		)
-	$ leftAssoc
-		(         op TStar            Mul
-		<|>       op TSlash           Div
-		<|>       op TPercent         Rem
-		)
+	$ rightAssoc (op TColon           Cons)
+	$ leftAssoc  (op TPlus            Add
+	          <|> op TMinus           Sub)
+	$ leftAssoc  (op TStar            Mul
+	          <|> op TSlash           Div)
+	$ leftAssoc  (op TPercent         Rem)
 	$ noInfix
 where
 	op :: Token Op2 -> Parser Token Op2
@@ -219,7 +222,7 @@ where
 		=   liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
 		<|> op TTilde       Neg
 		<|> op TExclamation Not
-		<|> (simpleExpr >>= \e -> many field >>= \fs -> pure $ foldr Field e fs)
+		<|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field)
 	where
 		op :: Token Op1 -> Parser Token Expression
 		op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
@@ -231,6 +234,8 @@ where
 	simpleExpr = liftM Literal literal
 		<|> liftM Name name
 		<|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
+		<|> flip List [] o pure <$> bracked type
+		<|> List Nothing <$> bracked (seplist TComma expression)
 		<|> parenthised expression
 
 name :: Parser Token Name
@@ -249,6 +254,7 @@ type
 	<|> simpletype "Int"  TInt
 	<|> simpletype "Void" TVoid
 	<|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
+	<|> TList <$> bracked type
 	<?> P_Expected "type"
 where
 	simpletype s t = item (TName s) $> t
@@ -263,6 +269,9 @@ where
 parenthised :: (Parser Token a) -> Parser Token a
 parenthised p = item TParenOpen *> p <* item TParenClose
 
+bracked :: (Parser Token a) -> Parser Token a
+bracked p = item TBrackOpen *> p <* item TBrackClose
+
 braced :: (Parser Token a) -> Parser Token a
 braced p = item TBraceOpen *> p <* item TBraceClose
 
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 0f15930..e3a458d 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,8 +47,9 @@ from Sil.Types import :: Type
 	| App Name [Expression]
 	| BuiltinApp Op1 Expression
 	| BuiltinApp2 Expression Op2 Expression
-	| Tuple Int [Expression]
 	| Field Name Expression
+	| Tuple Int [Expression]
+	| List (Maybe Type) [Expression]
 
 :: Op1
 	= Neg //* ~
@@ -63,6 +64,7 @@ from Sil.Types import :: Type
 	| Equals //* ==
 	| LogOr  //* ||
 	| LogAnd //* &&
+	| Cons   //* :
 
 :: Literal
 	= BLit Bool
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index cc5c3ba..53384b3 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -32,7 +32,10 @@ where
 	toString (BuiltinApp op e)      = op <+ "(" <+ e <+ ")"
 	toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
 	toString (Tuple _ es)           = "(" <+ printersperse ", " es <+ ")"
-	toString (Field f e)            = e <+ "." <+ f
+	toString (List (Just t) [])     = "[" <+ t <+ "]"
+	toString (List (Just t) es)     = "[" <+ t <+ ":" <+ printersperse ", " es <+ "]"
+	toString (List Nothing es)      = "[" <+ printersperse ", " es <+ "]"
+	toString (Field f e)            = "(" <+ e <+ ")." <+ f
 
 instance toString Op1
 where
@@ -49,6 +52,7 @@ where
 	toString Equals = "=="
 	toString LogOr  = "||"
 	toString LogAnd = "&&"
+	toString Cons   = ":"
 
 instance toString Literal
 where
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
index 51d4229..14602d3 100644
--- a/Sil/Types.dcl
+++ b/Sil/Types.dcl
@@ -16,6 +16,7 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
 	| TVoid
 	| (-->) infixr Type Type
 	| TTuple Int [Type]
+	| TList Type
 
 :: TypeSize =
 	{ asize  :: Int
diff --git a/Sil/Types.icl b/Sil/Types.icl
index e314342..ba13cba 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -33,6 +33,7 @@ where
 	toString TVoid         = "Void"
 	toString (at --> rt)   = "(" <+ at <+ " -> " <+ rt <+ ")"
 	toString (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
+	toString (TList t)     = "[" <+ t <+ "]"
 
 instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]}
 
@@ -41,6 +42,7 @@ typeSize TVoid        = zero
 typeSize TBool        = {zero & bsize=1, btypes=[BT_Bool]}
 typeSize TInt         = {zero & bsize=1, btypes=[BT_Int]}
 typeSize (TTuple _ _) = {zero & asize=1}
+typeSize (TList _)    = {zero & asize=1}
 
 (+~) infixl 6 :: TypeSize TypeSize -> TypeSize
 (+~) a b =
@@ -78,6 +80,13 @@ where
 		type res op >>= \top -> pure
 		( top >>= \top ->
 		  te  >>= \te  -> tryApply top te)
+	type res (BuiltinApp2 e1 Cons e2) =
+		type res e1 >>= \te1 ->
+		type res e2 >>= \te2 -> pure
+		( te1 >>= \te1 ->
+		  te2 >>= \te2 ->
+		  let top = te1 --> TList te1 --> TList te1 in
+		  foldM tryApply top [te1,te2])
 	type res (BuiltinApp2 e1 op e2) =
 		type res e1 >>= \te1 ->
 		type res e2 >>= \te2 ->
@@ -85,6 +94,17 @@ where
 		( top >>= \top ->
 		  te1 >>= \te1 ->
 		  te2 >>= \te2 -> foldM tryApply top [te1,te2])
+	type res e=:(List (Just t) es) =
+		mapM (type res) es >>= \tes -> pure
+		(sequence tes >>= \tes -> case [(e,t`) \\ e <- es & t` <- tes | t <> t`] of
+			[(e`,t`):_] -> Error $ C_TypeMisMatch t e` t`
+			[]          -> Ok $ TList t)
+	type res (List Nothing []) = Nothing
+	type res e=:(List Nothing es) =
+		mapM (type res) es >>= \tes -> pure
+		(sequence tes >>= \tes -> case removeDup tes of
+			[t]    -> Ok $ TList t
+			[_:_]  -> Error $ C_CouldNotDeduceType e)
 	type res (Tuple n es)
 	| n > 32 = Just $ Error $ T_TooHighTupleArity n
 	| otherwise =
@@ -95,6 +115,15 @@ where
 			(Ok $ es!!(tupleEl - 1))
 			(Error $ T_IllegalField f te)
 		_ -> Error $ T_IllegalField f te)
+	| f == "hd" = type res e >>= \te -> pure (te >>= \te -> case te of
+		TList t -> Ok t
+		_       -> Error $ T_IllegalField f te)
+	| f == "tl" = type res e >>= \te -> pure (te >>= \te -> case te of
+		t=:(TList _) -> Ok t
+		_            -> Error $ T_IllegalField f te)
+	| f == "nil" = type res e >>= \te -> pure (te >>= \te -> case te of
+		(TList _) -> Ok TBool
+		_         -> Error $ T_IllegalField f te)
 	| otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField f)
 	where
 		f` = fromString f