From db85bf1cc51d2e428175ccf2f3608014e9459ba8 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Tue, 30 Mar 1999 11:26:24 +0000
Subject: [PATCH] [project @ 1999-03-30 11:26:18 by sof] New compiler option
-fignore-asserts: Causes
(PrelGHC.assert pred expr)
to be rewritten to (expr).
---
ghc/compiler/main/CmdLineOpts.lhs | 2 ++
ghc/compiler/rename/RnExpr.lhs | 33 ++++++++++++++++++++-----
ghc/compiler/rename/RnMonad.lhs | 9 +++++++
ghc/docs/users_guide/glasgow_exts.vsgml | 16 +++++++-----
ghc/driver/ghc.lprl | 1 +
5 files changed, 49 insertions(+), 12 deletions(-)
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 821882c2c30a..08aa38feba7a 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -60,6 +60,7 @@ module CmdLineOpts (
opt_HiMap,
opt_HiVersion,
opt_IgnoreIfacePragmas,
+ opt_IgnoreAsserts,
opt_IrrefutableTuples,
opt_LiberateCaseThreshold,
opt_MaxContextReductionDepth,
@@ -328,6 +329,7 @@ opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
opt_HiVersion = lookup_def_int "-fhi-version=" 0 -- what version we're compiling.
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
+opt_IgnoreAsserts = lookUp SLIT("-fignore-asserts")
opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_MultiParamClasses = opt_GlasgowExts
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index b990ab716d69..16f9da477bb5 100644
--- 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 )
@@ -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}
%************************************************************************
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 456ce0838a99..1d3578a1d2a3 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -705,6 +705,15 @@ newInstUniq key (RnDown {rn_ns = names_var}) l_down
in
writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
returnSST uniq
+
+getUniqRn :: RnM s d Unique
+getUniqRn (RnDown {rn_ns = names_var}) l_down
+ = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
+ let
+ (us1,us') = splitUniqSupply us
+ in
+ writeMutVarSST names_var (us', mapInst, cache) `thenSST_`
+ returnSST (uniqFromSupply us1)
\end{code}
================ Occurrences =====================
diff --git a/ghc/docs/users_guide/glasgow_exts.vsgml b/ghc/docs/users_guide/glasgow_exts.vsgml
index 07f204913f8b..9d0afcdfcf19 100644
--- a/ghc/docs/users_guide/glasgow_exts.vsgml
+++ b/ghc/docs/users_guide/glasgow_exts.vsgml
@@ -1,5 +1,5 @@
%
-% $Id: glasgow_exts.vsgml,v 1.7 1999/03/26 19:50:31 sof Exp $
+% $Id: glasgow_exts.vsgml,v 1.8 1999/03/30 11:26:24 sof Exp $
%
% GHC Language Extensions.
%
@@ -1493,8 +1493,8 @@ stands, unless there are convincing reasons to change it.
<label id="sec:assertions">
<p>
-If you want to use assertions in your standard Haskell code, you
-could define something like the following:
+If you want to make use of assertions in your standard Haskell code, you
+could define a function like the following:
<tscreen><verb>
assert :: Bool -> a -> a
@@ -1503,7 +1503,7 @@ assert _ x = x
</verb></tscreen>
which works, but gives you back a less than useful error message --
-an assertion failed, but which?
+an assertion failed, but which and where?
One way out is to define an extended <tt/assert/ function which also
takes a descriptive string to include in the error message and
@@ -1522,13 +1522,17 @@ Ghc will rewrite this to also include the source location where the
assertion was made,
<tscreen><verb>
-assert pred val ==> assertError "Main.hs,15" pred val
+assert pred val ==> assertError "Main.hs|15" pred val
</verb></tscreen>
The rewrite is only performed by the compiler when applications of
<tt>Exception.assert</tt> are spotted, so you can still define and use
your own versions of <tt/assert/, should you so wish. If not, import
-<tt/Exception/ to use <tt/assert/ in your code.
+<tt/Exception/ to make use <tt/assert/ in your code.
+
+To have the compiler ignore uses of assert, use the compiler option
+@-fignore-asserts@. <nidx>-fignore-asserts option</nidx> That is,
+expressions of the form @assert pred e@ will be rewritten to @e@.
Assertion failures can be caught, see the documentation for the
Hugs/GHC Exception library for information of how.
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index abcef324a301..10415f278d72 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -3055,6 +3055,7 @@ arg: while($_ = $Args[0]) {
/^-keep-s-files?-too$/ && do { $Keep_s_file_too = 1; next arg; };
/^-fignore-interface-pragmas$/ && do { push(@HsC_flags, $_); next arg; };
+ /^-fignore-asserts$/ && do { push(@HsC_flags, $_); next arg; };
/^-fno-implicit-prelude$/ && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; };
--
GitLab