bindist fixes

[ghc-hetmet.git] / compiler / parser / Lexer.x

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e891cae..2f22106 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -31,6 +31,8 @@
 -- Note that Alex itself generates code with with some unused bindings and
 -- without type signatures, so removing the flag might not be possible.
 
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
@@ -60,15 +62,11 @@ import Data.Char    ( chr, ord, isSpace )
 import Data.Ratio
 import Debug.Trace
 
-#if __GLASGOW_HASKELL__ >= 605
-import Data.Char       ( GeneralCategory(..), generalCategory, isPrint, isUpper )
-#else
-import Compat.Unicode  ( GeneralCategory(..), generalCategory, isPrint, isUpper )
-#endif
+import Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
 }
 
 $unispace    = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
-$whitechar   = [\ \n\r\f\v\xa0 $unispace]
+$whitechar   = [\ \n\r\f\v $unispace]
 $white_no_nl = $whitechar # \n
 $tab         = \t
 
@@ -78,16 +76,16 @@ $decdigit  = $ascdigit -- for now, should really be $digit (ToDo)
 $digit     = [$ascdigit $unidigit]
 
 $special   = [\(\)\,\;\[\]\`\{\}]
-$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
 $unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
 $symbol    = [$ascsymbol $unisymbol] # [$special \_\:\"\']
 
 $unilarge  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
-$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
+$asclarge  = [A-Z]
 $large     = [$asclarge $unilarge]
 
 $unismall  = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
-$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
+$ascsmall  = [a-z]
 $small     = [$ascsmall $unismall \_]
 
 $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
@@ -250,6 +248,8 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
        $whitechar* (NO(T?)INLINE|no(t?)inline)
                                        { token (ITspec_inline_prag False) }
   "{-#" $whitechar* (SOURCE|source)    { token ITsource_prag }
+  "{-#" $whitechar* (WARNING|warning)
+                                       { token ITwarning_prag }
   "{-#" $whitechar* (DEPRECATED|deprecated)
                                        { token ITdeprecated_prag }
   "{-#" $whitechar* (SCC|scc)          { token ITscc_prag }
@@ -258,7 +258,10 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
 
- "{-#"                                 { nested_comment lexToken }
+  -- We ignore all these pragmas, but don't generate a warning for them
+  -- CFILES is a hugs-only thing.
+  "{-#" $whitechar* (OPTIONS_HUGS|options_hugs|OPTIONS_NHC98|options_nhc98|OPTIONS_JHC|options_jhc|CFILES|cfiles)
+                    { nested_comment lexToken }
 
   -- ToDo: should only be valid inside a pragma:
   "#-}"                                { token ITclose_prag}
@@ -276,12 +279,18 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 }
 
 <0> {
+  -- In the "0" mode we ignore these pragmas
+  "{-#"  $whitechar* (OPTIONS|options|OPTIONS_GHC|options_ghc|OPTIONS_HADDOCK|options_haddock|LANGUAGE|language|INCLUDE|include)
+                     { nested_comment lexToken }
+}
+
+<0> {
   "-- #" .* ;
 }
 
 <0,option_prags> {
-       -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ... 
-  "{-#" $whitechar* $idchar+           { nested_comment lexToken }
+  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")
+                    (nested_comment lexToken) }
 }
 
 -- '0' state: ordinary lexemes
@@ -468,6 +477,7 @@ data Token
   | ITspec_inline_prag Bool    -- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
   | ITrules_prag
+  | ITwarning_prag
   | ITdeprecated_prag
   | ITline_prag
   | ITscc_prag
@@ -504,8 +514,8 @@ data Token
   | ITvocurly
   | ITvccurly
   | ITobrack
-  | ITopabrack                 -- [:, for parallel arrays with -fparr
-  | ITcpabrack                 -- :], for parallel arrays with -fparr
+  | ITopabrack                 -- [:, for parallel arrays with -XParr
+  | ITcpabrack                 -- :], for parallel arrays with -XParr
   | ITcbrack
   | IToparen
   | ITcparen
@@ -1218,7 +1228,7 @@ lex_char c inp = do
       c | isAny c -> do setInput inp; return c
       _other -> lit_error
 
-isAny c | c > '\xff' = isPrint c
+isAny c | c > '\x7f' = isPrint c
        | otherwise  = is_any c
 
 lex_escape :: P Char
@@ -1242,7 +1252,7 @@ lex_escape = do
 
        'x'   -> readNum is_hexdigit 16 hexDigit
        'o'   -> readNum is_octdigit  8 octDecDigit
-       x | is_digit x -> readNum2 is_digit 10 octDecDigit (octDecDigit x)
+       x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
 
        c1 ->  do
           i <- getInput
@@ -1377,6 +1387,11 @@ warn option warning srcspan _buf _len = do
     addWarning option srcspan warning
     lexToken
 
+warnThen :: DynFlag -> SDoc -> Action -> Action
+warnThen option warning action srcspan buf len = do
+    addWarning option srcspan warning
+    action srcspan buf len
+
 -- -----------------------------------------------------------------------------
 -- The Parse Monad
 
@@ -1486,7 +1501,7 @@ alexGetChar (AI loc ofs s)
 
        adj_c 
          | c <= '\x06' = non_graphic
-         | c <= '\xff' = c
+         | c <= '\x7f' = c
           -- Alex doesn't handle Unicode, so when Unicode
           -- character is encoutered we output these values
           -- with the actual character value hidden in the state.
@@ -1496,7 +1511,7 @@ alexGetChar (AI loc ofs s)
                  LowercaseLetter       -> lower
                  TitlecaseLetter       -> upper
                  ModifierLetter        -> other_graphic
-                 OtherLetter           -> other_graphic
+                 OtherLetter           -> lower -- see #1103
                  NonSpacingMark        -> other_graphic
                  SpacingCombiningMark  -> other_graphic
                  EnclosingMark         -> other_graphic
@@ -1550,7 +1565,7 @@ getLexState :: P Int
 getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
 
 -- for reasons of efficiency, flags indicating language extensions (eg,
--- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
+-- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
 -- integer
 
 genericsBit, ffiBit, parrBit :: Int
@@ -1565,7 +1580,7 @@ bangPatBit = 8    -- Tells the parser to understand bang-patterns
                -- (doesn't affect the lexer)
 tyFamBit   = 9 -- indexed type families: 'family' keyword and kind sigs
 haddockBit = 10 -- Lex and parse Haddock comments
-magicHashBit = 11 -- # in both functions and operators
+magicHashBit = 11 -- "#" in both functions and operators
 kindSigsBit = 12 -- Kind signatures on type variables
 recursiveDoBit = 13 -- mdo
 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
@@ -1597,14 +1612,12 @@ qqEnabled        flags = testBit flags qqBit
 
 -- PState for parsing options pragmas
 --
-pragState :: StringBuffer -> SrcLoc -> PState
-pragState buf loc  = 
+pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+pragState dynflags buf loc =
   PState {
-      buffer         = buf,
+      buffer        = buf,
       messages      = emptyMessages,
-      -- XXX defaultDynFlags is not right, but we don't have a real
-      -- dflags handy
-      dflags        = defaultDynFlags,
+      dflags        = dynflags,
       last_loc      = mkSrcSpan loc loc,
       last_offs     = 0,
       last_len      = 0,