Fix parsing of pragmas.

mainland · Oct 2, 2014 · e22ba3c · e22ba3c
1 parent 3206883
commit e22ba3c
Show file tree

Hide file tree

Showing 2 changed files with 44 additions and 13 deletions.
diff --git a/Language/C/Parser/Lexer.x b/Language/C/Parser/Lexer.x
@@ -32,7 +32,9 @@ import Data.Char (isAlphaNum,
                   isSpace,
                   chr,
                   toLower)
-import Data.List (foldl', intersperse)
+import Data.List (foldl',
+                  intersperse,
+                  isPrefixOf)
 import Data.Loc
 import qualified Data.Map as Map
 import Data.Ratio ((%))
@@ -144,7 +146,7 @@ c :-
  ^ $whitechar* "#line" $whitechar+ $digit+ $whitechar+ \" [^\"]* \" .* { setLineFromPragma }
  ^ $whitechar* "#" $whitechar+ $digit+ $whitechar+ \" [^\"]* \" .*     { setLineFromPragma }
 
- ^ $whitechar* "#" $whitechar* "pragma" $whitechar+ { lexPragmaTok }
+ $whitechar* "#" $whitechar* "pragma" $whitechar+ .* { pragmaTok }
 
  @ccomment ;
  @cppcomment ;
@@ -343,18 +345,21 @@ lexAnti antiTok beg end = do
     isIdChar '\'' = True
     isIdChar c    = isAlphaNum c
 
-lexPragmaTok :: Action
-lexPragmaTok beg _ = do
-    s    <- lexPragma ""
-    end  <- getInput
-    return $ locateTok beg end (Tpragma (inputString beg end))
+pragmaTok :: Action
+pragmaTok beg end =
+    return $ locateTok beg end (Tpragma (findPragma (inputString beg end)))
   where
-    lexPragma :: String -> P String
-    lexPragma s = do
-        c <- nextChar
-        case c of
-          '\n' -> return (reverse s)
-          _    -> lexPragma (c : s)
+    findPragma :: String -> String
+    findPragma s | pragma `isPrefixOf` s =
+        (trim . drop (length pragma)) s
+      where
+        trim = f . f
+        f = reverse . dropWhile isSpace
+    findPragma s =
+        findPragma (tail s)
+
+    pragma :: String
+    pragma = "pragma"
 
 -- XXX: Gross hack. We assume the first character of our input is the textual
 -- representation of tok, e.g., '{' or ';'. We then scan to the first '/', which

diff --git a/tests/unit/Main.hs b/tests/unit/Main.hs
@@ -22,6 +22,7 @@ tests = [ constantTests
         , cQuotationTests
         , cPatternAntiquotationTests
         , statementCommentTests
+        , regressionTests
         , objcTests
         ]
 
@@ -305,3 +306,28 @@ statementCommentTests = testGroup "Statement comments"
     test_semi_comment =
         [cstms|x = 1; $comment:("/* Test 1 */") return x + y;|]
           @?= [cstms|x = 1; /* Test 1 */ return x + y;|]
+
+regressionTests :: Test
+regressionTests = testGroup "Regressions"
+    [ testCase "pragmas" test_pragmas ]
+  where
+    test_pragmas :: Assertion
+    test_pragmas =
+        [cstms|
+        #pragma omp sections
+        {
+            #pragma omp section
+            a = 1;
+        }
+        |]
+
+        @?= [ C.Pragma "omp sections" noLoc
+            , C.Block [ C.BlockStm (C.Pragma "omp section" noLoc)
+                      , C.BlockStm (C.Exp (Just $ C.Assign (C.Var (C.Id "a" noLoc) noLoc)
+                                                           C.JustAssign
+                                                           (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc)
+                                                           noLoc)
+                                          noLoc)
+                      ]
+                      noLoc
+            ]