[project @ 2002-09-25 10:53:11 by simonpj]

Fix assertion handling

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index aa711d2..fd5e769 100644 (file)
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -282,7 +282,7 @@ knownKeyNames
        -- Others
        unsafeCoerceName, otherwiseIdName, 
        plusIntegerName, timesIntegerName,
-       eqStringName, assertName, runSTRepName,
+       eqStringName, assertName, assertErrorName, runSTRepName,
        printName, splitName, fstName, sndName,
        errorName,
 
@@ -611,7 +611,7 @@ augmentName   = varQual pREL_BASE_Name FSLIT("augment")   augmentIdKey
 appendName       = varQual pREL_BASE_Name FSLIT("++")        appendIdKey
 andName                  = varQual pREL_BASE_Name FSLIT("&&")        andIdKey
 orName           = varQual pREL_BASE_Name FSLIT("||")        orIdKey
-assertName        = varQual pREL_BASE_Name FSLIT("assert")   assertIdKey
+assertName        = varQual pREL_BASE_Name FSLIT("assert")    assertIdKey
 lazyIdName       = wVarQual pREL_BASE_Name FSLIT("lazy")     lazyIdKey
 
 -- PrelTup
@@ -791,6 +791,7 @@ newStablePtrName      = varQual  pREL_STABLE_Name FSLIT("newStablePtr") newStabl
 
 -- Error module
 errorName               = wVarQual pREL_ERR_Name FSLIT("error")                errorIdKey
+assertErrorName                 = wVarQual pREL_ERR_Name FSLIT("assertError")          assertErrorIdKey
 recSelErrorName                 = wVarQual pREL_ERR_Name FSLIT("recSelError")          recSelErrorIdKey
 runtimeErrorName        = wVarQual pREL_ERR_Name FSLIT("runtimeError")         runtimeErrorIdKey
 irrefutPatErrorName     = wVarQual pREL_ERR_Name FSLIT("irrefutPatError")      irrefutPatErrorIdKey
@@ -1091,6 +1092,7 @@ andIdKey                = mkPreludeMiscIdUnique 57
 orIdKey                              = mkPreludeMiscIdUnique 58
 thenIOIdKey                  = mkPreludeMiscIdUnique 59
 lazyIdKey                    = mkPreludeMiscIdUnique 60
+assertErrorIdKey             = mkPreludeMiscIdUnique 61
 
 -- Parallel array functions
 nullPIdKey                   = mkPreludeMiscIdUnique 80

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index a4d6a35..bed32e3 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -37,7 +37,7 @@ import PrelNames      ( hasKey, assertIdKey,
                          ioDataConName, plusIntegerName, timesIntegerName,
                          replicatePName, mapPName, filterPName,
                          crossPName, zipPName, lengthPName, indexPName, toPName,
-                         enumFromToPName, enumFromThenToPName, assertName,
+                         enumFromToPName, enumFromThenToPName, assertErrorName,
                          fromIntegerName, fromRationalName, minusName, negateName,
                          qTyConName, monadNames )
 import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
@@ -292,11 +292,13 @@ rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
 
 rnExpr (HsVar v)
   = lookupOccRn v      `thenM` \ name ->
-    if name `hasKey` assertIdKey then
-       -- We expand it to (GHCerr.assert__ location)
-        mkAssertExpr
+    if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
+       -- We expand it to (GHC.Err.assertError location_string)
+        mkAssertErrorExpr
     else
-        -- The normal case
+        -- The normal case.  Even if the Id was 'assert', if we are 
+       -- ignoring assertions we leave it as GHC.Base.assert; 
+       -- this function just ignores its first arg.
        returnM (HsVar name, unitFV name)
 
 rnExpr (HsIPVar v)
@@ -930,30 +932,15 @@ rnOverLit (HsFractional i _)
 %************************************************************************
 
 \begin{code}
-mkAssertExpr :: RnM (RenamedHsExpr, FreeVars)
-mkAssertExpr
+mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
+-- Return an expression for (assertError "Foo.hs:27")
+mkAssertErrorExpr
   = getSrcLocM                         `thenM` \ sloc ->
-
-    -- if we're ignoring asserts, return (\ _ e -> e)
-    -- if not, return (assertError "src-loc")
-
-    if opt_IgnoreAsserts then
-      newUnique                                `thenM` \ uniq ->
-      let
-       vname = mkSystemName uniq FSLIT("v")
-       expr  = HsLam ignorePredMatch
-       loc   = nameSrcLoc vname
-       ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname] 
-                                      (HsVar vname) placeHolderType loc
-      in
-      returnM (expr, emptyFVs)
-    else
-      let
-        expr = 
-          HsApp (HsVar assertName)
-               (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))))
-      in
-      returnM (expr, unitFV assertName)
+    let
+       expr = HsApp (HsVar assertErrorName) (HsLit msg)
+       msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
+    in
+    returnM (expr, unitFV assertErrorName)
 \end{code}
 
 %************************************************************************