X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=73358bf0b35e8bde7fa06d3d81e37ef15e8170c1;hb=265be40ffb10e9c1713479bb2b89a4bfa699c3a6;hp=e444450658dfa64ed99f3b617bd3bd330843ea25;hpb=b5f00004d9ac04dee3d36a72374e9712fbc87a13;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index e444450..73358bf 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -12,7 +12,7 @@ module ParseUtil (
 	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
 	, groupBindings
 	
-	, mkExtName             -- Maybe ExtName -> RdrName -> ExtName
+	, mkExtName             -- RdrName -> ExtName
 
 	, checkPrec 		-- String -> P String
 	, checkContext		-- HsType -> P HsContext
@@ -20,8 +20,8 @@ module ParseUtil (
 	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
 	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
 	, checkPattern		-- HsExp -> P HsPat
-	, checkPatterns		-- [HsExp] -> P [HsPat]
-	-- , checkExpr		-- HsExp -> P HsExp
+	, checkPatterns		-- SrcLoc -> [HsExp] -> P [HsPat]
+	, checkDo		-- [HsStmt] -> P [HsStmt]
 	, checkValDef		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	, checkValSig		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  ) where
@@ -38,11 +38,10 @@ import RdrHsSyn		( RdrBinding(..),
 			)
 import RdrName
 import PrelNames	( unitTyCon_RDR )
-import CallConv
 import OccName  	( dataName, varName, tcClsName,
 			  occNameSpace, setOccNameSpace, occNameUserString )
+import CStrings		( CLabelString )
 import FastString	( unpackFS )
-import UniqFM		( UniqFM, listToUFM, lookupUFM )
 import Outputable
 
 -----------------------------------------------------------------------------
@@ -68,7 +67,7 @@ mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDeta
 mkVanillaCon ty tys
  = split ty tys
  where
-   split (HsAppTy t u)  ts = split t (Unbanged u : ts)
+   split (HsAppTy t u)  ts = split t (unbangedType u : ts)
    split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
 			     returnP (data_con, VanillaCon ts)
    split _		 _ = parseError "Illegal data/newtype declaration"
@@ -91,22 +90,6 @@ tyConToDataCon tc
 ----------------------------------------------------------------------------
 -- Various Syntactic Checks
 
-callConvFM :: UniqFM CallConv
-callConvFM = listToUFM $
-      map (\ (x,y) -> (_PK_ x,y))
-     [  ("stdcall",  stdCallConv),
-	("ccall",    cCallConv)
---	("pascal",   pascalCallConv),
---	("fastcall", fastCallConv)
-     ]
-
-checkCallConv :: FAST_STRING -> P CallConv
-checkCallConv s = 
-  case lookupUFM callConvFM s of
-	Nothing -> parseError ("unknown calling convention: `"
-				 ++ unpackFS s ++ "'")
-	Just conv -> returnP conv
-
 checkInstType :: RdrNameHsType -> P RdrNameHsType
 checkInstType t 
   = case t of
@@ -167,16 +150,29 @@ checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) []
 checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"
 
 ---------------------------------------------------------------------------
+-- Checking statements in a do-expression
+-- 	We parse   do { e1 ; e2 ; }
+-- 	as [ExprStmt e1, ExprStmt e2]
+-- checkDo (a) checks that the last thing is an ExprStmt
+--	   (b) transforms it to a ResultStmt
+
+checkDo []	       = parseError "Empty 'do' construct"
+checkDo [ExprStmt e l] = returnP [ResultStmt e l]
+checkDo [s] 	       = parseError "The last statment in a 'do' construct must be an expression"
+checkDo (s:ss)	       = checkDo ss	`thenP` \ ss' ->
+			 returnP (s:ss')
+
+---------------------------------------------------------------------------
 -- Checking Patterns.
 
 -- We parse patterns as expressions and check for valid patterns below,
 -- converting the expression into a pattern at the same time.
 
-checkPattern :: RdrNameHsExpr -> P RdrNamePat
-checkPattern e = checkPat e []
+checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
+checkPattern loc e = setSrcLocP loc (checkPat e [])
 
-checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat]
-checkPatterns es = mapP checkPattern es
+checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
+checkPatterns loc es = mapP (checkPattern loc) es
 
 checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
 checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
@@ -249,11 +245,11 @@ checkValDef
 checkValDef lhs opt_sig grhss loc
  = case isFunLhs lhs [] of
 	   Just (f,inf,es) -> 
-		checkPatterns es `thenP` \ps ->
+		checkPatterns loc es `thenP` \ps ->
 		returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
 
            Nothing ->
-		checkPattern lhs `thenP` \lhs ->
+		checkPattern loc lhs `thenP` \lhs ->
 		returnP (RdrValBinding (PatMonoBind lhs grhss loc))
 
 checkValSig
@@ -275,7 +271,7 @@ isFunLhs (OpApp l (HsVar op) fix r) es  | not (isRdrDataCon op)
 				= case isFunLhs l es of
 				    Just (op', True, j : k : es') ->
 				      Just (op', True, j : OpApp k (HsVar op) fix r : es')
-				    Nothing -> Nothing
+				    _ -> Nothing
 isFunLhs (HsVar f) es | not (isRdrDataCon f)
 			 	= Just (f,False,es)
 isFunLhs (HsApp f e) es 	= isFunLhs f (e:es)
@@ -308,10 +304,8 @@ mkRecConstrOrUpdate _ _
 -- want z-encoding (e.g. names with z's in them shouldn't be doubled)
 -- (This is why we use occNameUserString.)
 
-mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
-				  Nothing
-mkExtName (Just x) _    = x
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
 
 -----------------------------------------------------------------------------
 -- group function bindings into equation groups