Skip to content

GitLab

GHC
GHC
Commit ed4f46f4 authored by andy's avatar andy
Browse files
Options

[project @ 2000-03-15 23:27:16 by andy] 

Adding in internal support for assert, that gives optional
assertion messages with file and line numbers.

Changing the default build style to stand alone.
Thinking: People building the combined system are likly to
be hackers already, so can make a one line change.
We should discuss this...
parent c1c65dca
Hide whitespace changes
Inline Side-by-side
Showing with 96 additions and 14 deletions
ghc/interpreter/compiler.c
View file @ ed4f46f4
......@@ -11,8 +11,8 @@
* included in the distribution.
*
* $RCSfile: compiler.c,v $
* $Revision: 1.22 $
* $Date: 2000/03/13 11:37:16 $
* $Revision: 1.23 $
* $Date: 2000/03/15 23:27:16 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -77,6 +77,7 @@ static Name local compileSelFunction ( Pair );
static List local addStgVar ( List,Pair );
static Name currentName; /* Top level name being processed */
static Int lineNumber = 0; /* previously discarded line number */
/* --------------------------------------------------------------------------
* Translation: Convert input expressions into a less complex language
......@@ -98,6 +99,9 @@ Cell e; {
case AP : fst(e) = translate(fst(e));
/* T [id <exp>] ==> T[<exp>]
* T [indirect <exp> ] ==> T[<exp>]
*/
if (fst(e)==nameId || fst(e)==nameInd)
return translate(snd(e));
if (isName(fst(e)) &&
......@@ -106,10 +110,23 @@ Cell e; {
return translate(snd(e));
snd(e) = translate(snd(e));
return e;
case NAME : if (e==nameOtherwise)
case NAME :
/* T [otherwise] ==> True
*/
if (e==nameOtherwise)
return nameTrue;
/* T [assert] ==> T[assertError "<location info>"]
*/
if (flagAssert && e==nameAssert) {
Cell str = errAssert(lineNumber);
return (ap(nameAssertError,str));
}
if (isCfun(e)) {
if (isName(name(e).defn))
return name(e).defn;
......@@ -247,7 +264,14 @@ Cell rhs; {
mapProc(transPair,snd(rhs));
return rhs;
default : return translate(snd(rhs)); /* discard line number */
default : {
Cell tmp;
Int prev = lineNumber;
lineNumber = intOf(fst(rhs));
tmp = translate(snd(rhs)); /* discard line number */
lineNumber = prev;
return tmp;
}
}
}
......@@ -1629,6 +1653,7 @@ Int what; {
case PREPREL :
case RESET : freeVars = NIL;
freeFuns = NIL;
lineNumber = 0;
freeBegin = mkOffset(0);
break;
......
ghc/interpreter/connect.h
View file @ ed4f46f4
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: connect.h,v $
* $Revision: 1.29 $
* $Date: 2000/03/14 14:34:47 $
* $Revision: 1.30 $
* $Date: 2000/03/15 23:27:16 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
......@@ -130,6 +130,18 @@ extern Name namePrimSeq;
extern Name nameMap;
extern Name nameMinus;
/* assertion and exceptions */
extern Name nameAssert;
extern Name nameAssertError;
extern Name nameTangleMessage;
extern Name nameIrrefutPatError;
extern Name nameNoMethodBindingError;
extern Name nameNonExhaustiveGuardsError;
extern Name namePatError;
extern Name nameRecSelError;
extern Name nameRecConError;
extern Name nameRecUpdError;
extern Class classMonad; /* Monads */
extern Class classEq; /* `standard' classes */
......@@ -302,6 +314,8 @@ extern Long numCells; /* number of cells allocated */
extern Int numGcs; /* number of garbage collections */
extern Bool broken; /* indicates interrupt received */
extern Bool preludeLoaded; /* TRUE => prelude has been loaded */
extern Bool flagAssert; /* TRUE => assert False <e> causes
an assertion failure */
extern Bool gcMessages; /* TRUE => print GC messages */
extern Bool literateScripts; /* TRUE => default lit scripts */
......
ghc/interpreter/errors.h
View file @ ed4f46f4
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: errors.h,v $
* $Revision: 1.6 $
* $Date: 2000/03/13 11:37:16 $
* $Revision: 1.7 $
* $Date: 2000/03/15 23:27:16 $
* ------------------------------------------------------------------------*/
extern Void internal ( String) HUGS_noreturn;
......@@ -41,6 +41,7 @@ extern Void fatal ( String) HUGS_noreturn;
extern Void errHead ( Int ); /* in main.c */
extern Void errFail ( Void) HUGS_noreturn;
extern Void errAbort ( Void );
extern Cell errAssert ( Int );
extern sigProto(breakHandler);
......
ghc/interpreter/hugs.c
View file @ ed4f46f4
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
* $Revision: 1.43 $
* $Date: 2000/03/14 14:34:47 $
* $Revision: 1.44 $
* $Date: 2000/03/15 23:27:16 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
......@@ -94,7 +94,6 @@ static Void local browse ( Void );
* Machine dependent code for Hugs interpreter:
* ------------------------------------------------------------------------*/
#include "machdep.c"
#ifdef WANT_TIMER
#include "timer.c"
......@@ -112,9 +111,11 @@ static Bool useDots = RISCOS; /* TRUE => use dots in progress */
static Bool quiet = FALSE; /* TRUE => don't show progress */
static Bool lastWasObject = FALSE;
Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
an assertion failure */
Bool preludeLoaded = FALSE;
Bool debugSC = FALSE;
Bool combined = TRUE;
Bool combined = FALSE;
typedef
struct {
......@@ -788,6 +789,7 @@ struct options toggle[] = { /* List of command line toggles */
{'k', 1, "Show kind errors in full", &kindExpert},
{'o', 0, "Allow overlapping instances", &allowOverlap},
{'S', 1, "Debug: show generated SC code", &debugSC},
{'a', 1, "Raise exception on assert failure", &flagAssert},
#if EXPLAIN_INSTANCE_RESOLUTION
{'x', 1, "Explain instance resolution", &showInstRes},
#endif
......@@ -2182,6 +2184,19 @@ static Void local failed() { /* Goal cannot be reached due to */
* Error handling:
* ------------------------------------------------------------------------*/
Cell errAssert(l) /* message to use when raising asserts, etc */
Int l; {
char tmp[100];
Cell str;
if (scriptFile) {
str = mkStr(findText(scriptFile));
} else {
str = mkStr(findText(""));
}
return (ap2(nameTangleMessage,str,mkInt(l)));
}
Void errHead(l) /* print start of error message */
Int l; {
failed(); /* failed to reach target ... */
......
ghc/interpreter/link.c
View file @ ed4f46f4
......@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
* $Revision: 1.51 $
* $Date: 2000/03/14 14:34:47 $
* $Revision: 1.52 $
* $Date: 2000/03/15 23:27:16 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
......@@ -132,6 +132,17 @@ Name nameFrom;
Name nameFromThenTo;
Name nameNegate;
Name nameAssert;
Name nameAssertError;
Name nameTangleMessage;
Name nameIrrefutPatError;
Name nameNoMethodBindingError;
Name nameNonExhaustiveGuardsError;
Name namePatError;
Name nameRecSelError;
Name nameRecConError;
Name nameRecUpdError;
/* these names are required before we've had a chance to do the right thing */
Name nameSel;
Name nameUnsafeUnpackCString;
......@@ -557,6 +568,7 @@ assert(nonNull(namePMFail));
/* implementTagToCon */
xyzzy(nameError, "hugsprimError");
typeStable = linkTycon("Stable");
typeRef = linkTycon("IORef");
// {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
......@@ -714,6 +726,21 @@ assert(nonNull(namePMFail));
pFun(nameError, "error");
pFun(nameUnpackString, "hugsprimUnpackString");
/* assertion and exception issues */
pFun(nameAssert, "assert");
pFun(nameAssertError, "assertError");
pFun(nameTangleMessage, "tangleMessager");
pFun(nameIrrefutPatError,
"irrefutPatError");
pFun(nameNoMethodBindingError,
"noMethodBindingError");
pFun(nameNonExhaustiveGuardsError,
"nonExhaustiveGuardsError");
pFun(namePatError, "patError");
pFun(nameRecSelError, "recSelError");
pFun(nameRecConError, "recConError");
pFun(nameRecUpdError, "recUpdError");
/* hooks for handwritten bytecode */
pFun(namePrimSeq, "primSeq");
pFun(namePrimCatch, "primCatch");
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment