From: andy Date: Tue, 23 Nov 1999 15:12:10 +0000 (+0000) Subject: [project @ 1999-11-23 15:12:04 by andy] X-Git-Tag: Approximately_9120_patches~5505 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=618348854155e48b3abb64809065601c586d0553;p=ghc-hetmet.git [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 . --- diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index bf79c88..cf99336 100644 --- 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 --- 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 @@ -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 --- 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 --- 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 --- 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 --- 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 --- 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 ()