Add tuples (see #1)

8 files changed, 114 insertions, 37 deletions

diff --git a/Sil/Compile.dcl b/Sil/Compile.dcl
index 5eb35a2..7b0cf2f 100644
--- a/Sil/Compile.dcl
+++ b/Sil/Compile.dcl
@@ -12,6 +12,7 @@ from Sil.Types import :: Type, :: TypeError
 
 :: CompileError
 	= UndefinedName Name
+	| UndefinedField Name
 	| VariableLabel
 	| FunctionOnStack
 	| TypeError TypeError Expression
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index cad8000..2a6ba54 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -1,5 +1,6 @@
 implementation module Sil.Compile
 
+import StdBool
 import StdEnum
 from StdFunc import const, flip, o
 import StdList
@@ -212,17 +213,17 @@ where
 	invert :: TypeSize -> TypeSize
 	invert ts = {zero & asize=0-ts.asize, bsize=0-ts.bsize}
 
-checkType :: Type Expression -> Gen ()
-checkType t e = getTypeResolver >>= \tr -> case type tr e of
+getType :: Expression -> Gen Type
+getType e = getTypeResolver >>= \tr -> case type tr e of
 	Nothing          -> error $ CouldNotDeduceType e
 	Just (Error err) -> error $ TypeError err e
-	Just (Ok t`)     -> if (t == t`) nop (error $ TypeMisMatch t e)
+	Just (Ok t)      -> pure $ t
+
+checkType :: Type Expression -> Gen ()
+checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ TypeMisMatch t e)
 
 checkTypeName :: Name Expression -> Gen Type
-checkTypeName n e = getTypeResolver >>= \tr -> case type tr n of
-	Nothing          -> error $ CouldNotDeduceType $ Name n
-	Just (Error err) -> error $ TypeError err $ Name n
-	Just (Ok t`)     -> checkType t` e $> t`
+checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
 
 class gen a :: a -> Gen ()
 
@@ -254,8 +255,9 @@ where
 		tell [ 'ABC'.Annotation $ toOAnnot` [typeSize a.arg_type \\ a <- f.f_args]
 		     , 'ABC'.Label $ toLabel f.f_name
 		     ] *>
-		tell (repeatn retSize.asize 'ABC'.Create) *> growStack {retSize & bsize=0} *>
+		tell (repeatn retSize.asize 'ABC'.Create) *>
 		mapM_ reserveVar [(a.arg_name, a.arg_type) \\ a <- f.f_args] *>
+		growStack {retSize & bsize=0} *>
 		newReturn cleanup` *>
 		pushTypeResolver typeresolver *>
 		setReturnType f.f_type *>
@@ -448,16 +450,18 @@ where
 				     ] *>
 				growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes)
 			_ -> liftT $ Error $ UndefinedName n
-	gen (BuiltinApp op arg) = genToBStack arg *> gen op
+	gen (BuiltinApp op arg) =
+		gen arg *>
+		gen op
 	gen (BuiltinApp2 e1 LogOr e2) =
 		checkType TBool e1 *>
 		checkType TBool e2 *>
 		fresh "or_true" >>= \true ->
 		fresh "or_end" >>= \end ->
 		storeStackOffsets *>
-		genToBStack e1 *>
+		gen e1 *>
 		tell [ 'ABC'.JmpTrue true ] *>
-		genToBStack e2 *>
+		gen e2 *>
 		tell [ 'ABC'.Jmp end ] *>
 		restoreStackOffsets *>
 		tell [ 'ABC'.Label true
@@ -470,24 +474,44 @@ where
 		fresh "and_false" >>= \false ->
 		fresh "and_end" >>= \end ->
 		storeStackOffsets *>
-		genToBStack e1 *>
+		gen e1 *>
 		tell [ 'ABC'.JmpFalse false ] *>
-		genToBStack e2 *>
+		gen e2 *>
 		tell [ 'ABC'.Jmp end ] *>
 		restoreStackOffsets *>
 		tell [ 'ABC'.Label false
 		     , 'ABC'.PushB False ] *>
 		growStack {zero & bsize=1} *>
 		tell [ 'ABC'.Label end ]
-	gen (BuiltinApp2 e1 op e2) = mapM genToBStack [e2,e1] *> gen op
+	gen (BuiltinApp2 e1 op e2) =
+		mapM gen [e2,e1] *>
+		gen op
+	gen (Tuple i es) =
+		comment "Building tuple" *>
+		tell [ 'ABC'.Create ] *>
+		growStack {zero & asize=1} *>
+		mapM genToAStack (reverse es) *>
+		tell [ 'ABC'.Raw $ "\tfillh\t_Tuple\t" <+ i <+ "\t" <+ i ] *>
+		shrinkStack {zero & asize=i}
+	gen e=:(Field f e`)
+	| isTuple =
+		getType e` >>= \(TTuple arity tes) ->
+		gen e` *>
+		tell [ 'ABC'.ReplArgs arity arity
+		     , 'ABC'.Pop_a (tupleEl - 1)
+		     , 'ABC'.Update_a 0 (arity - tupleEl)
+		     , 'ABC'.Pop_a (arity - tupleEl)
+		     ] *>
+		case typeSize $ tes!!(tupleEl - 1) of
+			{bsize=0} -> nop
+			{btypes} -> mapM (flip toBStack 1) btypes *> nop
+	| otherwise =
+		error $ UndefinedField f
+	where
+		f` = fromString f
 
-genToBStack :: Expression -> Gen ()
-genToBStack (Name n) = findVar n >>= getLoc
-where
-	getLoc :: Address -> Gen ()
-	getLoc (AAddr i) = tell ['ABC'.PushI_a $ i] *> growStack {zero & bsize=1}
-	getLoc (BAddr i) = tell ['ABC'.Push_b  $ i] *> growStack {zero & bsize=1}
-genToBStack e = gen e
+		isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
+		tupleEl = toInt $ toString $ tl f`
 
 instance gen Op1
 where
