summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 17:57:47 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 17:57:47 -0400
commit3e65e1558de55a1a47a62690b48159d92a4ed072 (patch)
tree57096304282d20c6a741d75fbeeedcbba1275a81 /src
parent289b94cdcffed0874ac10b38d69366d8a43057cf (diff)
FFI datatypes
Diffstat (limited to 'src')
-rw-r--r--src/cjr.sml4
-rw-r--r--src/cjr_print.sml36
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/core.sml4
-rw-r--r--src/core_print.sml14
-rw-r--r--src/corify.sml67
-rw-r--r--src/mono.sml4
-rw-r--r--src/mono_opt.sml1
-rw-r--r--src/mono_print.sml18
-rw-r--r--src/mono_reduce.sml16
-rw-r--r--src/monoize.sml19
11 files changed, 128 insertions, 59 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index 4c9cf4c3..d260e8b3 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -40,7 +40,7 @@ withtype typ = typ' located
datatype patCon =
PConVar of int
- | PConFfi of string * string
+ | PConFfi of {mod : string, datatyp : string, con : string}
datatype pat' =
PWild
@@ -55,7 +55,7 @@ datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
- | ECon of int * exp option
+ | ECon of patCon * exp option
| EFfi of string * string
| EFfiApp of string * string * exp list
| EApp of exp * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 4a6971b0..d35c93fe 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -266,46 +266,54 @@ fun newGoto () =
end
end
+fun patConInfo env pc =
+ case pc of
+ PConVar n =>
+ let
+ val (x, _, dn) = E.lookupConstructor env n
+ val (dx, _) = E.lookupDatatype env dn
+ in
+ ("__lwd_" ^ dx ^ "_" ^ Int.toString dn,
+ "__lwc_" ^ x ^ "_" ^ Int.toString n)
+ end
+ | PConFfi {mod = m, datatyp, con} =>
+ ("lw_" ^ m ^ "_" ^ datatyp,
+ "lw_" ^ m ^ "_" ^ con)
+
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t p
| ERel n => p_rel env n
| ENamed n => p_enamed env n
- | ECon (n, eo) =>
+ | ECon (pc, eo) =>
let
- val (x, _, dn) = E.lookupConstructor env n
- val (dx, _) = E.lookupDatatype env dn
+ val (xd, xc) = patConInfo env pc
in
box [string "({",
newline,
string "struct",
space,
- string "__lwd_",
- string dx,
- string "_",
- string (Int.toString dn),
+ string xd,
space,
string "*tmp",
space,
string "=",
space,
- string "lw_malloc(ctx, sizeof(struct __lwd_",
- string dx,
- string "_",
- string (Int.toString dn),
+ string "lw_malloc(ctx, sizeof(struct ",
+ string xd,
string "));",
newline,
string "tmp->tag",
space,
string "=",
space,
- string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+ string xc,
string ";",
newline,
case eo of
NONE => box []
- | SOME e => box [string "tmp->data.__lwc_",
- string x,
+ | SOME e => box [string "tmp->data.",
+ string xd,
space,
string "=",
space,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 8e410f92..eedc594e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -143,7 +143,7 @@ fun cifyExp ((e, loc), sm) =
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.ECon (n, eo) =>
+ | L.ECon (pc, eo) =>
let
val (eo, sm) =
case eo of
@@ -155,7 +155,7 @@ fun cifyExp ((e, loc), sm) =
(SOME e, sm)
end
in
- ((L'.ECon (n, eo), loc), sm)
+ ((L'.ECon (cifyPatCon pc, eo), loc), sm)
end
| L.EFfi mx => ((L'.EFfi mx, loc), sm)
| L.EFfiApp (m, x, es) =>
diff --git a/src/core.sml b/src/core.sml
index 257f7ed1..1ecc9691 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -61,7 +61,7 @@ withtype con = con' located
datatype patCon =
PConVar of int
- | PConFfi of string * string
+ | PConFfi of {mod : string, datatyp : string, con : string}
datatype pat' =
PWild
@@ -76,7 +76,7 @@ datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
- | ECon of int * exp option
+ | ECon of patCon * exp option
| EFfi of string * string
| EFfiApp of string * string * exp list
| EApp of exp * exp
diff --git a/src/core_print.sml b/src/core_print.sml
index 520ca903..d749bdf9 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -162,11 +162,11 @@ fun p_con_named env n =
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
- | PConFfi (m, x) => box [string "FFI(",
- string m,
- string ".",
- string x,
- string ")"]
+ | PConFfi {mod = m, con, ...} => box [string "FFI(",
+ string m,
+ string ".",
+ string con,
+ string ")"]
fun p_pat' par env (p, _) =
case p of
@@ -199,8 +199,8 @@ fun p_exp' par env (e, _) =
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
| ENamed n => p_enamed env n
- | ECon (n, NONE) => p_con_named env n
- | ECon (n, SOME e) => parenIf par (box [p_con_named env n,
+ | ECon (pc, NONE) => p_patCon env pc
+ | ECon (pc, SOME e) => parenIf par (box [p_patCon env pc,
space,
p_exp' true env e])
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
diff --git a/src/corify.sml b/src/corify.sml
index a3cbb92e..81c32f40 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -62,7 +62,7 @@ structure St : sig
val enter : t -> t
val leave : t -> {outer : t, inner : t}
- val ffi : string -> L'.con SM.map -> t
+ val ffi : string -> L'.con SM.map -> string SM.map -> t
datatype core_con =
CNormal of int
@@ -99,7 +99,8 @@ datatype flattening =
strs : flattening SM.map,
funs : (string * int * L.str) SM.map}
| FFfi of {mod : string,
- vals : L'.con SM.map}
+ vals : L'.con SM.map,
+ constructors : string SM.map}
type t = {
cons : int IM.map,
@@ -258,10 +259,13 @@ fun lookupConstructorById ({constructors, ...} : t) n =
fun lookupConstructorByName ({current, ...} : t) x =
case current of
- FFfi {mod = m, ...} => L'.PConFfi (m, x)
+ FFfi {mod = m, constructors, ...} =>
+ (case SM.find (constructors, x) of
+ NONE => raise Fail "Corify.St.lookupConstructorByName [1]"
+ | SOME n => L'.PConFfi {mod = m, datatyp = n, con = x})
| FNormal {constructors, ...} =>
case SM.find (constructors, x) of
- NONE => raise Fail "Corify.St.lookupConstructorByName"
+ NONE => raise Fail "Corify.St.lookupConstructorByName [2]"
| SOME n => n
fun enter {cons, constructors, vals, strs, funs, current, nested} =
@@ -296,7 +300,7 @@ fun leave {cons, constructors, vals, strs, funs, current, nested = m1 :: rest} =
inner = dummy current}
| leave _ = raise Fail "Corify.St.leave"
-fun ffi m vals = dummy (FFfi {mod = m, vals = vals})
+fun ffi m vals constructors = dummy (FFfi {mod = m, vals = vals, constructors = constructors})
fun bindStr ({cons, constructors, vals, strs, funs,
current = FNormal {cons = mcons, constructors = mconstructors,
@@ -506,9 +510,9 @@ fun corifyDecl ((d, loc : EM.span), st) =
let
val (e, t) =
case to of
- NONE => ((L'.ECon (n, NONE), loc), t)
+ NONE => ((L'.ECon (L'.PConVar n, NONE), loc), t)
| SOME t' => ((L'.EAbs ("x", t', t,
- (L'.ECon (n, SOME (L'.ERel 0, loc)), loc)),
+ (L'.ECon (L'.PConVar n, SOME (L'.ERel 0, loc)), loc)),
loc),
(L'.TFun (t', t), loc))
in
@@ -601,8 +605,8 @@ fun corifyDecl ((d, loc : EM.span), st) =
(case sgn of
L.SgnConst sgis =>
let
- val (ds, cmap, st) =
- foldl (fn ((sgi, _), (ds, cmap, st)) =>
+ val (ds, cmap, conmap, st) =
+ foldl (fn ((sgi, _), (ds, cmap, conmap, st)) =>
case sgi of
L.SgiConAbs (x, n, k) =>
let
@@ -610,6 +614,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
in
((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
cmap,
+ conmap,
st)
end
| L.SgiCon (x, n, k, _) =>
@@ -618,16 +623,56 @@ fun corifyDecl ((d, loc : EM.span), st) =
in
((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
cmap,
+ conmap,
+ st)
+ end
+
+ | L.SgiDatatype (x, n, xnts) =>
+ let
+ val (st, n') = St.bindCon st x n
+ val (xnts, (st, cmap, conmap)) =
+ ListUtil.foldlMap
+ (fn ((x', n, to), (st, cmap, conmap)) =>
+ let
+ val st = St.bindConstructor st x' n
+ (L'.PConFfi {mod = m,
+ datatyp = x,
+ con = x'})
+ val st = St.bindConstructorVal st x' n
+
+ val dt = (L'.CNamed n', loc)
+
+ val (to, cmap) =
+ case to of
+ NONE => (NONE, SM.insert (cmap, x', dt))
+ | SOME t =>
+ let
+ val t = corifyCon st t
+ in
+ (SOME t, SM.insert (cmap, x',
+ (L'.TFun (t, dt), loc)))
+ end
+
+ val conmap = SM.insert (conmap, x', x)
+ in
+ ((x', n, to),
+ (st, cmap, conmap))
+ end) (st, cmap, conmap) xnts
+ in
+ ((L'.DDatatype (x, n', xnts), loc) :: ds,
+ cmap,
+ conmap,
st)
end
| L.SgiVal (x, _, c) =>
(ds,
SM.insert (cmap, x, corifyCon st c),
+ conmap,
st)
- | _ => (ds, cmap, st)) ([], SM.empty, st) sgis
+ | _ => (ds, cmap, conmap, st)) ([], SM.empty, SM.empty, st) sgis
- val st = St.bindStr st m n (St.ffi m cmap)
+ val st = St.bindStr st m n (St.ffi m cmap conmap)
in
(rev ds, st)
end
diff --git a/src/mono.sml b/src/mono.sml
index f8c7dbfe..2c55721a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -39,7 +39,7 @@ withtype typ = typ' located
datatype patCon =
PConVar of int
- | PConFfi of string * string
+ | PConFfi of {mod : string, datatyp : string, con : string}
datatype pat' =
PWild
@@ -54,7 +54,7 @@ datatype exp' =
EPrim of Prim.t
| ERel of int
| ENamed of int
- | ECon of int * exp option
+ | ECon of patCon * exp option
| EFfi of string * string
| EFfiApp of string * string * exp list
| EApp of exp * exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6fa871ec..6558115c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -185,7 +185,6 @@ fun exp e =
| EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
EFfiApp ("Basis", "urlifyString_w", [e])
-
| EWrite (ECase (discE, pes, {disc, ...}), loc) =>
optExp (ECase (discE,
map (fn (p, e) => (p, (EWrite e, loc))) pes,
diff --git a/src/mono_print.sml b/src/mono_print.sml
index e069c1ec..ea8458eb 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -80,11 +80,11 @@ fun p_con_named env n =
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
- | PConFfi (m, x) => box [string "FFI(",
- string m,
- string ".",
- string x,
- string ")"]
+ | PConFfi {mod = m, con, ...} => box [string "FFI(",
+ string m,
+ string ".",
+ string con,
+ string ")"]
fun p_pat' par env (p, _) =
case p of
@@ -117,10 +117,10 @@ fun p_exp' par env (e, _) =
string (#1 (E.lookupERel env n)))
handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
| ENamed n => p_enamed env n
- | ECon (n, NONE) => p_con_named env n
- | ECon (n, SOME e) => parenIf par (box [p_con_named env n,
- space,
- p_exp' true env e])
+ | ECon (pc, NONE) => p_patCon env pc
+ | ECon (pc, SOME e) => parenIf par (box [p_patCon env pc,
+ space,
+ p_exp' true env e])
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| EFfiApp (m, x, es) => box [string "FFI(",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 07634a57..20d26547 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -79,18 +79,30 @@ fun match (env, p : pat, e : exp) =
else
NONE
- | (PCon (PConVar n1, NONE), ECon (n2, NONE)) =>
+ | (PCon (PConVar n1, NONE), ECon (PConVar n2, NONE)) =>
if n1 = n2 then
SOME env
else
NONE
- | (PCon (PConVar n1, SOME p), ECon (n2, SOME e)) =>
+ | (PCon (PConVar n1, SOME p), ECon (PConVar n2, SOME e)) =>
if n1 = n2 then
match (env, p, e)
else
NONE
+ | (PCon (PConFfi {mod = m1, con = con1, ...}, NONE), ECon (PConFfi {mod = m2, con = con2, ...}, NONE)) =>
+ if m1 = m2 andalso con1 = con2 then
+ SOME env
+ else
+ NONE
+
+ | (PCon (PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
+ if m1 = m2 andalso con1 = con2 then
+ match (env, p, e)
+ else
+ NONE
+
| (PRecord xps, ERecord xes) =>
let
fun consider (xps, env) =
diff --git a/src/monoize.sml b/src/monoize.sml
index 94442132..a1d1d570 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -156,7 +156,13 @@ fun lookup (t as {count, map, decls}) k n thunk =
end
end
-
+
+
+fun capitalize s =
+ if s = "" then
+ s
+ else
+ str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
fun fooifyExp fk env =
let
@@ -193,9 +199,7 @@ fun fooifyExp fk env =
end
| _ =>
case t of
- L'.TFfi ("Basis", "string") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyString", [e]), loc), fm)
- | L'.TFfi ("Basis", "int") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyInt", [e]), loc), fm)
- | L'.TFfi ("Basis", "float") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyFloat", [e]), loc), fm)
+ L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
| L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
| L'.TDatatype (i, _) =>
@@ -306,7 +310,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
L.EPrim p => ((L'.EPrim p, loc), fm)
| L.ERel n => ((L'.ERel n, loc), fm)
| L.ENamed n => ((L'.ENamed n, loc), fm)
- | L.ECon (n, eo) =>
+ | L.ECon (pc, eo) =>
let
val (eo, fm) =
case eo of
@@ -318,7 +322,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(SOME e, fm)
end
in
- ((L'.ECon (n, eo), loc), fm)
+ ((L'.ECon (monoPatCon pc, eo), loc), fm)
end
| L.EFfi mx => ((L'.EFfi mx, loc), fm)
| L.EFfiApp (m, x, es) =>
@@ -416,7 +420,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val fooify =
case x of
- "Link" => urlifyExp
+ "Href" => urlifyExp
+ | "Link" => urlifyExp
| "Action" => urlifyExp
| _ => attrifyExp