X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=e0fb04b001ed49cba6692d41a00cd60db393ef14;hb=8d6e1b1d33ea8f21204911155af6b829d1ae031b;hp=cb251366672b1dcb342897aa82a6265fa971b0c1;hpb=f940a549b7562dcdbea3af81ee93b1660d279497;p=ghc-hetmet.git

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index cb25136..e0fb04b 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -18,9 +18,6 @@
 module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
 		parseHeader ) where
 
-#define INCLUDE #include 
-INCLUDE "HsVersions.h"
-
 import HsSyn
 import RdrHsSyn
 import HscTypes		( IsBootInterface, DeprecTxt )
@@ -319,6 +316,7 @@ incorrect.
  PRIMCHAR	{ L _ (ITprimchar   _) }
  PRIMSTRING	{ L _ (ITprimstring _) }
  PRIMINTEGER	{ L _ (ITprimint    _) }
+ PRIMWORD 	{ L _ (ITprimword  _) }
  PRIMFLOAT	{ L _ (ITprimfloat  _) }
  PRIMDOUBLE	{ L _ (ITprimdouble _) }
 
@@ -380,7 +378,7 @@ module 	:: { Located (HsModule RdrName) }
                           Nothing)) }
 
 maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
-        : moduleheader            { (fst $1, snd $1) }
+        : moduleheader            { $1 }
         | {- empty -}             { (emptyHaddockModInfo, Nothing) }
 
 missing_module_keyword :: { () }
@@ -1311,8 +1309,8 @@ exp10 :: { LHsExpr RdrName }
 
 scc_annot :: { Located FastString }
 	: '_scc_' STRING			{% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
-                                   (return $ LL $ getSTRING $2) }
-	| '{-# SCC' STRING '#-}'		{ LL $ getSTRING $2 }
+                                   ( do scc <- getSCC $2; return $ LL scc ) }
+	| '{-# SCC' STRING '#-}'		{% do scc <- getSCC $2; return $ LL scc }
 
 hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
 	: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
