From 9df21476c4963a6ec4de6401a6e7275ba632f4bd Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 10 Jan 2000 16:23:33 +0000 Subject: [PATCH] [project @ 2000-01-10 16:23:32 by sewardj] --- ghc/interpreter/lib/Prelude.hs | 36 +++++++++++++------------- ghc/interpreter/link.c | 56 ++++++++++++++++++++++++++-------------- ghc/interpreter/storage.c | 27 +++++++++++++++++-- ghc/lib/hugs/Prelude.hs | 36 +++++++++++++------------- 4 files changed, 98 insertions(+), 57 deletions(-) diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs index 8a1e04d..ce05049 100644 --- a/ghc/interpreter/lib/Prelude.hs +++ b/ghc/interpreter/lib/Prelude.hs @@ -1548,11 +1548,11 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, primCompAux :: Ord a => a -> a -> Ordering -> Ordering primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT -primPmInt :: Num a => Int -> a -> Bool -primPmInt n x = fromInt n == x +hugsprimPmInt :: Num a => Int -> a -> Bool +hugsprimPmInt n x = fromInt n == x -primPmInteger :: Num a => Integer -> a -> Bool -primPmInteger n x = fromInteger n == x +hugsprimPmInteger :: Num a => Integer -> a -> Bool +hugsprimPmInteger n x = fromInteger n == x primPmDouble :: Fractional a => Double -> a -> Bool primPmDouble n x = fromDouble n == x @@ -1562,28 +1562,28 @@ primPmFail :: a primPmFail = error "Pattern Match Failure" -- used in desugaring Foreign functions -primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a -primMkIO = ST +hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a +hugsprimMkIO = ST -primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr -primCreateAdjThunk fun typestr callconv +hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +hugsprimCreateAdjThunk fun typestr callconv = do sp <- makeStablePtr fun p <- copy_String_to_cstring typestr -- is never freed a <- primCreateAdjThunkARCH sp p callconv return a -- The following primitives are only needed if (n+k) patterns are enabled: -primPmSub :: Integral a => Int -> a -> a -primPmSub n x = x - fromInt n +hugsprimPmSub :: Integral a => Int -> a -> a +hugsprimPmSub n x = x - fromInt n -primPmFromInteger :: Integral a => Integer -> a -primPmFromInteger = fromIntegral +hugsprimPmFromInteger :: Integral a => Integer -> a +hugsprimPmFromInteger = fromIntegral -primPmSubtract :: Integral a => a -> a -> a -primPmSubtract x y = x - y +hugsprimPmSubtract :: Integral a => a -> a -> a +hugsprimPmSubtract x y = x - y -primPmLe :: Integral a => a -> a -> Bool -primPmLe x y = x <= y +hugsprimPmLe :: Integral a => a -> a -> Bool +hugsprimPmLe x y = x <= y -- Unpack strings generated by the Hugs code generator. -- Strings can contain \0 provided they're coded right. @@ -1842,8 +1842,8 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ())) prelCleanupAfterRunAction = primRunST (newIORef Nothing) -- used when Hugs invokes top level function -primRunIO_hugs_toplevel :: IO a -> () -primRunIO_hugs_toplevel m +hugsprimRunIO_toplevel :: IO a -> () +hugsprimRunIO_toplevel m = protect 5 (fst (unST composite_action realWorld)) where composite_action diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 74186f3..8db6b70 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.27 $ - * $Date: 2000/01/07 17:49:29 $ + * $Revision: 1.28 $ + * $Date: 2000/01/10 16:23:32 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -213,9 +213,13 @@ static Name predefinePrim ( String s ); static Tycon linkTycon( String s ) { Tycon tc = findTycon(findText(s)); - if (nonNull(tc)) { - return tc; + if (nonNull(tc)) return tc; + if (combined) { + tc = findTyconInAnyModule(findText(s)); + if (nonNull(tc)) return tc; } +fprintf(stderr, "frambozenvla! unknown tycon %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard type \"%s\"", s EEND; } @@ -223,9 +227,13 @@ static Tycon linkTycon( String s ) static Class linkClass( String s ) { Class cc = findClass(findText(s)); - if (nonNull(cc)) { - return cc; - } + if (nonNull(cc)) return cc; + if (combined) { + cc = findClassInAnyModule(findText(s)); + if (nonNull(cc)) return cc; + } +fprintf(stderr, "frambozenvla! unknown class %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard class \"%s\"", s EEND; } @@ -233,9 +241,13 @@ static Class linkClass( String s ) static Name linkName( String s ) { Name n = findName(findText(s)); - if (nonNull(n)) { - return n; - } + if (nonNull(n)) return n; + if (combined) { + n = findNameInAnyModule(findText(s)); + if (nonNull(n)) return n; + } +fprintf(stderr, "frambozenvla! unknown name %s\n", s ); +return NIL; ERRMSG(0) "Prelude does not define standard name \"%s\"", s EEND; } @@ -427,7 +439,7 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ setCurrModule(modulePrelude); /* primops */ - nameMkIO = linkName("primMkIO"); + nameMkIO = linkName("hugsprimMkIO"); for (i=0; asmPrimOps[i].name; ++i) { Text t = findText(asmPrimOps[i].name); Name n = findName(t); @@ -447,25 +459,25 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ /* static(tidyInfix) */ nameNegate = linkName("negate"); /* user interface */ - nameRunIO = linkName("primRunIO_hugs_toplevel"); + nameRunIO = linkName("hugsprimRunIO_toplevel"); namePrint = linkName("print"); /* desugar */ nameOtherwise = linkName("otherwise"); nameUndefined = linkName("undefined"); /* pmc */ # if NPLUSK - namePmSub = linkName("primPmSub"); + namePmSub = linkName("hugsprimPmSub"); # endif /* translator */ nameEqChar = linkName("primEqChar"); - nameCreateAdjThunk = linkName("primCreateAdjThunk"); - namePmInt = linkName("primPmInt"); - namePmInteger = linkName("primPmInteger"); + nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk"); + namePmInt = linkName("hugsprimPmInt"); + namePmInteger = linkName("hugsprimPmInteger"); namePmDouble = linkName("primPmDouble"); - namePmFromInteger = linkName("primPmFromInteger"); - namePmSubtract = linkName("primPmSubtract"); - namePmLe = linkName("primPmLe"); + namePmFromInteger = linkName("hugsprimPmFromInteger"); + namePmSubtract = linkName("hugsprimPmSubtract"); + namePmLe = linkName("hugsprimPmLe"); implementCfun ( nameCons, NIL ); implementCfun ( nameNil, NIL ); @@ -492,6 +504,12 @@ Int what; { case POSTPREL: #if 1 fprintf(stderr, "linkControl(POSTPREL)\n"); +#if 1 + setCurrModule(modulePrelude); + linkPreludeTC(); + linkPreludeCM(); + linkPreludeNames(); +#endif #endif break; diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index b35bb94..a302cb7 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.33 $ - * $Date: 2000/01/07 17:49:29 $ + * $Revision: 1.34 $ + * $Date: 2000/01/10 16:23:33 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1209,6 +1209,29 @@ Tycon findQualTyconWithoutConsultingExportList ( QualId q ) return NIL; } +Tycon findTyconInAnyModule ( Text t ) +{ + Tycon tc; + for (tc = TYCMIN; tc < tyconHw; tc++) + if (tycon(tc).text == t) return tc; + return NIL; +} + +Class findClassInAnyModule ( Text t ) +{ + Class cc; + for (cc = CLASSMIN; cc < classHw; cc++) + if (cclass(cc).text == t) return cc; + return NIL; +} + +Name findNameInAnyModule ( Text t ) +{ + Name nm; + for (nm = NAMEMIN; nm < nameHw; nm++) + if (name(nm).text == t) return nm; + return NIL; +} /* Same deal, except for Names. */ Name findQualNameWithoutConsultingExportList ( QualId q ) diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index 8a1e04d..ce05049 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -1548,11 +1548,11 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r, primCompAux :: Ord a => a -> a -> Ordering -> Ordering primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT -primPmInt :: Num a => Int -> a -> Bool -primPmInt n x = fromInt n == x +hugsprimPmInt :: Num a => Int -> a -> Bool +hugsprimPmInt n x = fromInt n == x -primPmInteger :: Num a => Integer -> a -> Bool -primPmInteger n x = fromInteger n == x +hugsprimPmInteger :: Num a => Integer -> a -> Bool +hugsprimPmInteger n x = fromInteger n == x primPmDouble :: Fractional a => Double -> a -> Bool primPmDouble n x = fromDouble n == x @@ -1562,28 +1562,28 @@ primPmFail :: a primPmFail = error "Pattern Match Failure" -- used in desugaring Foreign functions -primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a -primMkIO = ST +hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a +hugsprimMkIO = ST -primCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr -primCreateAdjThunk fun typestr callconv +hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr +hugsprimCreateAdjThunk fun typestr callconv = do sp <- makeStablePtr fun p <- copy_String_to_cstring typestr -- is never freed a <- primCreateAdjThunkARCH sp p callconv return a -- The following primitives are only needed if (n+k) patterns are enabled: -primPmSub :: Integral a => Int -> a -> a -primPmSub n x = x - fromInt n +hugsprimPmSub :: Integral a => Int -> a -> a +hugsprimPmSub n x = x - fromInt n -primPmFromInteger :: Integral a => Integer -> a -primPmFromInteger = fromIntegral +hugsprimPmFromInteger :: Integral a => Integer -> a +hugsprimPmFromInteger = fromIntegral -primPmSubtract :: Integral a => a -> a -> a -primPmSubtract x y = x - y +hugsprimPmSubtract :: Integral a => a -> a -> a +hugsprimPmSubtract x y = x - y -primPmLe :: Integral a => a -> a -> Bool -primPmLe x y = x <= y +hugsprimPmLe :: Integral a => a -> a -> Bool +hugsprimPmLe x y = x <= y -- Unpack strings generated by the Hugs code generator. -- Strings can contain \0 provided they're coded right. @@ -1842,8 +1842,8 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ())) prelCleanupAfterRunAction = primRunST (newIORef Nothing) -- used when Hugs invokes top level function -primRunIO_hugs_toplevel :: IO a -> () -primRunIO_hugs_toplevel m +hugsprimRunIO_toplevel :: IO a -> () +hugsprimRunIO_toplevel m = protect 5 (fst (unST composite_action realWorld)) where composite_action -- 1.7.10.4