summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-06-22 10:17:34 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-06-22 10:17:34 -0400
commitd60f854fc35ce30fb698f3d8e87b88938001fdaf (patch)
tree993aecf3c64b1e472749ccc4cc3d9ffa6dd2ed3e /src
parentf3ddf9922b90bdd45ca5b1c33c72ff316d5440eb (diff)
FFI through cloconv
Diffstat (limited to 'src')
-rw-r--r--src/cjrize.sml3
-rw-r--r--src/cloconv.sml11
-rw-r--r--src/flat.sml3
-rw-r--r--src/flat_print.sml9
-rw-r--r--src/flat_util.sml10
5 files changed, 33 insertions, 3 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 48d1dae3..2647ad24 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -93,12 +93,15 @@ fun cifyTyp ((t, loc), sm) =
((L'.TRecord si, loc), sm)
end
| L.TNamed n => ((L'.TNamed n, loc), sm)
+ | L.TFfi _ => raise Fail "Cjrize TFfi"
fun cifyExp ((e, loc), sm) =
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
| L.ERel n => ((L'.ERel n, loc), sm)
| L.ENamed n => ((L'.ENamed n, loc), sm)
+ | L.EFfi _ => raise Fail "Cjrize EFfi"
+ | L.EFfiApp _ => raise Fail "Cjrize EFfiApp"
| L.ECode n => ((L'.ECode n, loc), sm)
| L.EApp (e1, e2) =>
let
diff --git a/src/cloconv.sml b/src/cloconv.sml
index 5c26312a..98f86e5b 100644
--- a/src/cloconv.sml
+++ b/src/cloconv.sml
@@ -69,7 +69,7 @@ fun ccTyp (t, loc) =
L.TFun (t1, t2) => (L'.TFun (ccTyp t1, ccTyp t2), loc)
| L.TRecord xts => (L'.TRecord (map (fn (x, t) => (x, ccTyp t)) xts), loc)
| L.TNamed n => (L'.TNamed n, loc)
- | L.TFfi _ => raise Fail "Cloconv TFfi"
+ | L.TFfi mx => (L'.TFfi mx, loc)
structure Ds :> sig
type t
@@ -111,8 +111,13 @@ fun ccExp env ((e, loc), D) =
L.EPrim p => ((L'.EPrim p, loc), D)
| L.ERel n => ((L'.ERel n, loc), Ds.used (D, n))
| L.ENamed n => ((L'.ENamed n, loc), D)
- | L.EFfi _ => raise Fail "Cloconv EFfi"
- | L.EFfiApp _ => raise Fail "Cloconv EFfiApp"
+ | L.EFfi mx => ((L'.EFfi mx, loc), D)
+ | L.EFfiApp (m, x, es) =>
+ let
+ val (es, D) = ListUtil.foldlMap (ccExp env) D es
+ in
+ ((L'.EFfiApp (m, x, es), loc), D)
+ end
| L.EApp (e1, e2) =>
let
val (e1, D) = ccExp env (e1, D)
diff --git a/src/flat.sml b/src/flat.sml
index 55c7397a..e635bd1c 100644
--- a/src/flat.sml
+++ b/src/flat.sml
@@ -35,6 +35,7 @@ datatype typ' =
| TCode of typ * typ
| TRecord of (string * typ) list
| TNamed of int
+ | TFfi of string * string
withtype typ = typ' located
@@ -42,6 +43,8 @@ datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
+ | EFfi of string * string
+ | EFfiApp of string * string * exp list
| ECode of int
| EApp of exp * exp
diff --git a/src/flat_print.sml b/src/flat_print.sml
index 08008e9a..ccfceb2f 100644
--- a/src/flat_print.sml
+++ b/src/flat_print.sml
@@ -66,6 +66,7 @@ fun p_typ' par env (t, _) =
string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupTNamed env n))
+ | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
and p_typ env = p_typ' false env
@@ -83,6 +84,14 @@ fun p_exp' par env (e, _) =
string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
else
string (#1 (E.lookupENamed env n))
+ | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
+ | EFfiApp (m, x, es) => box [string "FFI(",
+ string m,
+ string ".",
+ string x,
+ string "(",
+ p_list (p_exp env) es,
+ string "))"]
| ECode n => string ("code$" ^ Int.toString n)
| EApp (e1, e2) => parenIf par (box [p_exp env e1,
space,
diff --git a/src/flat_util.sml b/src/flat_util.sml
index 6bddd566..72020d44 100644
--- a/src/flat_util.sml
+++ b/src/flat_util.sml
@@ -61,6 +61,7 @@ fun compare ((t1, _), (t2, _)) =
joinL compareFields (xts1, xts2)
end
| (TNamed n1, TNamed n2) => Int.compare (n1, n2)
+ | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TTop, _) => LESS
| (_, TTop) => GREATER
@@ -74,6 +75,9 @@ fun compare ((t1, _), (t2, _)) =
| (TRecord _, _) => LESS
| (_, TRecord _) => GREATER
+ | (TNamed _, _) => LESS
+ | (_, TNamed _) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -108,6 +112,7 @@ fun mapfold fc =
xts,
fn xts' => (TRecord xts', loc))
| TNamed _ => S.return2 cAll
+ | TFfi _ => S.return2 cAll
in
mft
end
@@ -152,6 +157,11 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
EPrim _ => S.return2 eAll
| ERel _ => S.return2 eAll
| ENamed _ => S.return2 eAll
+ | EFfi _ => S.return2 eAll
+ | EFfiApp (m, x, es) =>
+ S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
+ fn es' =>
+ (EFfiApp (m, x, es'), loc))
| ECode _ => S.return2 eAll
| EApp (e1, e2) =>
S.bind2 (mfe ctx e1,