Mercurial > urweb
changeset 185:19ee24bffbc0
FFI datatypes
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 03 Aug 2008 17:57:47 -0400 |
| parents | 98c29e3986d3 |
| children | 88d46972de53 |
| files | src/cjr.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_print.sml src/corify.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/monoize.sml tests/caseFfi.lac |
| diffstat | 12 files changed, 156 insertions(+), 59 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/cjr.sml Sun Aug 03 17:57:47 2008 -0400 @@ -40,7 +40,7 @@ datatype patCon = PConVar of int - | PConFfi of string * string + | PConFfi of {mod : string, datatyp : string, con : string} datatype pat' = PWild @@ -55,7 +55,7 @@ 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
--- a/src/cjr_print.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/cjr_print.sml Sun Aug 03 17:57:47 2008 -0400 @@ -266,46 +266,54 @@ 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,
--- a/src/cjrize.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/cjrize.sml Sun Aug 03 17:57:47 2008 -0400 @@ -143,7 +143,7 @@ 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 @@ (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) =>
--- a/src/core.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/core.sml Sun Aug 03 17:57:47 2008 -0400 @@ -61,7 +61,7 @@ datatype patCon = PConVar of int - | PConFfi of string * string + | PConFfi of {mod : string, datatyp : string, con : string} datatype pat' = PWild @@ -76,7 +76,7 @@ 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
--- a/src/core_print.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/core_print.sml Sun Aug 03 17:57:47 2008 -0400 @@ -162,11 +162,11 @@ 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 @@ 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 ")"]
--- a/src/corify.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/corify.sml Sun Aug 03 17:57:47 2008 -0400 @@ -62,7 +62,7 @@ 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 @@ 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 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 @@ 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 @@ 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 @@ (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 @@ 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 @@ 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
--- a/src/mono.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/mono.sml Sun Aug 03 17:57:47 2008 -0400 @@ -39,7 +39,7 @@ datatype patCon = PConVar of int - | PConFfi of string * string + | PConFfi of {mod : string, datatyp : string, con : string} datatype pat' = PWild @@ -54,7 +54,7 @@ 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
--- a/src/mono_opt.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/mono_opt.sml Sun Aug 03 17:57:47 2008 -0400 @@ -185,7 +185,6 @@ | 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,
--- a/src/mono_print.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/mono_print.sml Sun Aug 03 17:57:47 2008 -0400 @@ -80,11 +80,11 @@ 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 @@ 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(",
--- a/src/mono_reduce.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/mono_reduce.sml Sun Aug 03 17:57:47 2008 -0400 @@ -79,18 +79,30 @@ 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) =
--- a/src/monoize.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/monoize.sml Sun Aug 03 17:57:47 2008 -0400 @@ -156,7 +156,13 @@ 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 @@ 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 @@ 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 @@ (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 @@ val fooify = case x of - "Link" => urlifyExp + "Href" => urlifyExp + | "Link" => urlifyExp | "Action" => urlifyExp | _ => attrifyExp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/caseFfi.lac Sun Aug 03 17:57:47 2008 -0400 @@ -0,0 +1,28 @@ +extern structure M : sig + datatype t = A | B + datatype u = C of t | D +end + +val f = fn x => case x of M.A => M.B | M.B => M.A + +val t2s = fn x => case x of M.A => "A" | M.B => "B" + +val g = fn x => case x of M.C a => M.C (f a) | M.D => M.C M.A + +val u2s = fn x => case x of M.C a => t2s a | M.D => "D" + +val page = fn x => <html><body> + {cdata (t2s x)} +</body></html> + +val page2 = fn x => <html><body> + {cdata (u2s x)} +</body></html> + +val main : unit -> page = fn () => <html><body> + <li><a link={page M.A}>A</a></li> + <li><a link={page M.B}>B</a></li> + <li><a link={page2 (M.C M.A)}>C A</a></li> + <li><a link={page2 (M.C M.B)}>C B</a></li> + <li><a link={page2 M.D}>D</a></li> +</body></html>