# HG changeset patch # User Adam Chlipala # Date 1217776653 14400 # Node ID 31dfab1d405070d58402ff455426263a34ee7634 # Parent c7a5c8e0a0e0522f6874df0e57bc277a457fc0e5 Cjrize ECon diff -r c7a5c8e0a0e0 -r 31dfab1d4050 src/cjr.sml --- a/src/cjr.sml Sun Aug 03 11:03:35 2008 -0400 +++ b/src/cjr.sml Sun Aug 03 11:17:33 2008 -0400 @@ -38,10 +38,24 @@ withtype typ = typ' located +datatype patCon = + PConVar of int + | PConFfi of string * string + +datatype pat' = + PWild + | PVar of string + | PPrim of Prim.t + | PCon of patCon * pat option + | PRecord of (string * pat) list + +withtype pat = pat' located + datatype exp' = EPrim of Prim.t | ERel of int | ENamed of int + | ECon of int * exp option | EFfi of string * string | EFfiApp of string * string * exp list | EApp of exp * exp @@ -49,6 +63,8 @@ | ERecord of int * (string * exp) list | EField of exp * string + | ECase of exp * (pat * exp) list * typ + | EWrite of exp | ESeq of exp * exp diff -r c7a5c8e0a0e0 -r 31dfab1d4050 src/cjr_env.sig --- a/src/cjr_env.sig Sun Aug 03 11:03:35 2008 -0400 +++ b/src/cjr_env.sig Sun Aug 03 11:17:33 2008 -0400 @@ -39,6 +39,8 @@ val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list + val lookupConstructor : env -> int -> string * Cjr.typ option * int + val pushERel : env -> string -> Cjr.typ -> env val lookupERel : env -> int -> string * Cjr.typ val listERels : env -> (string * Cjr.typ) list diff -r c7a5c8e0a0e0 -r 31dfab1d4050 src/cjr_env.sml --- a/src/cjr_env.sml Sun Aug 03 11:03:35 2008 -0400 +++ b/src/cjr_env.sml Sun Aug 03 11:17:33 2008 -0400 @@ -39,6 +39,7 @@ type env = { datatypes : (string * (string * int * typ option) list) IM.map, + constructors : (string * typ option * int) IM.map, numRelE : int, relE : (string * typ) list, @@ -49,6 +50,7 @@ val empty = { datatypes = IM.empty, + constructors = IM.empty, numRelE = 0, relE = [], @@ -59,6 +61,9 @@ fun pushDatatype (env : env) x n xncs = {datatypes = IM.insert (#datatypes env, n, (x, xncs)), + constructors = foldl (fn ((x, n, to), constructors) => + IM.insert (constructors, n, (x, to, n))) + (#constructors env) xncs, numRelE = #numRelE env, relE = #relE env, @@ -71,8 +76,14 @@ NONE => raise UnboundNamed n | SOME x => x +fun lookupConstructor (env : env) n = + case IM.find (#constructors env, n) of + NONE => raise UnboundNamed n + | SOME x => x + fun pushERel (env : env) x t = {datatypes = #datatypes env, + constructors = #constructors env, numRelE = #numRelE env + 1, relE = (x, t) :: #relE env, @@ -90,6 +101,7 @@ fun pushENamed (env : env) x n t = {datatypes = #datatypes env, + constructors = #constructors env, numRelE = #numRelE env, relE = #relE env, @@ -104,6 +116,7 @@ fun pushStruct (env : env) n xts = {datatypes = #datatypes env, + constructors = #constructors env, numRelE = #numRelE env, relE = #relE env, diff -r c7a5c8e0a0e0 -r 31dfab1d4050 src/cjr_print.sml --- a/src/cjr_print.sml Sun Aug 03 11:03:35 2008 -0400 +++ b/src/cjr_print.sml Sun Aug 03 11:17:33 2008 -0400 @@ -90,6 +90,51 @@ EPrim p => Prim.p_t p | ERel n => p_rel env n | ENamed n => p_enamed env n + | ECon (n, eo) => + let + val (x, _, dn) = E.lookupConstructor env n + val (dx, _) = E.lookupDatatype env dn + in + box [string "{(", + newline, + string "struct", + space, + string "__lwd_", + string dx, + string "_", + string (Int.toString dn), + space, + string "*tmp", + space, + string "=", + space, + string "lw_malloc(ctx, sizeof(struct __lwd_", + string dx, + string "_", + string (Int.toString dn), + string "));", + newline, + string "tmp->tag", + space, + string "=", + space, + string ("__lwc_" ^ x ^ "_" ^ Int.toString n), + string ";", + newline, + case eo of + NONE => box [] + | SOME e => box [string "tmp->data.", + string x, + space, + string "=", + space, + p_exp env e, + string ";", + newline], + string "tmp;", + newline, + string "})"] + end | EFfi (m, x) => box [string "lw_", string m, string "_", string x] | EFfiApp (m, x, es) => box [string "lw_", @@ -121,7 +166,7 @@ space, string ("__lws_" ^ Int.toString i), space, - string "__lw_tmp", + string "tmp", space, string "=", space, @@ -130,7 +175,7 @@ p_exp env e) xes, string "};", space, - string "__lw_tmp;", + string "tmp;", space, string "})" ] | EField (e, x) => @@ -138,6 +183,8 @@ string ".", string x] + | ECase _ => raise Fail "CjrPrint ECase" + | EWrite e => box [string "(lw_write(ctx, ", p_exp env e, string "), lw_unit_v)"] @@ -430,7 +477,7 @@ string "__lws_", string (Int.toString i), space, - string "__lw_tmp", + string "tmp", space, string "=", space, @@ -440,7 +487,7 @@ space, string "};", newline, - string "__lw_tmp;", + string "tmp;", newline, string "})"] end @@ -467,13 +514,13 @@ space, string ("__lwd_" ^ x ^ "_" ^ Int.toString i), space, - string "*__lw_tmp = lw_malloc(ctx, sizeof(struct __lwd_", + string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_", string x, string "_", string (Int.toString i), string "));", newline, - string "__lw_tmp->tag", + string "tmp->tag", space, string "=", space, @@ -491,7 +538,7 @@ newline, case to of NONE => box [] - | SOME t => box [string "__lw_tmp->data.", + | SOME t => box [string "tmp->data.", string x', space, string "=", @@ -499,7 +546,7 @@ unurlify t, string ";", newline], - string "__lw_tmp;", + string "tmp;", newline, string "})", space, diff -r c7a5c8e0a0e0 -r 31dfab1d4050 src/cjrize.sml --- a/src/cjrize.sml Sun Aug 03 11:03:35 2008 -0400 +++ b/src/cjrize.sml Sun Aug 03 11:17:33 2008 -0400 @@ -103,12 +103,38 @@ val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) +fun cifyPatCon pc = + case pc of + L.PConVar n => L'.PConVar n + | L.PConFfi mx => L'.PConFfi mx + +fun cifyPat (p, loc) = + case p of + L.PWild => (L'.PWild, loc) + | L.PVar x => (L'.PVar x, loc) + | L.PPrim p => (L'.PPrim p, loc) + | L.PCon (pc, po) => (L'.PCon (cifyPatCon pc, Option.map cifyPat po), loc) + | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, cifyPat p)) xps), loc) + 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.ECon _ => raise Fail "Cjrize ECon" + | L.ECon (n, eo) => + let + val (eo, sm) = + case eo of + NONE => (NONE, sm) + | SOME e => + let + val (e, sm) = cifyExp (e, sm) + in + (SOME e, sm) + end + in + ((L'.ECon (n, eo), loc), sm) + end | L.EFfi mx => ((L'.EFfi mx, loc), sm) | L.EFfiApp (m, x, es) => let @@ -153,7 +179,20 @@ ((L'.EField (e, x), loc), sm) end - | L.ECase _ => raise Fail "Cjrize ECase" + | L.ECase (e, pes, t) => + let + val (e, sm) = cifyExp (e, sm) + val (pes, sm) = ListUtil.foldlMap + (fn ((p, e), sm) => + let + val (e, sm) = cifyExp (e, sm) + in + ((cifyPat p, e), sm) + end) sm pes + val (t, sm) = cifyTyp (t, sm) + in + ((L'.ECase (e, pes, t), loc), sm) + end | L.EStrcat (e1, e2) => let