@@ -539,6 +563,14 @@ where
 		'ABC'.BT_Bool -> 'ABC'.FillB_b
 		'ABC'.BT_Int  -> 'ABC'.FillI_b
 
+genToAStack :: Expression -> Gen ()
+genToAStack (Literal (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
+where toABCBool = toString o map toUpper o fromString o toString
+genToAStack (Literal (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
+genToAStack e = getType e >>= \t -> case typeSize t of
+	{bsize=0} -> gen e
+	{btypes}  -> gen e <* comment "To A-stack" <* mapM BtoAStack btypes <* comment "Done to A-stack"
+
 comment :: String -> Gen ()
 comment s = tell ['ABC'.Comment s]
 
diff --git a/Sil/Parse.dcl b/Sil/Parse.dcl
index 0db10e6..d5bf453 100644
--- a/Sil/Parse.dcl
+++ b/Sil/Parse.dcl
@@ -14,6 +14,7 @@ from Sil.Util.Parser import class name
 	| TBraceClose         //* }
 	| TComma              //* ,
 	| TSemicolon          //* ;
+	| TField String       //* . and field name
 	| TAssign             //* :=
 	| TTilde              //* ~
 	| TExclamation        //* !
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index b5e0114..4fdc479 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -36,6 +36,7 @@ where
 	toString TBraceClose      = "}"
 	toString TComma           = ","
 	toString TSemicolon       = ";"
+	toString (TField f)       = "." +++ f
 	toString TAssign          = ":="
 	toString TTilde           = "~"
 	toString TPlus            = "+"
@@ -74,6 +75,8 @@ where
 		skipUntilEndOfComment []          = []
 		skipUntilEndOfComment ['*':'/':r] = r
 		skipUntilEndOfComment [_:r]       = skipUntilEndOfComment r
+	tks ['.':r=:[c:_]] t | isNameChar c = tks r` [TField $ toString f:t]
+	where (f,r`) = span isNameChar r
 	tks [':':'=':r] t = tks r [TAssign         :t]
 	tks ['=':'=':r] t = tks r [TDoubleEquals   :t]
 	tks ['|':'|':r] t = tks r [TDoubleBar      :t]
@@ -109,7 +112,7 @@ where
 		(num,numrest)   = span isDigit cs
 
 	isNameChar :: Char -> Bool
-	isNameChar c = isAlpha c || isMember c ['_\'']
+	isNameChar c = isAlphanum c || isMember c ['_\'']
 
 	isNotNameChar = not o isNameChar
 
@@ -221,13 +224,20 @@ where
 		=   liftM2 App name (item TParenOpen *> seplist TComma expression <* item TParenClose)
 		<|> op TTilde       Neg
 		<|> op TExclamation Not
-		<|> liftM Literal literal
-		<|> liftM Name name
-		<|> parenthised expression
+		<|> (simpleExpr >>= \e -> many field >>= \fs -> pure $ foldr Field e fs)
 	where
 		op :: Token Op1 -> Parser Token Expression
 		op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
 
+		field :: Parser Token Name
+		field = satisfy (\t -> t =: TField _) >>= \(TField f) -> pure f
+
+	simpleExpr :: Parser Token Expression
+	simpleExpr = liftM Literal literal
+		<|> liftM Name name
+		<|> (parenthised (min2seplist TComma expression) >>= \es -> pure $ Tuple (length es) es)
+		<|> parenthised expression
+
 name :: Parser Token Name
 name = liftM (\(TName s) -> s) $ satisfy isName <?> Expected "name"
 where
@@ -240,12 +250,13 @@ arg = (type >>= \type -> name >>= \name -> pure {arg_type=type, arg_name=name})
 
 type :: Parser Token Type
 type
-	=   type "Bool" TBool
-	<|> type "Int"  TInt
-	<|> type "Void" TVoid
+	=   simpletype "Bool" TBool
+	<|> simpletype "Int"  TInt
+	<|> simpletype "Void" TVoid
+	<|> (parenthised (min2seplist TComma type) >>= \ts -> pure $ TTuple (length ts) ts)
 	<?> Expected "type"
 where
-	type s t = item (TName s) $> t
+	simpletype s t = item (TName s) $> t
 
 literal :: Parser Token Literal
 literal = satisfy isLit >>= \(TLit lit) -> pure lit
@@ -259,3 +270,10 @@ parenthised p = item TParenOpen *> p <* item TParenClose
 
 braced :: (Parser Token a) -> Parser Token a
 braced p = item TBraceOpen *> p <* item TBraceClose
+
+min2seplist :: a (Parser a b) -> Parser a [b] | ==, name a
+min2seplist sep val =
+	val >>= \v1 ->
+	item sep *>
+	seplist sep val >>= \vs ->
+	pure [v1:vs]
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 669f2f6..0f15930 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -47,6 +47,8 @@ from Sil.Types import :: Type
 	| App Name [Expression]
 	| BuiltinApp Op1 Expression
 	| BuiltinApp2 Expression Op2 Expression
+	| Tuple Int [Expression]
+	| Field Name Expression
 
 :: Op1
 	= Neg //* ~
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index 43d27fc..cc5c3ba 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -31,6 +31,8 @@ where
 	toString (App n args)           = n <+ "(" <+ printersperse ", " args <+ ")"
 	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
 
 instance toString Op1
 where
diff --git a/Sil/Types.dcl b/Sil/Types.dcl
index d44a373..0821078 100644
--- a/Sil/Types.dcl
+++ b/Sil/Types.dcl
@@ -14,9 +14,11 @@ from Sil.Syntax import :: Expression, :: Function, :: Name, :: Op1, :: Op2
 	| TInt
 	| TVoid
 	| (-->) infixr Type Type
+	| TTuple Int [Type]
 
 :: TypeError
 	= IllegalApplication Type Type
+	| IllegalField Name Type
 
 :: TypeSize =
 	{ asize  :: Int
diff --git a/Sil/Types.icl b/Sil/Types.icl
index cd9b9a4..55e1cc0 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -1,6 +1,7 @@
 implementation module Sil.Types
 
-from StdFunc import const
+import StdBool
+from StdFunc import const, o
 import StdList
 import StdMisc
 import StdOverloaded
@@ -12,22 +13,25 @@ import Control.Applicative
 import Control.Monad
 import Data.Error
 from Data.Func import $
+import Data.Functor
 import Data.Maybe
 from Text import <+
 
 from ABC.Assembler import :: BasicType(..)
 
 import Sil.Syntax
+import Sil.Util.Printer
 
 derive gEq Type
 instance == Type where == a b = gEq{|*|} a b
 
 instance toString Type
 where
-	toString TBool = "Bool"
-	toString TInt  = "Int"
-	toString TVoid = "Void"
-	toString (at --> rt) = "(" <+ at <+ " -> " <+ rt <+ ")"
+	toString TBool         = "Bool"
+	toString TInt          = "Int"
+	toString TVoid         = "Void"
+	toString (at --> rt)   = "(" <+ at <+ " -> " <+ rt <+ ")"
+	toString (TTuple _ ts) = "(" <+ printersperse ", " ts <+ ")"
 
 instance toString TypeError
 where
@@ -36,9 +40,10 @@ where
 instance zero TypeSize where zero = {asize=0, bsize=0, btypes=[]}
 
 typeSize :: Type -> TypeSize
-typeSize TVoid = zero
-typeSize TBool = {zero & bsize=1, btypes=[BT_Bool]}
-typeSize TInt  = {zero & bsize=1, btypes=[BT_Int]}
+typeSize TVoid        = zero
+typeSize TBool        = {zero & bsize=1, btypes=[BT_Bool]}
+typeSize TInt         = {zero & bsize=1, btypes=[BT_Int]}
+typeSize (TTuple _ _) = {zero & asize=1}
 
 (+~) infixl 6 :: TypeSize TypeSize -> TypeSize
 (+~) a b =
@@ -83,6 +88,20 @@ where
 		( top >>= \top ->
 		  te1 >>= \te1 ->
 		  te2 >>= \te2 -> foldM tryApply top [te1,te2])
+	type res (Tuple n es) =
+		mapM (type res) es >>= \ats -> pure (sequence ats >>= pure o TTuple n)
+	type res (Field f e)
+	| isTuple = type res e >>= \te -> pure (te >>= \te -> case te of
+		TTuple arity es -> if (0 < tupleEl && tupleEl <= arity)
+			(Ok $ es!!(tupleEl - 1))
+			(Error $ IllegalField f te)
+		_ -> Error $ IllegalField f te)
+	| otherwise = type res e >>= \te -> pure (te >>= Error o IllegalField f)
+	where
+		f` = fromString f
+
+		isTuple = length f` >= 2 && hd f` == '_' && all isDigit (tl f`)
+		tupleEl = toInt $ toString $ tl f`
 
 tryApply :: Type Type -> MaybeError TypeError Type
 tryApply ft=:(at --> rt) et