From: simonmar <unknown>
Date: Thu, 26 Apr 2001 12:16:57 +0000 (+0000)
Subject: [project @ 2001-04-26 12:16:57 by simonmar]
X-Git-Tag: Approximately_9120_patches~2099
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=998444dc513e63103f9854543da4f603b2025744;p=ghc-hetmet.git

[project @ 2001-04-26 12:16:57 by simonmar]
Allow out-of-range character literals to appear in interface-file
unfoldings.  They occasionally pop up in Core.
---

diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs
index fb93ef4..3d1f220 100644
--- a/ghc/compiler/basicTypes/Literal.lhs
+++ b/ghc/compiler/basicTypes/Literal.lhs
@@ -12,7 +12,7 @@ module Literal
 	, literalType, literalPrimRep
 	, hashLiteral
 
-	, inIntRange, inWordRange, tARGET_MAX_INT
+	, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
 
 	, word2IntLit, int2WordLit, char2IntLit, int2CharLit
 	, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
@@ -61,6 +61,9 @@ tARGET_MIN_INT = -2147483648
 tARGET_MAX_INT =  2147483647
 #endif
 tARGET_MAX_WORD = (tARGET_MAX_INT * 2) + 1
+
+tARGET_MAX_CHAR :: Int
+tARGET_MAX_CHAR = 0x10ffff
 \end{code}
  
 
@@ -145,6 +148,9 @@ mkMachWord64 x = MachWord64 x	-- Ditto?
 inIntRange, inWordRange :: Integer -> Bool
 inIntRange  x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
 inWordRange x = x >= 0		    && x <= tARGET_MAX_WORD
+
+inCharRange :: Int -> Bool
+inCharRange c =  c >= 0 && c <= tARGET_MAX_CHAR
 \end{code}
 
 	Coercions
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index d0463da..eb92cd3 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -27,7 +27,7 @@ import RnMonad
 import RnEnv
 import RnHiFiles	( lookupFixityRn )
 import CmdLineOpts	( DynFlag(..), opt_IgnoreAsserts )
-import Literal		( inIntRange )
+import Literal		( inIntRange, inCharRange )
 import BasicTypes	( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
 import PrelNames	( hasKey, assertIdKey, minusName, negateName, fromIntegerName,
 			  eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
@@ -799,7 +799,10 @@ that the types and classes they involve
 are made available.
 
 \begin{code}
-litFVs (HsChar c)             = returnRn (unitFV charTyCon_name)
+litFVs (HsChar c)
+   = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
+     returnRn (unitFV charTyCon_name)
+
 litFVs (HsCharPrim c)         = returnRn (unitFV (getName charPrimTyCon))
 litFVs (HsString s)           = returnRn (mkFVs [listTyCon_name, charTyCon_name])
 litFVs (HsStringPrim s)       = returnRn (unitFV (getName addrPrimTyCon))
@@ -916,4 +919,7 @@ patSynErr e
 doStmtListErr e
   = sep [ptext SLIT("`do' statements must end in expression:"),
 	 nest 4 (ppr e)]
+
+bogusCharError c
+  = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
 \end{code}
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index c8e454d..165ce03 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -49,12 +49,14 @@ module Outputable (
 
 import {-# SOURCE #-} 	Name( Name )
 
-import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
 import CmdLineOpts	( opt_PprStyle_Debug, opt_PprUserLength )
 import FastString
 import qualified Pretty
 import Pretty		( Doc, Mode(..), TextDetails(..), fullRender )
 import Panic
+
+import Word		( Word32 )
+import IO		( Handle, hPutChar, hPutStr, stderr, stdout )
 import Char             ( chr, ord, isDigit )
 \end{code}
 
@@ -360,7 +362,7 @@ showCharLit c rest
     | c == ord '\r' = "\\r" ++ rest
     | c == ord '\t' = "\\t" ++ rest
     | c == ord '\v' = "\\v" ++ rest
-    | otherwise     = ('\\':) $ shows c $ case rest of
+    | otherwise     = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
         d:_ | isDigit d -> "\\&" ++ rest
         _               -> rest
 
@@ -369,7 +371,8 @@ showCharLit c rest
 -- of Char and String.
 
 pprHsChar :: Int -> SDoc
-pprHsChar c = text (show (chr c))
+pprHsChar c | not (inCharRange c) = char '\\' <> show (fromIntegral c :: Word32)
+            | otherwise = text (show (chr c))
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))