[project @ 1999-11-23 15:12:04 by andy]

Changing the top level evaluator so it runs things
of type IO a, not just IO <monomorphic-thing>.

diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h
index bf79c88..cf99336 100644 (file)
--- a/ghc/interpreter/connect.h
+++ b/ghc/interpreter/connect.h
@@ -8,8 +8,8 @@
  * included in the distribution.
  *
  * $RCSfile: connect.h,v $
- * $Revision: 1.16 $
- * $Date: 1999/11/17 16:57:38 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/23 15:12:10 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
@@ -105,6 +105,7 @@ extern String hugsEdit;                 /* String for editor command       */
 extern String hugsPath;                 /* String for file search path     */
 extern String projectPath;              /* String for project search path  */
 
+extern Type  typeProgIO;               /* For the IO monad, IO a          */
 extern Type  typeArrow;                 /* Builtin type constructors       */
 extern Type  typeList;
 extern Type  typeUnit;

diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 80c4921..85844cc 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.22 $
- * $Date: 1999/11/23 09:59:38 $
+ * $Revision: 1.23 $
+ * $Date: 1999/11/23 15:12:09 $
  * ------------------------------------------------------------------------*/
 
 #include <setjmp.h>
@@ -234,7 +234,9 @@ char *argv[]; {
        main after loading scripts.  Useful for running the nofib suite.    */
     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
        autoMain = TRUE;
-       hugsEnableOutput(0);
+       if (strcmp(argv[1],"-Q") == 0) {
+        hugsEnableOutput(0);
+       }
     }
 
     Printf("__   __ __  __  ____   ___      _________________________________________\n");
@@ -1342,7 +1344,7 @@ static Void local evaluator() {        /* evaluate expr and print value    */
 #endif
 
 #if 1
-    if (typeMatches(type,ap(typeIO,typeUnit))) {
+    if (isProgType(ks,bd)) {
         inputExpr = ap(nameRunIO,inputExpr);
         evalExp();
         Putchar('\n');

diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 3ada1bc..69c9db6 100644 (file)
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -1835,13 +1835,13 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
 
 -- used when Hugs invokes top level function
-primRunIO_hugs_toplevel :: IO () -> ()
+primRunIO_hugs_toplevel :: IO a -> ()
 primRunIO_hugs_toplevel m
    = protect 5 (fst (unST composite_action realWorld))
      where
         composite_action
            = do writeIORef prelCleanupAfterRunAction Nothing
-                m
+                m 
                 cleanup_handles <- readIORef prelCleanupAfterRunAction
                 case cleanup_handles of
                    Nothing -> return ()

diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index 4df6710..22967fb 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.16 $
- * $Date: 1999/11/22 16:00:22 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/23 15:12:08 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -209,6 +209,7 @@ Cell  predFractional;            /* Fractional (mkOffset(0))        */
 Cell  predIntegral;              /* Integral (mkOffset(0))          */
 Kind  starToStar;                /* Type -> Type                    */
 Cell  predMonad;                 /* Monad (mkOffset(0))             */
+Type  typeProgIO;                /* IO a                            */
 
 /* --------------------------------------------------------------------------
  * 
@@ -401,6 +402,7 @@ static Void mkTypes ( void )
         predFractional = ap(classFractional,aVar);
         predIntegral   = ap(classIntegral,aVar);
         predMonad      = ap(classMonad,aVar);
+       typeProgIO     = ap(typeIO,aVar);
 }
 
 Void linkPreludeCM(void) {              /* Hook to cfuns and mfuns in      */

diff --git a/ghc/interpreter/subst.c b/ghc/interpreter/subst.c
index 41c32a7..338f95b 100644 (file)
--- a/ghc/interpreter/subst.c
+++ b/ghc/interpreter/subst.c
@@ -10,8 +10,8 @@
  * included in the distribution.
  *
  * $RCSfile: subst.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/11/17 16:57:49 $
+ * $Revision: 1.9 $
+ * $Date: 1999/11/23 15:12:07 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -1259,7 +1259,21 @@ Bool typeMatches(type,mt)               /* test if type matches monotype mt*/
     return result;
 }
 
-
+Bool isProgType(ks,type)               /* Test if type is of the form     */
+List ks;                               /* IO t for some t.                */
+Type type; {
+    Bool result;
+    Int  alpha;
+    Int  beta;
+    emptySubstitution();
+    alpha  = newKindedVars(ks);
+    beta   = newTyvars(1);
+    bindOnlyAbove(beta);
+    result = unify(type,alpha,typeProgIO,beta);
+    unrestrictBind();
+    emptySubstitution();
+    return result;
+}
 
 /* --------------------------------------------------------------------------
  * Matching predicates:

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index 726c14f..cd4529f 100644 (file)
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: type.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/19 15:42:08 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/23 15:12:06 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -2748,6 +2748,7 @@ Int what; {
                        mark(predIntegral);
                        mark(starToStar);
                        mark(predMonad);
+                      mark(typeProgIO);
                        break;
 
         case INSTALL : typeChecker(RESET);

diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 3ada1bc..69c9db6 100644 (file)
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -1835,13 +1835,13 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
 prelCleanupAfterRunAction = primRunST (newIORef Nothing)
 
 -- used when Hugs invokes top level function
-primRunIO_hugs_toplevel :: IO () -> ()
+primRunIO_hugs_toplevel :: IO a -> ()
 primRunIO_hugs_toplevel m
    = protect 5 (fst (unST composite_action realWorld))
      where
         composite_action
            = do writeIORef prelCleanupAfterRunAction Nothing
-                m
+                m 
                 cleanup_handles <- readIORef prelCleanupAfterRunAction
                 case cleanup_handles of
                    Nothing -> return ()