Mercurial > urweb
changeset 269:fac9fae654e2
Cjrize query
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 02 Sep 2008 09:53:15 -0400 |
| parents | bacd0ba869e1 |
| children | b9b02613c0c2 |
| files | src/cjr.sml src/cjr_print.sml src/cjrize.sml |
| diffstat | 3 files changed, 108 insertions(+), 6 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Sun Aug 31 16:54:13 2008 -0400 +++ b/src/cjr.sml Tue Sep 02 09:53:15 2008 -0400 @@ -32,8 +32,7 @@ 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 @@ | 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
--- a/src/cjr_print.sml Sun Aug 31 16:54:13 2008 -0400 +++ b/src/cjr_print.sml Tue Sep 02 09:53:15 2008 -0400 @@ -34,6 +34,8 @@ open Cjr +val dummyt = (TRecord 0, ErrorMsg.dummySpan) + structure E = CjrEnv structure EM = ErrorMsg @@ -57,8 +59,7 @@ 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 @@ 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
--- a/src/cjrize.sml Sun Aug 31 16:54:13 2008 -0400 +++ b/src/cjrize.sml Tue Sep 02 09:53:15 2008 -0400 @@ -275,12 +275,63 @@ ((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