[project @ 1999-04-27 17:33:49 by sof]

[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 6eaa5ea..1c4914e 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -25,18 +25,20 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnEnv
-import CmdLineOpts     ( opt_GlasgowExts )
-import BasicTypes      ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
+import CmdLineOpts     ( opt_GlasgowExts, opt_IgnoreAsserts )
+import BasicTypes      ( Fixity(..), FixityDirection(..) )
 import PrelInfo                ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
                          ccallableClass_RDR, creturnableClass_RDR, 
-                         monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+                         monadClass_RDR, enumClass_RDR, ordClass_RDR,
                          ratioDataCon_RDR, negate_RDR, assertErr_RDR,
                          ioDataCon_RDR
                        )
 import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
                          floatPrimTyCon, doublePrimTyCon
                        )
-import Name            ( nameUnique, isLocallyDefined, NamedThing(..) )
+import Name            ( nameUnique, isLocallyDefined, NamedThing(..)
+                        , mkSysLocalName, nameSrcLoc
+                       )
 import NameSet
 import UniqFM          ( isNullUFM )
 import FiniteMap       ( elemFM )
@@ -172,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
        -- Note that we do a single bindLocalsRn for all the
        -- matches together, so that we spot the repeated variable in
        --      f x x = 1
-    bindLocalsFVRn "pattern" (collectPatsBinders pats)         $ \ new_binders ->
+    bindLocalsFVRn "a pattern" (collectPatsBinders pats) $ \ new_binders ->
 
     mapAndUnzipRn rnPat pats           `thenRn` \ (pats', pat_fvs_s) ->
     rnGRHSs grhss                      `thenRn` \ (grhss', grhss_fvs) ->
@@ -256,12 +258,7 @@ grubby_seqNameSet ns result | isNullUFM ns = result
                            | otherwise    = result
 \end{code}
 
-Variables. We look up the variable and return the resulting name.  The
-interesting question is what the free-variable set should be.  We
-don't want to return imported or prelude things as free vars.  So we
-look at the Name returned from the lookup, and make it part of the
-free-var set iff if it's a LocallyDefined Name.
-\end{itemize}
+Variables. We look up the variable and return the resulting name. 
 
 \begin{code}
 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
@@ -274,13 +271,11 @@ rnExpr (HsVar v)
        returnRn (expr, emptyUniqSet)
     else
         -- The normal case
-       returnRn (HsVar name, if isLocallyDefined name
-                            then unitNameSet name
-                            else emptyUniqSet)
+       returnRn (HsVar name, unitFV name)
 
 rnExpr (HsLit lit) 
   = litOccurrence lit          `thenRn_`
-    returnRn (HsLit lit, emptyNameSet)
+    returnRn (HsLit lit, emptyFVs)
 
 rnExpr (HsLam match)
   = rnMatch match      `thenRn` \ (match', fvMatch) ->
@@ -355,7 +350,7 @@ rnExpr (HsLet binds expr)
 
 rnExpr (HsDo do_or_lc stmts src_loc)
   = pushSrcLocRn src_loc $
-    lookupImplicitOccRn monadZeroClass_RDR     `thenRn_`       -- Forces Monad to come too
+    lookupImplicitOccRn monadClass_RDR         `thenRn_`
     rnStmts rnExpr stmts                       `thenRn` \ (stmts', fvs) ->
     returnRn (HsDo do_or_lc stmts' src_loc, fvs)
 
@@ -426,7 +421,7 @@ rnExpr (ArithSeqIn seq)
 
 \begin{code}
 rnRbinds str rbinds 
-  = mapRn field_dup_err dup_fields     `thenRn_`
+  = mapRn_ field_dup_err dup_fields    `thenRn_`
     mapAndUnzipRn rn_rbind rbinds      `thenRn` \ (rbinds', fvRbind_s) ->
     returnRn (rbinds', plusFVs fvRbind_s)
   where
@@ -437,10 +432,10 @@ rnRbinds str rbinds
     rn_rbind (field, expr, pun)
       = lookupGlobalOccRn field        `thenRn` \ fieldname ->
        rnExpr expr             `thenRn` \ (expr', fvExpr) ->
-       returnRn ((fieldname, expr', pun), fvExpr)
+       returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
 
 rnRpats rpats
-  = mapRn field_dup_err dup_fields     `thenRn_`
+  = mapRn_ field_dup_err dup_fields    `thenRn_`
     mapAndUnzipRn rn_rpat rpats                `thenRn` \ (rpats', fvs_s) ->
     returnRn (rpats', plusFVs fvs_s)
   where
@@ -451,7 +446,7 @@ rnRpats rpats
     rn_rpat (field, pat, pun)
       = lookupGlobalOccRn field        `thenRn` \ fieldname ->
        rnPat pat               `thenRn` \ (pat', fvs) ->
-       returnRn ((fieldname, pat', pun), fvs)
+       returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
 \end{code}
 
 %************************************************************************
@@ -476,7 +471,7 @@ rnStmts :: RnExprTy s
        -> RnMS s ([RenamedStmt], FreeVars)
 
 rnStmts rn_expr []
-  = returnRn ([], emptyNameSet)
+  = returnRn ([], emptyFVs)
 
 rnStmts rn_expr (stmt:stmts)
   = rnStmt rn_expr stmt                                $ \ stmt' ->
@@ -491,7 +486,7 @@ rnStmt :: RnExprTy s -> RdrNameStmt
 rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
   = pushSrcLocRn src_loc $
     rn_expr expr                                       `thenRn` \ (expr', fv_expr) ->
-    bindLocalsFVRn "pattern in do binding" binders     $ \ new_binders ->
+    bindLocalsFVRn "a pattern in do binding" binders   $ \ new_binders ->
     rnPat pat                                          `thenRn` \ (pat', fv_pat) ->
     thing_inside (BindStmt pat' expr' src_loc)         `thenRn` \ (result, fvs) -> 
     returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
@@ -745,18 +740,33 @@ litOccurrence (HsLitLit _)
 \begin{code}
 mkAssertExpr :: RnMS s RenamedHsExpr
 mkAssertExpr =
-  newImportedGlobalName mod occ HiFile `thenRn` \ name ->
-  addOccurrenceName name              `thenRn_`
-  getSrcLocRn                          `thenRn` \ sloc ->
-  let
-   expr = HsApp (HsVar name)
+  newImportedGlobalFromRdrName assertErr_RDR   `thenRn` \ name ->
+  addOccurrenceName name                               `thenRn_`
+  getSrcLocRn                                          `thenRn` \ sloc ->
+
+    -- if we're ignoring asserts, return (\ _ e -> e)
+    -- if not, return (assertError "src-loc")
+
+  if opt_IgnoreAsserts then
+    getUniqRn                          `thenRn` \ uniq ->
+    let
+     vname = mkSysLocalName uniq SLIT("v")
+     expr  = HsLam ignorePredMatch
+     loc   = nameSrcLoc vname
+     ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing 
+                             (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
+                                   EmptyBinds Nothing)
+    in
+    returnRn expr
+  else
+    let
+     expr = 
+          HsApp (HsVar name)
                (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
-  in
-  returnRn expr
 
-  where
-   mod = rdrNameModule assertErr_RDR
-   occ = rdrNameOcc assertErr_RDR
+    in
+    returnRn expr
+
 \end{code}
 
 %************************************************************************