From: simonpj <unknown>
Date: Thu, 28 Nov 2002 10:04:53 +0000 (+0000)
Subject: [project @ 2002-11-28 10:04:52 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~1397
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b44c6881743abf8f4c3c0612c482ede8b835ac37;p=ghc-hetmet.git

[project @ 2002-11-28 10:04:52 by simonpj]
Report over-size tuples gracefully
---

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 97697a0..b1481e3 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -30,7 +30,7 @@ import TcRnMonad
 import RnEnv
 import RnNames		( importsFromLocalDecls )
 import RnTypes		( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
-			  dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
+			  dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
 import CmdLineOpts	( DynFlag(..), opt_IgnoreAsserts )
 import BasicTypes	( Fixity(..), FixityDirection(..), IPName(..),
 			  defaultFixity, negateFixity, compareFixity )
@@ -322,11 +322,13 @@ rnExpr (ExplicitPArr _ exps)
     returnM  (ExplicitPArr placeHolderType exps', 
 	       fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 
-rnExpr (ExplicitTuple exps boxity)
-  = rnExprs exps	 			`thenM` \ (exps', fvs) ->
+rnExpr e@(ExplicitTuple exps boxity)
+  = checkTupSize tup_size			`thenM_`
+    rnExprs exps	 			`thenM` \ (exps', fvs) ->
     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
   where
-    tycon_name = tupleTyCon_name boxity (length exps)
+    tup_size   = length exps
+    tycon_name = tupleTyCon_name boxity tup_size
 
 rnExpr (RecordCon con_id rbinds)
   = lookupOccRn con_id 			`thenM` \ conname ->
diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs
index 88963e1..421378a 100644
--- a/ghc/compiler/rename/RnTypes.lhs
+++ b/ghc/compiler/rename/RnTypes.lhs
@@ -8,7 +8,7 @@ module RnTypes ( rnHsType, rnContext,
 		 rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs, 
 		 rnPat, rnPats, rnPatsAndThen,	-- Here because it's not part 
 		 rnOverLit, litFVs,		-- of any mutual recursion	
-		 precParseErr, sectionPrecErr, dupFieldErr, patSigErr
+		 precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
   ) where
 
 import CmdLineOpts	( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) )
@@ -27,6 +27,7 @@ import TcRnMonad
 import PrelNames( cCallishClassKeys, eqStringName, eqClassName, ordClassName, 
 		  negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName,
 		  timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName )
+import Constants	( mAX_TUPLE_SIZE )
 import TysWiredIn	( intTyCon )
 import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
 			  floatPrimTyCon, doublePrimTyCon )
@@ -402,10 +403,12 @@ rnPat (PArrPat pats _)
     implicit_fvs = mkFVs [lengthPName, indexPName]
 
 rnPat (TuplePat pats boxed)
-  = rnPats pats			`thenM` \ (patslist, fvs) ->
+  = checkTupSize tup_size	`thenM_`
+    rnPats pats			`thenM` \ (patslist, fvs) ->
     returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
   where
-    tycon_name = tupleTyCon_name boxed (length pats)
+    tup_size   = length pats
+    tycon_name = tupleTyCon_name boxed tup_size
 
 rnPat (TypePat name) =
     rnHsTypeFVs (text "In a type pattern") name	`thenM` \ (name', fvs) ->
@@ -545,8 +548,16 @@ rnOverLit (HsFractional i _)
 %*							*
 %*********************************************************
 
-\end{code}
 \begin{code}
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+  | tup_size <= mAX_TUPLE_SIZE 
+  = returnM ()
+  | otherwise		       
+  = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
+		 nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
+		 nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
+
 forAllWarn doc ty tyvar
   = ifOptM Opt_WarnUnusedMatches 	$
     getModeRn				`thenM` \ mode ->