diff options
| -rw-r--r-- | src/cjr.sml | 2 | ||||
| -rw-r--r-- | src/cjr_env.sml | 7 | ||||
| -rw-r--r-- | src/cjr_print.sml | 15 | ||||
| -rw-r--r-- | src/cjrize.sml | 31 | ||||
| -rw-r--r-- | src/monoize.sml | 7 | ||||
| -rw-r--r-- | tests/plink2.lac | 8 |
6 files changed, 49 insertions, 21 deletions
diff --git a/src/cjr.sml b/src/cjr.sml index c262e326..363fa762 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -57,7 +57,7 @@ withtype exp = exp' located datatype decl' = DStruct of int * (string * typ) list | DVal of string * int * typ * exp - | DFun of string * int * string * typ * typ * exp + | DFun of string * int * (string * typ) list * typ * exp withtype decl = decl' located diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 686c99b1..bad365a5 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -119,7 +119,12 @@ fun lookupStruct (env : env) n = fun declBinds env (d, loc) = case d of DVal (x, n, t, _) => pushENamed env x n t - | DFun (fx, n, _, dom, ran, _) => pushENamed env fx n (TFun (dom, ran), loc) + | DFun (fx, n, args, ran, _) => + let + val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args + in + pushENamed env fx n t + end | DStruct (n, xts) => pushStruct env n xts end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index a3796686..991315e5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -149,19 +149,22 @@ fun p_decl env ((d, _) : decl) = space, p_exp env e, string ";"] - | DFun (fx, n, x, dom, ran, e) => + | DFun (fx, n, args, ran, e) => let - val env' = E.pushERel env x dom + val nargs = length args + val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args in box [string "static", space, p_typ env ran, space, string ("__lwn_" ^ fx ^ "_" ^ Int.toString n), - string "(lw_context ctx, ", - p_typ env dom, - space, - p_rel env' 0, + string "(", + p_list_sep (box [string ",", space]) (fn x => x) + (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => + box [p_typ env dom, + space, + p_rel env' (nargs - i - 1)]) args), string ")", space, string "{", diff --git a/src/cjrize.sml b/src/cjrize.sml index e14f7db1..dcbfbce3 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -165,16 +165,27 @@ fun cifyDecl ((d, loc), sm) = val (t, sm) = cifyTyp (t, sm) val (d, sm) = case #1 t of - L'.TFun (dom, ran) => - (case #1 e of - L.EAbs (ax, _, _, e) => - let - val (e, sm) = cifyExp (e, sm) - in - (L'.DFun (x, n, ax, dom, ran, e), sm) - end - | _ => (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; - (L'.DVal ("", 0, t, (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)), sm))) + L'.TFun _ => + let + fun unravel (tAll as (t, _), eAll as (e, _)) = + case (t, e) of + (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) => + let + val (args, t, e) = unravel (ran, e) + in + ((ax, dom) :: args, t, e) + end + | (L'.TFun _, _) => + (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; + ([], tAll, eAll)) + | _ => ([], tAll, eAll) + + val (args, ran, e) = unravel (t, e) + val (e, sm) = cifyExp (e, sm) + in + (L'.DFun (x, n, args, ran, e), sm) + end + | _ => let val (e, sm) = cifyExp (e, sm) diff --git a/src/monoize.sml b/src/monoize.sml index b5d9099f..b314d1d6 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -98,9 +98,10 @@ fun fooifyExp name env = case (args, ft) of ([], _) => e | (arg :: args, (L'.TFun (t, ft), _)) => - (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), - fooify (arg, t)), loc)), loc) + attrify (args, ft, + (L'.EStrcat (e, + (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + fooify (arg, t)), loc)), loc)) | _ => (E.errorAt loc "Type mismatch encoding attribute"; e) in diff --git a/tests/plink2.lac b/tests/plink2.lac new file mode 100644 index 00000000..22cd9094 --- /dev/null +++ b/tests/plink2.lac @@ -0,0 +1,8 @@ +val pA = fn size1 => fn size2 => <html><body> + <font size={size1}>Hello</font> <font size={size2}>World!</font> +</body></html> + +val main = fn () => <html><body> + <li> <a link={pA 5 10}>Size 5</a></li> + <li> <a link={pA 10 5}>Size 10</a></li> +</body></html> |