From 4e5a383f739c312e3811b89d519a95a675182e58 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 25 Sep 2002 10:53:11 +0000
Subject: [PATCH] [project @ 2002-09-25 10:53:11 by simonpj] Fix assertion
 handling

---
 ghc/compiler/prelude/PrelNames.lhs |    6 +++--
 ghc/compiler/rename/RnExpr.lhs     |   43 +++++++++++++-----------------------
 2 files changed, 19 insertions(+), 30 deletions(-)

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index aa711d2..fd5e769 100644
--- 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
--- 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}
 
 %************************************************************************
-- 
1.7.10.4