[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 d9643ad..1c4914e 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -25,7 +25,7 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnEnv
-import CmdLineOpts     ( opt_GlasgowExts )
+import CmdLineOpts     ( opt_GlasgowExts, opt_IgnoreAsserts )
 import BasicTypes      ( Fixity(..), FixityDirection(..) )
 import PrelInfo                ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
                          ccallableClass_RDR, creturnableClass_RDR, 
@@ -36,7 +36,9 @@ import PrelInfo               ( numClass_RDR, fractionalClass_RDR, eqClass_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) ->
@@ -419,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
@@ -433,7 +435,7 @@ rnRbinds str rbinds
        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
@@ -484,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)
@@ -741,11 +743,30 @@ mkAssertExpr =
   newImportedGlobalFromRdrName assertErr_RDR   `thenRn` \ name ->
   addOccurrenceName name                               `thenRn_`
   getSrcLocRn                                          `thenRn` \ sloc ->
-  let
-   expr = HsApp (HsVar name)
+
+    -- 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
+
+    in
+    returnRn expr
+
 \end{code}
 
 %************************************************************************