summaryrefslogtreecommitdiff
path: root/src/corify.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-06-22 09:27:29 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-06-22 09:27:29 -0400
commita78e978c05d7d28f31f4407b6918d89d44a5643c (patch)
tree29f8a7dd372a3fd5fa14b1960e5b3917c6aa1e50 /src/corify.sml
parent79223408d7b3ce19f0463142461d84a1ad09d785 (diff)
Start of FFI
Diffstat (limited to 'src/corify.sml')
-rw-r--r--src/corify.sml108
1 files changed, 68 insertions, 40 deletions
diff --git a/src/corify.sml b/src/corify.sml
index e3ea791e..6a80881a 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -60,10 +60,15 @@ structure St : sig
val enter : t -> t
val leave : t -> {outer : t, inner : t}
+ val ffi : string -> t
val bindCore : t -> string -> int -> t * int
val lookupCoreById : t -> int -> int option
- val lookupCoreByName : t -> string -> int
+
+ datatype core =
+ Normal of int
+ | Ffi of string
+ val lookupCoreByName : t -> string -> core
val bindStr : t -> string -> int -> t -> t
val lookupStrById : t -> int -> t
@@ -74,11 +79,11 @@ structure St : sig
val lookupFunctorByName : string * t -> int * L.str
end = struct
-datatype flattening = F of {
- core : int SM.map,
- strs : flattening SM.map,
- funs : (int * L.str) SM.map
-}
+datatype flattening =
+ FNormal of {core : int SM.map,
+ strs : flattening SM.map,
+ funs : (int * L.str) SM.map}
+ | FFfi of string
type t = {
core : int IM.map,
@@ -92,22 +97,25 @@ val empty = {
core = IM.empty,
strs = IM.empty,
funs = IM.empty,
- current = F { core = SM.empty, strs = SM.empty, funs = SM.empty },
+ current = FNormal { core = SM.empty, strs = SM.empty, funs = SM.empty },
nested = []
}
+datatype core =
+ Normal of int
+ | Ffi of string
+
fun bindCore {core, strs, funs, current, nested} s n =
let
val n' = alloc ()
val current =
- let
- val F {core, strs, funs} = current
- in
- F {core = SM.insert (core, s, n'),
- strs = strs,
- funs = funs}
- end
+ case current of
+ FFfi _ => raise Fail "Binding inside FFfi"
+ | FNormal {core, strs, funs} =>
+ FNormal {core = SM.insert (core, s, n'),
+ strs = strs,
+ funs = funs}
in
({core = IM.insert (core, n, n'),
strs = strs,
@@ -119,18 +127,21 @@ fun bindCore {core, strs, funs, current, nested} s n =
fun lookupCoreById ({core, ...} : t) n = IM.find (core, n)
-fun lookupCoreByName ({current = F {core, ...}, ...} : t) x =
- case SM.find (core, x) of
- NONE => raise Fail "Corify.St.lookupCoreByName"
- | SOME n => n
+fun lookupCoreByName ({current, ...} : t) x =
+ case current of
+ FFfi m => Ffi m
+ | FNormal {core, ...} =>
+ case SM.find (core, x) of
+ NONE => raise Fail "Corify.St.lookupCoreByName"
+ | SOME n => Normal n
fun enter {core, strs, funs, current, nested} =
{core = core,
strs = strs,
funs = funs,
- current = F {core = SM.empty,
- strs = SM.empty,
- funs = SM.empty},
+ current = FNormal {core = SM.empty,
+ strs = SM.empty,
+ funs = SM.empty},
nested = current :: nested}
fun dummy f = {core = IM.empty,
@@ -148,45 +159,51 @@ fun leave {core, strs, funs, current, nested = m1 :: rest} =
inner = dummy current}
| leave _ = raise Fail "Corify.St.leave"
-fun bindStr ({core, strs, funs, current = F {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
+fun ffi m = dummy (FFfi m)
+
+fun bindStr ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
x n ({current = f, ...} : t) =
{core = core,
strs = IM.insert (strs, n, f),
funs = funs,
- current = F {core = mcore,
+ current = FNormal {core = mcore,
strs = SM.insert (mstrs, x, f),
funs = mfuns},
nested = nested}
+ | bindStr _ _ _ _ = raise Fail "Corify.St.bindStr"
fun lookupStrById ({strs, ...} : t) n =
case IM.find (strs, n) of
NONE => raise Fail "Corify.St.lookupStrById"
| SOME f => dummy f
-fun lookupStrByName (m, {current = F {strs, ...}, ...} : t) =
- case SM.find (strs, m) of
- NONE => raise Fail "Corify.St.lookupStrByName"
- | SOME f => dummy f
+fun lookupStrByName (m, {current = FNormal {strs, ...}, ...} : t) =
+ (case SM.find (strs, m) of
+ NONE => raise Fail "Corify.St.lookupStrByName"
+ | SOME f => dummy f)
+ | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName"
-fun bindFunctor ({core, strs, funs, current = F {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
+fun bindFunctor ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t)
x n na str =
{core = core,
strs = strs,
funs = IM.insert (funs, n, (na, str)),
- current = F {core = mcore,
- strs = mstrs,
- funs = SM.insert (mfuns, x, (na, str))},
+ current = FNormal {core = mcore,
+ strs = mstrs,
+ funs = SM.insert (mfuns, x, (na, str))},
nested = nested}
+ | bindFunctor _ _ _ _ _ = raise Fail "Corify.St.bindFunctor"
fun lookupFunctorById ({funs, ...} : t) n =
case IM.find (funs, n) of
NONE => raise Fail "Corify.St.lookupFunctorById"
| SOME v => v
-fun lookupFunctorByName (m, {current = F {funs, ...}, ...} : t) =
- case SM.find (funs, m) of
- NONE => raise Fail "Corify.St.lookupFunctorByName"
- | SOME v => v
+fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) =
+ (case SM.find (funs, m) of
+ NONE => raise Fail "Corify.St.lookupFunctorByName"
+ | SOME v => v)
+ | lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName"
end
@@ -213,9 +230,10 @@ fun corifyCon st (c, loc) =
let
val st = St.lookupStrById st m
val st = foldl St.lookupStrByName st ms
- val n = St.lookupCoreByName st x
in
- (L'.CNamed n, loc)
+ case St.lookupCoreByName st x of
+ St.Normal n => (L'.CNamed n, loc)
+ | St.Ffi m => (L'.CFfi (m, x), loc)
end
| L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc)
@@ -239,9 +257,10 @@ fun corifyExp st (e, loc) =
let
val st = St.lookupStrById st m
val st = foldl St.lookupStrByName st ms
- val n = St.lookupCoreByName st x
in
- (L'.ENamed n, loc)
+ case St.lookupCoreByName st x of
+ St.Normal n => (L'.ENamed n, loc)
+ | St.Ffi m => (L'.EFfi (m, x), loc)
end
| L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc)
| L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc)
@@ -280,6 +299,14 @@ fun corifyDecl ((d, loc : EM.span), st) =
(ds, st)
end
+ | L.DFfiStr (x, n, _) =>
+ let
+ val st = St.bindStr st x n (St.ffi x)
+ in
+ ([], st)
+ end
+
+
and corifyStr ((str, _), st) =
case str of
L.StrConst ds =>
@@ -324,7 +351,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
L.DCon (_, n', _, _) => Int.max (n, n')
| L.DVal (_, n', _ , _) => Int.max (n, n')
| L.DSgn (_, n', _) => Int.max (n, n')
- | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)))
+ | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
+ | L.DFfiStr (_, n', _) => Int.max (n, n'))
0 ds
and maxNameStr (str, _) =