[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 (file)
--- 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 (file)
--- 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 }