diff options
| -rw-r--r-- | src/cjr.sml | 12 | ||||
| -rw-r--r-- | src/cjr_print.sml | 47 | ||||
| -rw-r--r-- | src/cjrize.sml | 55 |
3 files changed, 108 insertions, 6 deletions
diff --git a/src/cjr.sml b/src/cjr.sml index cda7245a..e9b89bfc 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -32,8 +32,7 @@ type 'a located = 'a ErrorMsg.located datatype datatype_kind = datatype Mono.datatype_kind datatype typ' = - TTop - | TFun of typ * typ + TFun of typ * typ | TRecord of int | TDatatype of datatype_kind * int * (string * int * typ option) list ref | TFfi of string * string @@ -69,6 +68,15 @@ datatype exp' = | EWrite of exp | ESeq of exp * exp + | ELet of string * typ * exp * exp + + | EQuery of { exps : (string * typ) list, + tables : (string * (string * typ) list) list, + rnum : int, + state : typ, + query : exp, + body : exp, + initial : exp } withtype exp = exp' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 115f09fc..4a65cd34 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -34,6 +34,8 @@ open Print open Cjr +val dummyt = (TRecord 0, ErrorMsg.dummySpan) + structure E = CjrEnv structure EM = ErrorMsg @@ -57,8 +59,7 @@ val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) fun p_typ' par env (t, loc) = case t of - TTop => string "void*" - | TFun (t1, t2) => parenIf par (box [p_typ' true env t2, + TFun (t1, t2) => parenIf par (box [p_typ' true env t2, space, string "(*)", space, @@ -528,6 +529,48 @@ fun p_exp' par env (e, loc) = space, p_exp env e2, string ")"] + | ELet (x, t, e1, e2) => box [string "({", + newline, + p_typ env t, + space, + p_rel env 0, + space, + string "=", + space, + p_exp env e1, + string ";", + newline, + p_exp (E.pushERel env x t) e2, + string ";", + newline, + string "})"] + + | EQuery {exps, tables, rnum, state, query, body, initial} => + box [string "query[", + p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, + string "] [", + p_list (fn (x, xts) => box [string x, + space, + string ":", + space, + string "{", + p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts, + string "}"]) tables, + string "] [", + p_typ env state, + string "] [", + string (Int.toString rnum), + string "]", + space, + p_exp env query, + space, + string "initial", + space, + p_exp env initial, + space, + string "in", + space, + p_exp (E.pushERel (E.pushERel env "r" dummyt) "acc" dummyt) body] and p_exp env = p_exp' false env diff --git a/src/cjrize.sml b/src/cjrize.sml index 7dbabe74..29182e2c 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -275,12 +275,63 @@ fun cifyExp ((e, loc), sm) = ((L'.ESeq (e1, e2), loc), sm) end - | L.ELet _ => raise Fail "Cjrize ELet" + | L.ELet (x, t, e1, e2) => + let + val (t, sm) = cifyTyp (t, sm) + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ELet (x, t, e1, e2), loc), sm) + end | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; (dummye, sm)) - | L.EQuery _ => raise Fail "Cjrize EQuery" + | L.EQuery {exps, tables, state, query, body, initial} => + let + val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm exps + val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) => + let + val (xts, sm) = ListUtil.foldlMap + (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + in + ((x, xts), sm) + end) sm tables + + val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables + val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row + + val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) => + let + val (sm, rnum) = Sm.find (sm, xts, xts') + in + ((x, rnum), sm) + end) + sm (ListPair.zip (tables, tables')) + val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows + val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row' + + val (sm, rnum) = Sm.find (sm, row, row') + + val (state, sm) = cifyTyp (state, sm) + val (query, sm) = cifyExp (query, sm) + val (body, sm) = cifyExp (body, sm) + val (initial, sm) = cifyExp (initial, sm) + in + ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state, + query = query, body = body, initial = initial}, loc), sm) + end + fun cifyDecl ((d, loc), sm) = case d of |