Small fixes to the generics branch to get rid of warnings,

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

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 9237384..26f7e48 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -51,6 +51,7 @@ module Lexer (
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages, 
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
+   activeContext, nextIsEOF,
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    addWarning,
@@ -430,6 +431,7 @@ data Token
   | ITderiving
   | ITdo
   | ITelse
+  | ITgeneric
   | IThiding
   | ITif
   | ITimport
@@ -484,6 +486,8 @@ data Token
   | IToptions_prag String
   | ITinclude_prag String
   | ITlanguage_prag
+  | ITvect_prag
+  | ITvect_scalar_prag
 
   | ITdotdot                   -- reserved symbols
   | ITcolon
@@ -632,6 +636,7 @@ reservedWordsFM = listToUFM $
        ( "deriving",   ITderiving,     0 ), 
        ( "do",         ITdo,           0 ),       
        ( "else",       ITelse,         0 ),     
+       ( "generic",    ITgeneric,      bit genericsBit ),     
        ( "hiding",     IThiding,       0 ),
        ( "if",         ITif,           0 ),       
        ( "import",     ITimport,       0 ),   
@@ -1670,6 +1675,11 @@ getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b)
 setInput :: AlexInput -> P ()
 setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } ()
 
+nextIsEOF :: P Bool
+nextIsEOF = do
+  AI _ s <- getInput
+  return $ atEnd s
+
 pushLexState :: Int -> P ()
 pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} ()
 
@@ -1684,6 +1694,15 @@ popNextToken
     = P $ \s@PState{ alr_next_token = m } ->
               POk (s {alr_next_token = Nothing}) m
 
+activeContext :: P Bool
+activeContext = do
+  ctxt <- getALRContext
+  expc <- getAlrExpectingOCurly
+  impt <- implicitTokenPending
+  case (ctxt,expc) of
+    ([],Nothing) -> return impt
+    _other       -> return True
+
 setAlrLastLoc :: SrcSpan -> P ()
 setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
 
@@ -1707,6 +1726,13 @@ setJustClosedExplicitLetBlock b
 setNextToken :: Located Token -> P ()
 setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
 
+implicitTokenPending :: P Bool
+implicitTokenPending
+    = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
+              case ts of
+              [] -> POk s False
+              _  -> POk s True
+
 popPendingImplicitToken :: P (Maybe (Located Token))
 popPendingImplicitToken
     = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
@@ -1728,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
 -- integer
 
 genericsBit :: Int
-genericsBit = 0 -- {| and |}
+genericsBit = 0 -- {|, |} and "generic"
 ffiBit :: Int
 ffiBit    = 1
 parrBit :: Int
@@ -2253,13 +2279,14 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("generated", token ITgenerated_prag),
                            ("core", token ITcore_prag),
                            ("unpack", token ITunpack_prag),
-                           ("ann", token ITann_prag)])
+                           ("ann", token ITann_prag),
+                           ("vectorize", token ITvect_prag)])
 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                              ("notinline conlike", token (ITinline_prag NoInline ConLike)),
                              ("specialize inline", token (ITspec_inline_prag True)),
-                             ("specialize notinline", token (ITspec_inline_prag False))])
-
+                             ("specialize notinline", token (ITspec_inline_prag False)),
+                             ("vectorize scalar", token ITvect_scalar_prag)])
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
@@ -2278,6 +2305,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                           canonical prag' = case prag' of
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"
+                                              "vectorise" -> "vectorize"
                                               "constructorlike" -> "conlike"
                                               _ -> prag'
                           canon_ws s = unwords (map canonical (words s))