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

1 files changed, 65 insertions, 4 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