Skip to content

GitLab

Commit 9df21476 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-01-10 16:23:32 by sewardj]

parent 98689fa6
Hide whitespace changes
Inline Side-by-side
Showing with 98 additions and 57 deletions
ghc/interpreter/lib/Prelude.hs
View file @ 9df21476
......@@ -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
......
ghc/interpreter/link.c
View file @ 9df21476
......@@ -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;
......
ghc/interpreter/storage.c
View file @ 9df21476
......@@ -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 )
......
ghc/lib/hugs/Prelude.hs
View file @ 9df21476
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment