shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Add simple foreign import.

--- a/comb/mhs.comb

+++ b/comb/mhs.comb

@@ -1,3 +1,3 @@

-v3.2

-770

-(($A :0 ((_576 _529) (($B ((($S' ($C ((($C' ($S' _576)) (($B ($C _2)) _516)) (($B ($B (_576 _604))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _577)) ((($C' $B) (($B _667) (($B _594) ((($C' _705) _8) 0)))) (($B (_667 _597)) (($B (_610 "top level defns: ")) _558)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _577)) ((($C' $B) (($B _667) (($B _594) ((($C' _705) _8) 1)))) (_593 ($T (($B ($B (_667 _597))) ((($C' $B) (($B _610) _520)) (($B (_610 " = ")) _359))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _577))) ((($C' $B) ($B' (($B _667) (($B _599) _11)))) (($B ($B (_610 _1))) (($B (($C' _610) _558)) (_610 (($O 10) $K))))))) (($B ($B (_576 _604))) ((($C' $B) ($B' (($B _667) (($B _594) ((($C' _705) _8) 0))))) (($B ($B (_667 _597))) (($B ($B (_610 "final pass            "))) ((($C' ($C' _610)) (($B ($B (_571 6))) (($B ($B _558)) _699))) "ms")))))))) _3)))) _555))) (($B (($C' $C) (($B ($C _615)) _359))) (($C _628) (_645 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_610 "(($A :"))))) (($B ($B (($C' $B) (($B _610) _558)))) (($B ($B ($B (_610 (($O 32) $K))))) ((($C' $B) (($B ($C' _610)) ($B _359))) (($B (_610 ") ")) (($C _610) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _336)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _667) (($B _664) (($B (_667 _714)) (($B (_610 "main: findIdent: ")) _520))))) (($C' _548) _518)))) (($B ($B _552)) (($B (($C' _612) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _518))) $K)))))) (($C _628) (_645 0)))))) (($B (_667 _335)) (($B (_667 _516)) (($B (_610 (($O 95) $K))) _558)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _627) (_614 (_569 "-v")))) ((_644 _569) "-r"))) (($B (_608 (($O 46) $K))) (($B _666) (_613 ((_632 _690) "-i")))))) (($B (_667 _639)) ((($C' _610) (($B _666) (_613 ((_632 _690) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _701) _627) 1)) (_714 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _639)) (_614 ((_668 _710) ((_668 (_569 (($O 45) $K))) (_625 1))))))) (_635 ((_668 _710) (_569 "--")))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _576)) _16) (($B ($B ($B (_576 _604)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _577) (($B (_667 _595)) (($B (_667 (_626 1000000))) _190)))))) (($B ($B ($B ($B (_576 _604))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _577))) ((($C' $B) ($B' (($B _667) (($B _594) ((($C' _705) _8) 0))))) (($B ($B (_667 _597))) (($B ($B (_610 "combinator conversion "))) ((($C' ($C' _610)) (($B ($B (_571 6))) (($B ($B _558)) _699))) "ms"))))))) (($B ($B _578)) (($B $P) (($C _522) (_516 "main")))))))) (_612 ($T ((($C' ($C' $O)) ((($C' $B) $P) _362)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_576 _529)))) (($B ($B ($B (($C' _530) ((($C' _694) (($B _627) (_635 ((_668 _710) (_569 "--"))))) 1))))) (($B ($B ($B (_667 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _507))) (($C' ($C' _612)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _667) (($B _664) (($B (_667 _714)) (($B (_610 "not found ")) _520))))) ($C _508))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _361))) (($B (_667 (_664 (_714 "primlookup")))) (($C (_650 _569)) _5))))) (_714 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($

\ No newline at end of file

+v3.3

+772

+(($A :0 ((_578 _531) (($B ((($S' ($C ((($C' ($S' _578)) (($B ($C _2)) _518)) (($B ($B (_578 _606))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _579)) ((($C' $B) (($B _669) (($B _596) ((($C' _707) _8) 0)))) (($B (_669 _599)) (($B (_612 "top level defns: ")) _560)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _579)) ((($C' $B) (($B _669) (($B _596) ((($C' _707) _8) 1)))) (_595 ($T (($B ($B (_669 _599))) ((($C' $B) (($B _612) _522)) (($B (_612 " = ")) _359))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _579))) ((($C' $B) ($B' (($B _669) (($B _601) _11)))) (($B ($B (_612 _1))) (($B (($C' _612) _560)) (_612 (($O 10) $K))))))) (($B ($B (_578 _606))) ((($C' $B) ($B' (($B _669) (($B _596) ((($C' _707) _8) 0))))) (($B ($B (_669 _599))) (($B ($B (_612 "final pass            "))) ((($C' ($C' _612)) (($B ($B (_573 6))) (($B ($B _560)) _701))) "ms")))))))) _3)))) _557))) (($B (($C' $C) (($B ($C _617)) _359))) (($C _630) (_647 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_612 "(($A :"))))) (($B ($B (($C' $B) (($B _612) _560)))) (($B ($B ($B (_612 (($O 32) $K))))) ((($C' $B) (($B ($C' _612)) ($B _359))) (($B (_612 ") ")) (($C _612) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _336)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _669) (($B _666) (($B (_669 _716)) (($B (_612 "main: findIdent: ")) _522))))) (($C' _550) _520)))) (($B ($B _554)) (($B (($C' _614) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _520))) $K)))))) (($C _630) (_647 0)))))) (($B (_669 _335)) (($B (_669 _518)) (($B (_612 (($O 95) $K))) _560)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _629) (_616 (_571 "-v")))) ((_646 _571) "-r"))) (($B (_610 (($O 46) $K))) (($B _668) (_615 ((_634 _692) "-i")))))) (($B (_669 _641)) ((($C' _612) (($B _668) (_615 ((_634 _692) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _703) _629) 1)) (_716 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _641)) (_616 ((_670 _712) ((_670 (_571 (($O 45) $K))) (_627 1))))))) (_637 ((_670 _712) (_571 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _578)) _16) (($B ($B ($B (_578 _606)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _579) (($B (_669 _597)) (($B (_669 (_628 1000000))) _190)))))) (($B ($B ($B ($B (_578 _606))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _579))) ((($C' $B) ($B' (($B _669) (($B _596) ((($C' _707) _8) 0))))) (($B ($B (_669 _599))) (($B ($B (_612 "combinator conversion "))) ((($C' ($C' _612)) (($B ($B (_573 6))) (($B ($B _560)) _701))) "ms"))))))) (($B ($B _580)) (($B $P) (($C _524) (_518 "main")))))))) (_614 ($T ((($C' ($C' $O)) ((($C' $B) $P) _362)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_578 _531)))) (($B ($B ($B (($C' _532) ((($C' _696) (($B _629) (_637 ((_670 _712) (_571 "--"))))) 1))))) (($B ($B ($B (_669 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _509))) (($C' ($C' _614)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _669) (($B _666) (($B (_669 _716)) (($B (_612 "not found ")) _522))))) ($C _510))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _361))) (($B (_669 (_666 (_716 "primlookup")))) (($C (_652 _571)) _5)))) $K))) (_716 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P 

\ No newline at end of file

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -45,6 +45,7 @@

     Fcn f eqns -> [(f, dsEqns eqns)]

     Sign _ _ -> []

     Import _ -> []

+    ForImp ie i _ -> [(i, Lit $ LForImp ie)]

 oneAlt :: Expr -> EAlts

 oneAlt e = EAlts [([], e)] []

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -13,7 +13,7 @@

   EAlts(..),

   EAlt,

   ECaseArm,

-  EType,

+  EType, showEType,

   EPat, patVars, isPVar, isPConApp,

   EKind, kType,

   IdKind(..), idKindIdent,

@@ -56,6 +56,7 @@

   | Fcn Ident [Eqn]

   | Sign Ident ETypeScheme

   | Import ImportSpec

+  | ForImp String Ident EType

   --Xderiving (Show, Eq)

 data ImportSpec = ImportSpec Bool Ident (Maybe Ident)

@@ -117,7 +118,12 @@

 eqCon (ConLit    l) (ConLit    k) = eqLit   l k

 eqCon _             _             = False

-data Lit = LInt Int | LChar Char | LStr String | LPrim String

+data Lit

+  = LInt Int

+  | LChar Char

+  | LStr String

+  | LPrim String

+  | LForImp String

   --Xderiving (Show, Eq)

 eqLit :: Lit -> Lit -> Bool

@@ -125,6 +131,7 @@

 eqLit (LChar x) (LChar y) = eqChar x y

 eqLit (LStr  x) (LStr  y) = eqString x y

 eqLit (LPrim x) (LPrim y) = eqString x y

+eqLit (LForImp x) (LForImp y) = eqString x y

 eqLit _         _         = False

 type ECaseArm = (EPat, EAlts)

@@ -310,6 +317,7 @@

     Fcn i eqns -> unlines (map (\ (Eqn ps alts) -> showIdent i ++ " " ++ unwords (map showEPat ps) ++ showAlts "=" alts) eqns)

     Sign i t -> showIdent i ++ " :: " ++ showETypeScheme t

     Import (ImportSpec q m mm) -> "import " ++ (if q then "qualified " else "") ++ showIdent m ++ maybe "" ((" as " ++) . unIdent) mm

+    ForImp ie i t -> "foreign import ccall " ++ showString ie ++ " " ++ showIdent i ++ " :: " ++ showEType t

 showConstr :: Constr -> String

 showConstr (i, ts) = unwords (showIdent i : map showEType ts)

@@ -381,7 +389,8 @@

     LInt i -> showInt i

     LChar c -> showChar c

     LStr s -> showString s

-    LPrim s -> '$':s

+    LPrim s -> '$' : s

+    LForImp s -> '#' : s

 showEStmt :: EStmt -> String

 showEStmt as =

--- a/src/MicroHs/Main.hs

+++ b/src/MicroHs/Main.hs

@@ -65,7 +65,7 @@

       putStrLn $ "final pass            " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"

 version :: String

-version = "v3.2\n"

+version = "v3.3\n"

 type Program = (Ident, [LDef])

--- a/src/MicroHs/Parse.hs

+++ b/src/MicroHs/Parse.hs

@@ -111,7 +111,7 @@

   satisfyM "LQIdent" is

 keywords :: [String]

-keywords = ["case", "data", "do", "else", "forall", "if", "import",

+keywords = ["case", "data", "do", "else", "forall", "foreign", "if", "import",

   "in", "let", "module", "newtype", "of", "primitive", "then", "type", "where"]

 pSpec :: Char -> P ()

@@ -234,6 +234,7 @@

   <|> uncurry Fcn <$> pEqns

   <|> Sign        <$> (pLIdentSym <* pSymbol "::") <*> pTypeScheme

   <|> Import      <$> (pKeyword "import" *> pImportSpec)

+  <|> ForImp      <$> (pKeyword "foreign" *> pKeyword "import" *> pKeyword "ccall" *> pString) <*> pLIdent <*> (pSymbol "::" *> pType)

 pLHS :: P LHS

 pLHS = pair <$> pUIdentSym <*> many pIdKind

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -616,6 +616,7 @@

     Newtype lhs c  t -> Newtype lhs c <$> withVars (snd lhs) (fst <$> tcTypeT (Just kType) t)

     Type    lhs    t -> Type    lhs   <$> withVars (snd lhs) (fst <$> tcTypeT Nothing t)

     Sign    i      t -> Sign    i     <$> tcTypeScheme (Just kType) t

+    ForImp  ie i   t -> (ForImp ie i . fst) <$> tcTypeT (Just kType) t

     _ -> T.return d

 tcTypeScheme :: --XHasCallStack =>

@@ -657,6 +658,10 @@

       let

         tret = foldl tApp (tCon (qualIdent mn i)) (map tVarK vks)

       extValE c (ETypeScheme vks $ tArrow t tret) (ECon $ ConNew (qualIdent mn c))

+    ForImp _ i t -> T.do

+      let t' = ETypeScheme [] t

+      extQVal i t'

+      extVal (qualIdent mn i) t'

     _ -> T.return ()

 tcDefValue :: --XHasCallStack =>

@@ -673,6 +678,9 @@

       T.return $ Fcn (qualIdent mn i) teqns

 --      (et, _) <- withExtTyps vks (tcExpr (Just t) (foldr eLam1 rhs vs))

 --      T.return (Fcn (qualIdent mn i, vs) (dropLam (length vs) et))

+    ForImp ie i t -> T.do

+      mn <- gets moduleName

+      T.return (ForImp ie (qualIdent mn i) t)

     _ -> T.return adef

 -- Kind check a type while already in type checking mode

@@ -831,6 +839,7 @@

     LPrim _ -> T.do

       t <- unMType mt  -- pretend it is anything

       T.return (ELit loc l, t)

+    LForImp _ -> impossible

 unArrow :: SLoc -> Maybe EType -> T (EType, EType)

 unArrow _ Nothing = T.do { a <- newUVar; r <- newUVar; T.return (a, r) }

--- a/src/runtime/eval.c

+++ b/src/runtime/eval.c

@@ -28,6 +28,8 @@

 #define PRIcounter PRIu64

 typedef uint64_t bits_t;        /* One word of bits */

+/* We cast all FFI functions to this type.  It's reasonably portable */

+typedef void (*funptr_t)(void);

 #if defined(__MINGW32__)

 #define ffsl __builtin_ffsll

@@ -85,7 +87,7 @@

 #endif  /* !defined(_MSC_VER) */

-#define VERSION "v3.2\n"

+#define VERSION "v3.3\n"

 /* Keep permanent nodes for LOW_INT <= i < HIGH_INT */

 #define LOW_INT (-10)

@@ -106,6 +108,7 @@

                 T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,

                 T_IO_PERFORMIO,

                 T_IO_GETTIMEMILLI, T_IO_PRINT,

+                T_IO_CCALL,

                 T_STR,

                 T_LAST_TAG,

 };

@@ -167,6 +170,7 @@

 #define FUN(p) (p)->ufun.uufun

 #define ARG(p) (p)->uarg.uuarg

 #define STR(p) (p)->uarg.uustring

+#define FUNPTR(p) (p)->uarg.uufunptr

 #define INDIR(p) ARG(p)

 #define HANDLE(p) (p)->uarg.uufile

 #define NODE_SIZE sizeof(node)

@@ -606,6 +610,37 @@

   gc();

 }

+/*

+ * Table of FFI callable functions.

+ * (For a more flexible solution use dlopen()/dlsym()/dlclose())

+ * The table contains the information needed to do the actual call.

+ * The types are

+ *   V    void name(void)

+ *   I    int  name(void)

+ *   IV   void name(int)

+ *   II   int  name(int)

+ *   IIV  void name(int, int)

+ *   III  int  name(int, int)

+ * more can easily be added.

+ */

+struct {

+  const char *ffi_name;

+  const funptr_t ffi_fun;

+  enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III } ffi_how;

+} ffi_table[] = {

+  { "llabs", (funptr_t)llabs, FFI_II },

+};

+

+/* Look up an FFI function by name */

+value_t

+lookupFFIname(const char *name)

+{

+  for(int i = 0; i < sizeof(ffi_table) / sizeof(ffi_table[0]); i++)

+    if (strcmp(ffi_table[i].ffi_name, name) == 0)

+      return (value_t)i;

+  ERR("lookupFFIname");

+}

+

 /* If the next input character is c, then consume it, else leave it alone. */

 int

 gobble(BFILE *f, int c)

@@ -781,6 +816,20 @@

       r = mkStrNode(realloc(buffer, p - buffer));

       return r;

     }

+  case '#':

+    /* An FFI name */

+    for (int j = 0;;) {

+      c = getb(f);

+      if (c == ' ' || c == ')') {

+        ungetb(c, f);

+        buf[j] = 0;

+        break;

+      }

+      buf[j++] = c;

+    }

+    r = alloc_node(T_IO_CCALL);

+    SETVALUE(r, lookupFFIname(buf));

+    return r;

   default:

     fprintf(stderr, "parse '%c'\n", c);

     ERR("parse default");

@@ -1017,6 +1066,7 @@

   case T_IO_DROPARGS: fprintf(f, "$IO.dropArgs"); break;

   case T_IO_GETTIMEMILLI: fprintf(f, "$IO.getTimeMilli"); break;

   case T_IO_PERFORMIO: fprintf(f, "$IO.performIO"); break;

+  case T_IO_CCALL: fprintf(f, "#%s", ffi_table[GETVALUE(n)].ffi_name); break;

   default: ERR("print tag");

   }

 }

@@ -1332,6 +1382,7 @@

     case T_IO_GETARGS:

     case T_IO_DROPARGS:

     case T_IO_GETTIMEMILLI:

+    case T_IO_CCALL:

       RET;

     default:

@@ -1503,6 +1554,26 @@

       n = alloc_node(T_INT);

       SETVALUE(n, (value_t)(gettime() * 1000));

       RETIO(n);

+    case T_IO_CCALL:

+      {

+        int a = (int)GETVALUE(n);

+        funptr_t f = ffi_table[a].ffi_fun;

+        value_t r, x, y;

+#define INTARG(n) evalint(ARG(TOP(n)))

+#define FFIV(n) CHECKIO(n)

+#define FFI(n) CHECKIO(n); GCCHECK(1)

+        /* This isn't great, but this is MicroHs, so it's good enough. */

+        switch (ffi_table[a].ffi_how) {

+        case FFI_V:   FFIV(0);                                   (*                               f)();                  RETIO(combUnit);

+        case FFI_I:   FFI (0);                               r = (*(value_t (*)(void            ))f)();    n = mkInt(r); RETIO(n);

+        case FFI_IV:  FFIV(1); x = INTARG(1);                    (*(void    (*)(value_t         ))f)(x);                 RETIO(combUnit);

+        case FFI_II:  FFI (1); x = INTARG(1);                r = (*(value_t (*)(value_t         ))f)(x);   n = mkInt(r); RETIO(n);

+        case FFI_IIV: FFIV(1); x = INTARG(1); y = INTARG(2);     (*(void    (*)(value_t, value_t))f)(x,y);               RETIO(combUnit);

+        case FFI_III: FFI (1); x = INTARG(1); y = INTARG(2); r = (*(value_t (*)(value_t, value_t))f)(x,y); n = mkInt(r); RETIO(n);

+        default: ERR("T_IO_CCALL");

+        }

+      }

+

     default:

       fprintf(stderr, "bad tag %d\n", GETTAG(n));

       ERR("evalio tag");

--- /dev/null

+++ b/tests/Foreign.hs

@@ -1,0 +1,11 @@

+module Foreign(main) where

+import Prelude

+

+foreign import ccall "llabs" abs :: Int -> IO Int

+

+main :: IO ()

+main = do

+  x1 <- abs (3 - 8)

+  putStrLn $ showInt x1

+  x2 <- abs (10 - 8)

+  putStrLn $ showInt x2

--- /dev/null

+++ b/tests/Foreign.ref

@@ -1,0 +1,2 @@

+5

+2

--- a/tests/Makefile

+++ b/tests/Makefile

@@ -15,6 +15,7 @@

 	$(MHS) LitMatch && $(EVAL) > LitMatch.out && diff LitMatch.ref LitMatch.out

 	$(MHS) Word && $(EVAL) > Word.out && diff Word.ref Word.out

 	$(MHS) Enum && $(EVAL) > Enum.out && diff Enum.ref Enum.out

+	$(MHS) Foreign && $(EVAL) > Foreign.out && diff Foreign.ref Foreign.out

 time:

 	@echo Expect about 10s runtime

-- 

⑨