@@ -1441,7 +1439,7 @@ list :: { LHsExpr RdrName }
 	| texp '|' flattenedpquals	{ sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
 
 lexps :: { Located [LHsExpr RdrName] }
-	: lexps ',' texp 		{ LL ($3 : unLoc $1) }
+	: lexps ',' texp 		{ LL (((:) $! $3) $! unLoc $1) }
 	| texp ',' texp			{ LL [$3,$1] }
 
 -----------------------------------------------------------------------------
@@ -1756,9 +1754,9 @@ tyvarop : '`' tyvarid '`'	{ LL (unLoc $2) }
 tyvarid	:: { Located RdrName }
 	: VARID			{ L1 $! mkUnqual tvName (getVARID $1) }
 	| special_id		{ L1 $! mkUnqual tvName (unLoc $1) }
-	| 'unsafe' 		{ L1 $! mkUnqual tvName FSLIT("unsafe") }
-	| 'safe' 		{ L1 $! mkUnqual tvName FSLIT("safe") }
-	| 'threadsafe' 		{ L1 $! mkUnqual tvName FSLIT("threadsafe") }
+	| 'unsafe' 		{ L1 $! mkUnqual tvName (fsLit "unsafe") }
+	| 'safe' 		{ L1 $! mkUnqual tvName (fsLit "safe") }
+	| 'threadsafe' 		{ L1 $! mkUnqual tvName (fsLit "threadsafe") }
 
 tyvarsym :: { Located RdrName }
 -- Does not include "!", because that is used for strictness marks
@@ -1787,15 +1785,15 @@ qvarid :: { Located RdrName }
 
 varid :: { Located RdrName }
 	: varid_no_unsafe 	{ $1 }
-	| 'unsafe'		{ L1 $! mkUnqual varName FSLIT("unsafe") }
-	| 'safe'		{ L1 $! mkUnqual varName FSLIT("safe") }
-	| 'threadsafe'		{ L1 $! mkUnqual varName FSLIT("threadsafe") }
+	| 'unsafe'		{ L1 $! mkUnqual varName (fsLit "unsafe") }
+	| 'safe'		{ L1 $! mkUnqual varName (fsLit "safe") }
+	| 'threadsafe'		{ L1 $! mkUnqual varName (fsLit "threadsafe") }
 
 varid_no_unsafe :: { Located RdrName }
 	: VARID			{ L1 $! mkUnqual varName (getVARID $1) }
 	| special_id		{ L1 $! mkUnqual varName (unLoc $1) }
-	| 'forall'		{ L1 $! mkUnqual varName FSLIT("forall") }
-	| 'family'              { L1 $! mkUnqual varName FSLIT("family") }
+	| 'forall'		{ L1 $! mkUnqual varName (fsLit "forall") }
+	| 'family'              { L1 $! mkUnqual varName (fsLit "family") }
 
 qvarsym :: { Located RdrName }
 	: varsym		{ $1 }
@@ -1810,7 +1808,7 @@ qvarsym1 : QVARSYM		{ L1 $ mkQual varName (getQVARSYM $1) }
 
 varsym :: { Located RdrName }
 	: varsym_no_minus 	{ $1 }
-	| '-'			{ L1 $ mkUnqual varName FSLIT("-") }
+	| '-'			{ L1 $ mkUnqual varName (fsLit "-") }
 
 varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 	: VARSYM		{ L1 $ mkUnqual varName (getVARSYM $1) }
@@ -1823,19 +1821,19 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 -- depending on context 
 special_id :: { Located FastString }
 special_id
-	: 'as'			{ L1 FSLIT("as") }
-	| 'qualified'		{ L1 FSLIT("qualified") }
-	| 'hiding'		{ L1 FSLIT("hiding") }
-	| 'export'		{ L1 FSLIT("export") }
-	| 'label'		{ L1 FSLIT("label")  }
-	| 'dynamic'		{ L1 FSLIT("dynamic") }
-	| 'stdcall'             { L1 FSLIT("stdcall") }
-	| 'ccall'               { L1 FSLIT("ccall") }
+	: 'as'			{ L1 (fsLit "as") }
+	| 'qualified'		{ L1 (fsLit "qualified") }
+	| 'hiding'		{ L1 (fsLit "hiding") }
+	| 'export'		{ L1 (fsLit "export") }
+	| 'label'		{ L1 (fsLit "label")  }
+	| 'dynamic'		{ L1 (fsLit "dynamic") }
+	| 'stdcall'             { L1 (fsLit "stdcall") }
+	| 'ccall'               { L1 (fsLit "ccall") }
 
 special_sym :: { Located FastString }
-special_sym : '!'	{ L1 FSLIT("!") }
-	    | '.' 	{ L1 FSLIT(".") }
- 	    | '*' 	{ L1 FSLIT("*") }
+special_sym : '!'	{ L1 (fsLit "!") }
+	    | '.' 	{ L1 (fsLit ".") }
+ 	    | '*' 	{ L1 (fsLit "*") }
 
 -----------------------------------------------------------------------------
 -- Data constructors
@@ -1865,6 +1863,7 @@ literal :: { Located HsLit }
 	: CHAR 			{ L1 $ HsChar       $ getCHAR $1 }
 	| STRING 		{ L1 $ HsString     $ getSTRING $1 }
 	| PRIMINTEGER		{ L1 $ HsIntPrim    $ getPRIMINTEGER $1 }
+	| PRIMWORD   		{ L1 $ HsWordPrim    $ getPRIMWORD $1 }
 	| PRIMCHAR		{ L1 $ HsCharPrim   $ getPRIMCHAR $1 }
 	| PRIMSTRING		{ L1 $ HsStringPrim $ getPRIMSTRING $1 }
 	| PRIMFLOAT		{ L1 $ HsFloatPrim  $ getPRIMFLOAT $1 }
@@ -1958,6 +1957,7 @@ getRATIONAL	(L _ (ITrational x)) = x
 getPRIMCHAR	(L _ (ITprimchar   x)) = x
 getPRIMSTRING	(L _ (ITprimstring x)) = x
 getPRIMINTEGER	(L _ (ITprimint    x)) = x
+getPRIMWORD	(L _ (ITprimword x)) = x
 getPRIMFLOAT	(L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE	(L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
@@ -1969,6 +1969,14 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x
 getDOCNAMED (L _ (ITdocCommentNamed x)) = x
 getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
 
+getSCC :: Located Token -> P FastString
+getSCC lt = do let s = getSTRING lt
+                   err = "Spaces are not allowed in SCCs"
+               -- We probably actually want to be more restrictive than this
+               if ' ' `elem` unpackFS s
+                   then failSpanMsgP (getLoc lt) (text err)
+                   else return s
+
 -- Utilities for combining source spans
 comb2 :: Located a -> Located b -> SrcSpan
 comb2 a b = a `seq` b `seq` combineLocs a b