[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...

diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 5260f20..53f3708 100644 (file)
--- 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 <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;
 

diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h
index 89552c6..cbcff7b 100644 (file)
--- 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 <e> 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 (file)
--- 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 (file)
--- 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 <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 ...       */

diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index 58f3956..2f304d9 100644 (file)
--- 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");