From ed4f46f41c6293db4536705b4db3024991413f3f Mon Sep 17 00:00:00 2001 From: andy Date: Wed, 15 Mar 2000 23:27:16 +0000 Subject: [PATCH] [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... --- ghc/interpreter/compiler.c | 33 +++++++++++++++++++++++++++++---- ghc/interpreter/connect.h | 18 ++++++++++++++++-- ghc/interpreter/errors.h | 5 +++-- ghc/interpreter/hugs.c | 23 +++++++++++++++++++---- ghc/interpreter/link.c | 31 +++++++++++++++++++++++++++++-- 5 files changed, 96 insertions(+), 14 deletions(-) diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 5260f20..53f3708 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -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 ] ==> T[] + * T [indirect ] ==> T[] + */ 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 ""] + */ + 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; diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 89552c6..cbcff7b 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -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 causes + an assertion failure */ extern Bool gcMessages; /* TRUE => print GC messages */ extern Bool literateScripts; /* TRUE => default lit scripts */ diff --git a/ghc/interpreter/errors.h b/ghc/interpreter/errors.h index 8c4856b..512853a 100644 --- a/ghc/interpreter/errors.h +++ b/ghc/interpreter/errors.h @@ -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); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 155a391..8634d41 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -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 @@ -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 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 ... */ diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 58f3956..2f304d9 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -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"); -- 1.7.10.4