diff options
Diffstat (limited to 'src/cjr_print.sml')
| -rw-r--r-- | src/cjr_print.sml | 72 |
1 files changed, 59 insertions, 13 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7ff8f60f..749f56ab 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -53,7 +53,7 @@ structure CM = BinaryMapFn(struct val debug = ref false -val dummyTyp = (TDatatype (0, []), ErrorMsg.dummySpan) +val dummyTyp = (TDatatype (Enum, 0, []), ErrorMsg.dummySpan) fun p_typ' par env (t, loc) = case t of @@ -69,7 +69,12 @@ fun p_typ' par env (t, loc) = space, string "__lws_", string (Int.toString i)] - | TDatatype (n, _) => + | TDatatype (Enum, n, _) => + (box [string "enum", + space, + string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] + handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) + | TDatatype (Default, n, _) => (box [string "struct", space, string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] @@ -103,8 +108,8 @@ fun p_pat_preamble env (p, _) = newline], env) | PPrim _ => (box [], env) - | PCon (_, NONE) => (box [], env) - | PCon (_, SOME p) => p_pat_preamble env p + | PCon (_, _, NONE) => (box [], env) + | PCon (_, _, SOME p) => p_pat_preamble env p | PRecord xps => foldl (fn ((_, p, _), (pp, env)) => let @@ -161,7 +166,7 @@ fun p_pat (env, exit, depth) (p, _) = env) | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" - | PCon (pc, po) => + | PCon (dk, pc, po) => let val (p, env) = case po of @@ -175,9 +180,10 @@ fun p_pat (env, exit, depth) (p, _) = let val (x, to, _) = E.lookupConstructor env n in - (x, to) + ("__lwc_" ^ x, to) end - | PConFfi _ => raise Fail "PConFfi" + | PConFfi {mod = m, con, arg, ...} => + ("lw_" ^ m ^ "_" ^ con, arg) val t = case to of NONE => raise Fail "CjrPrint: Constructor mismatch" @@ -194,7 +200,7 @@ fun p_pat (env, exit, depth) (p, _) = space, string "disc", string (Int.toString depth), - string "->data.__lwc_", + string "->data.", string x, string ";", newline, @@ -208,7 +214,9 @@ fun p_pat (env, exit, depth) (p, _) = space, string "(disc", string (Int.toString depth), - string "->tag", + case dk of + Enum => box [] + | Default => string "->tag", space, string "!=", space, @@ -285,7 +293,8 @@ fun p_exp' par env (e, loc) = EPrim p => Prim.p_t p | ERel n => p_rel env n | ENamed n => p_enamed env n - | ECon (pc, eo) => + | ECon (Enum, pc, _) => p_patCon env pc + | ECon (Default, pc, eo) => let val (xd, xc) = patConInfo env pc in @@ -497,7 +506,17 @@ fun p_decl env (dAll as (d, _) : decl) = string ";", newline]) xts, string "};"] - | DDatatype (x, n, xncs) => + | DDatatype (Enum, x, n, xncs) => + box [string "enum", + space, + string ("__lwe_" ^ x ^ "_" ^ Int.toString n), + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs, + space, + string "};"] + | DDatatype (Default, x, n, xncs) => let val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE | (x, n, SOME t) => SOME (x, n, t)) xncs @@ -541,7 +560,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "data;", newline]), string "};"] - end + end | DVal (x, n, t, e) => box [p_typ env t, @@ -753,7 +772,34 @@ fun p_file env (ds, ps) = string "})"] end - | TDatatype (i, _) => + | TDatatype (Enum, i, _) => + let + val (x, xncs) = E.lookupDatatype env i + + fun doEm xncs = + case xncs of + [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_" + ^ x ^ "_" ^ Int.toString i ^ ")0)") + | (x', n, to) :: rest => + box [string "((!strncmp(request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && (request[", + string (Int.toString (size x')), + string "] == 0 || request[", + string (Int.toString (size x')), + string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n), + space, + string ":", + space, + doEm rest, + string ")"] + in + doEm xncs + end + + | TDatatype (Default, i, _) => let val (x, xncs) = E.lookupDatatype env i |