[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 (file)
--- 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 (file)
--- 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 (file)
--- 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))