From cc907a13395f2e2ac28cce642142d0908f1bc445 Mon Sep 17 00:00:00 2001
From: Adam Sampson <ats@offog.org>
Date: Mon, 7 Apr 2008 20:14:00 +0000
Subject: [PATCH] Pick the best type available for operators and array
 literals.

This is rather more expensive than the approach it was using, but it
does the right thing for things like "3 + 4(MYINT)" and "[3, 4(MYINT)]",
and the code's actually simpler.
---
 frontends/OccamTypes.hs | 64 ++++++++++++++++++++++++-----------------
 1 file changed, 37 insertions(+), 27 deletions(-)

diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs
index 6b41d23..c39414e 100644
--- a/frontends/OccamTypes.hs
+++ b/frontends/OccamTypes.hs
@@ -172,6 +172,23 @@ checkExpressionInt e = checkExpressionType A.Int e
 checkExpressionBool :: Check A.Expression
 checkExpressionBool e = checkExpressionType A.Bool e
 
+-- | Pick the more specific of a pair of types.
+betterType :: A.Type -> A.Type -> A.Type
+betterType t1 t2
+    = case betterType' t1 t2 of
+        Left () -> t1
+        Right () -> t2
+  where
+    betterType' :: A.Type -> A.Type -> Either () ()
+    betterType' A.Infer t = Right ()
+    betterType' t A.Infer = Left ()
+    betterType' t@(A.UserDataType _) _ = Left ()
+    betterType' _ t@(A.UserDataType _) = Right ()
+    betterType' t1@(A.Array ds1 et1) t2@(A.Array ds2 et2)
+      | length ds1 == length ds2 = betterType' et1 et2
+      | length ds1 < length ds2  = Left ()
+    betterType' t _ = Left ()
+
 --}}}
 --{{{  more complex checks
 
@@ -624,25 +641,21 @@ inferTypes = applyExplicitM9 doExpression doDimension doSubscript
             -- Expressions that aren't literals, but that modify the type
             -- context.
             A.Dyadic m op le re ->
-              case classifyOp op of
-                -- No info about the LHS; infer the RHS type from the LHS.
-                ComparisonOp ->
-                  do le' <- noTypeContext $ inferTypes le
-                     t <- typeOfExpression le'
-                     re' <- inTypeContext (Just t) $ inferTypes re
-                     return $ A.Dyadic m op le' re'
-                -- The RHS type is always A.Int.
-                ShiftOp ->
-                  do le' <- inferTypes le
-                     re' <- inTypeContext (Just A.Int) $ inferTypes re
-                     return $ A.Dyadic m op le' re'
-                -- Otherwise infer the LHS from the current context,
-                -- then the RHS from that.
-                _ ->
-                  do le' <- inferTypes le
-                     t <- typeOfExpression le'
-                     re' <- inTypeContext (Just t) $ inferTypes re
-                     return $ A.Dyadic m op le' re'
+              let -- Both types are the same.
+                  bothSame
+                    =  do lt <- inferTypes le >>= typeOfExpression
+                          rt <- inferTypes re >>= typeOfExpression
+                          inTypeContext (Just $ betterType lt rt) $
+                            descend outer
+                  -- The RHS type is always A.Int.
+                  intOnRight
+                    =  do le' <- inferTypes le
+                          re' <- inTypeContext (Just A.Int) $ inferTypes re
+                          return $ A.Dyadic m op le' re'
+              in case classifyOp op of
+                   ComparisonOp -> noTypeContext $ bothSame
+                   ShiftOp -> intOnRight
+                   _ -> bothSame
             A.SizeExpr _ _ -> noTypeContext $ descend outer
             A.Conversion _ _ _ _ -> noTypeContext $ descend outer
             A.FunctionCall m n es ->
@@ -910,15 +923,12 @@ inferTypes = applyExplicitM9 doExpression doDimension doSubscript
                                   A.ArrayElemArray aes')
                     _ -> diePC m $ formatCode "Table literal is not valid for type %" wantT
           where
-            -- | When walking along an array literal, use the type of the
-            -- first element as the default for the rest.
             doElems :: A.Type -> [A.ArrayElem] -> PassM (A.Type, [A.ArrayElem])
-            doElems t [] = return (t, [])
-            doElems t (ae:aes)
-                =  do (t', ae') <- doArrayElem t ae
-                      aes' <- sequence [doArrayElem t' ae >>* snd
-                                        | ae <- aes]
-                      return (t', ae':aes')
+            doElems t aes
+                =  do ts <- mapM (\ae -> doArrayElem t ae >>* fst) aes
+                      let bestT = foldl betterType t ts
+                      aes' <- mapM (\ae -> doArrayElem bestT ae >>* snd) aes
+                      return (bestT, aes')
         -- An expression: descend into it with the right context.
         doArrayElem wantT (A.ArrayElemExpr e)
             =  do e' <- inTypeContext (Just wantT) $ doExpression descend e