Mercurial > urweb

changeset 52:198172560b73

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FFI through cloconv
author Adam Chlipala <adamc@hcoop.net>
date Sun, 22 Jun 2008 10:17:34 -0400
parents 92361a008a10
children 4f641f8fddaa
files src/cjrize.sml src/cloconv.sml src/flat.sml src/flat_print.sml src/flat_util.sml
diffstat 5 files changed, 33 insertions(+), 3 deletions(-) [+]
line wrap: on
line diff
--- a/src/cjrize.sml	Sun Jun 22 10:12:23 2008 -0400
+++ b/src/cjrize.sml	Sun Jun 22 10:17:34 2008 -0400
@@ -93,12 +93,15 @@
             ((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
--- a/src/cloconv.sml	Sun Jun 22 10:12:23 2008 -0400
+++ b/src/cloconv.sml	Sun Jun 22 10:17:34 2008 -0400
@@ -69,7 +69,7 @@
         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 @@
         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)
--- a/src/flat.sml	Sun Jun 22 10:12:23 2008 -0400
+++ b/src/flat.sml	Sun Jun 22 10:17:34 2008 -0400
@@ -35,6 +35,7 @@
        | TCode of typ * typ
        | TRecord of (string * typ) list
        | TNamed of int
+       | TFfi of string * string
 
 withtype typ = typ' located
 
@@ -42,6 +43,8 @@
          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
 
--- a/src/flat_print.sml	Sun Jun 22 10:12:23 2008 -0400
+++ b/src/flat_print.sml	Sun Jun 22 10:17:34 2008 -0400
@@ -66,6 +66,7 @@
             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 @@
             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,
--- a/src/flat_util.sml	Sun Jun 22 10:12:23 2008 -0400
+++ b/src/flat_util.sml	Sun Jun 22 10:17:34 2008 -0400
@@ -61,6 +61,7 @@
             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 @@
       | (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 @@
                                          xts,
                      fn xts' => (TRecord xts', loc))
               | TNamed _ => S.return2 cAll
+              | TFfi _ => S.return2 cAll
     in
         mft
     end
@@ -152,6 +157,11 @@
                 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,