From: simonpj <unknown>
Date: Wed, 9 May 2001 13:05:07 +0000 (+0000)
Subject: [project @ 2001-05-09 13:05:07 by simonpj]
X-Git-Tag: Approximately_9120_patches~1966
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=43f425a47a7dc19bd4284112548ab51d230a0482;p=ghc-hetmet.git

[project @ 2001-05-09 13:05:07 by simonpj]
Fix yesterdays bogons in parsing do-expressions; MERGE IN BRANCH
---

diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 229b15f..5c4e6a4 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -21,7 +21,7 @@ module ParseUtil (
 	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
 	, checkPattern		-- HsExp -> P HsPat
 	, checkPatterns		-- SrcLoc -> [HsExp] -> P [HsPat]
-	-- , checkExpr		-- HsExp -> P HsExp
+	, checkDo		-- [HsStmt] -> P [HsStmt]
 	, checkValDef		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 	, checkValSig		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
  ) where
@@ -100,13 +100,6 @@ callConvFM = listToUFM $
 --	("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,6 +160,19 @@ 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,
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index b584fe8..ca4fafb 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.62 2001/05/08 16:25:30 simonpj Exp $
+$Id: Parser.y,v 1.63 2001/05/09 13:05:07 simonpj Exp $
 
 Haskell grammar.
 
@@ -697,7 +697,8 @@ exp10 :: { RdrNameHsExpr }
 	| 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 }
    	| 'case' srcloc exp 'of' altslist	{ HsCase $3 $5 $2 }
 	| '-' fexp				{ mkHsNegApp $2 }
-  	| srcloc 'do' stmtlist			{ HsDo DoExpr $3 $1 }
+  	| srcloc 'do' stmtlist			{% checkDo $3  `thenP` \ stmts ->
+						   returnP (HsDo DoExpr stmts $1) }
 
 	| '_ccall_'    ccallid aexps0		{ HsCCall $2 $3 False False cbot }
 	| '_ccall_GC_' ccallid aexps0		{ HsCCall $2 $3 True  False cbot }
@@ -837,13 +838,22 @@ stmtlist :: { [RdrNameStmt] }
 	: '{'            	stmts '}'	{ $2 }
 	|     layout_on_for_do  stmts close	{ $2 }
 
+--	do { ;; s ; s ; ; s ;; }
+-- The last Stmt should be a ResultStmt, but that's hard to enforce
+-- here, because we need too much lookahead if we see do { e ; }
+-- So we use ExprStmts throughout, and switch the last one over
+-- in ParseUtils.checkDo instead
 stmts :: { [RdrNameStmt] }
+	: stmt stmts_help		{ $1 : $2 }
+	| ';' stmts			{ $2 }
+	| {- empty -}			{ [] }
+
+stmts_help :: { [RdrNameStmt] }
 	: ';' stmts			{ $2 }
-	| stmt ';' stmts		{ $1 : $3 }
-	| srcloc exp			{ [ResultStmt $2 $1] }
+	| {- empty -}			{ [] }
 
--- for typing stmts at the GHCi prompt, where the input may consist of
--- just comments.
+-- For typing stmts at the GHCi prompt, where 
+-- the input may consist of just comments.
 maybe_stmt :: { Maybe RdrNameStmt }
 	: stmt				{ Just $1 }
 	| {- nothing -}			{ Nothing }