summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-09 19:23:31 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-09 19:23:31 -0400
commit0186af3d727b1b92e7b63925500a21d5e412d7b4 (patch)
tree6f836a2c222f87f521569b4110e0422d4291d37a /src/cjr_print.sml
parent3232399b3893f93678a2d1a519bd0d4011275dba (diff)
'Option' datatype encoding
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml164
1 files changed, 152 insertions, 12 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 6d115fd1..be13461e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -74,6 +74,14 @@ fun p_typ' par env (t, loc) =
space,
string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
+ | TDatatype (Option, n, xncs) =>
+ (case ListUtil.search #3 (!xncs) of
+ NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
+ | SOME t =>
+ case #1 t of
+ TDatatype _ => p_typ' par env t
+ | _ => box [p_typ' par env t,
+ string "*"])
| TDatatype (Default, n, _) =>
(box [string "struct",
space,
@@ -198,10 +206,18 @@ fun p_pat (env, exit, depth) (p, _) =
space,
string "=",
space,
- string "disc",
- string (Int.toString depth),
- string "->data.",
- string x,
+ case dk of
+ Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
+ | Default => box [string "disc",
+ string (Int.toString depth),
+ string "->data.",
+ string x]
+ | Option =>
+ case #1 t of
+ TDatatype _ => box [string "disc",
+ string (Int.toString depth)]
+ | _ => box [string "*disc",
+ string (Int.toString depth)],
string ";",
newline,
p,
@@ -214,13 +230,24 @@ fun p_pat (env, exit, depth) (p, _) =
space,
string "(disc",
string (Int.toString depth),
- case dk of
- Enum => box []
- | Default => string "->tag",
- space,
- string "!=",
- space,
- p_patCon env pc,
+ case (dk, po) of
+ (Enum, _) => box [space,
+ string "!=",
+ space,
+ p_patCon env pc]
+ | (Default, _) => box [string "->tag",
+ space,
+ string "!=",
+ space,
+ p_patCon env pc]
+ | (Option, NONE) => box [space,
+ string "!=",
+ space,
+ string "NULL"]
+ | (Option, SOME _) => box [space,
+ string "==",
+ space,
+ string "NULL"],
string ")",
space,
exit,
@@ -296,6 +323,41 @@ fun p_exp' par env (e, loc) =
| ERel n => p_rel env n
| ENamed n => p_enamed env n
| ECon (Enum, pc, _) => p_patCon env pc
+ | ECon (Option, pc, NONE) => string "NULL"
+ | ECon (Option, pc, SOME e) =>
+ let
+ val to = case pc of
+ PConVar n => #2 (E.lookupConstructor env n)
+ | PConFfi {arg, ...} => arg
+
+ val t = case to of
+ NONE => raise Fail "CjrPrint: ECon argument status mismatch"
+ | SOME t => t
+ in
+ case #1 t of
+ TDatatype _ => p_exp' par env e
+ | _ => box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "lw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ p_exp' par env e,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
+ end
| ECon (Default, pc, eo) =>
let
val (xd, xc, xn) = patConInfo env pc
@@ -522,6 +584,7 @@ fun p_decl env (dAll as (d, _) : decl) =
p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
space,
string "};"]
+ | DDatatype (Option, _, _, _) => box []
| DDatatype (Default, x, n, xncs) =>
let
val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
@@ -807,6 +870,79 @@ fun p_file env (ds, ps) =
doEm xncs
end
+ | TDatatype (Option, i, xncs) =>
+ let
+ val (x, _) = E.lookupDatatype env i
+
+ val (no_arg, has_arg, t) =
+ case !xncs of
+ [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
+ (no_arg, has_arg, t)
+ | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
+ (no_arg, has_arg, t)
+ | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
+ in
+ box [string "(request[0] == '/' ? ++request : request,",
+ newline,
+ string "((!strncmp(request, \"",
+ string no_arg,
+ string "\", ",
+ string (Int.toString (size no_arg)),
+ string ") && (request[",
+ string (Int.toString (size no_arg)),
+ string "] == 0 || request[",
+ string (Int.toString (size no_arg)),
+ string "] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size no_arg)),
+ string ", NULL) : ((!strncmp(request, \"",
+ string has_arg,
+ string "\", ",
+ string (Int.toString (size has_arg)),
+ string ") && (request[",
+ string (Int.toString (size has_arg)),
+ string "] == 0 || request[",
+ string (Int.toString (size has_arg)),
+ string "] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size has_arg)),
+ string ", ",
+
+ case #1 t of
+ TDatatype _ => unurlify t
+ | _ => box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "lw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ unurlify t,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"],
+ string ")",
+ newline,
+ string ":",
+ space,
+ string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
+ end
+
| TDatatype (Default, i, _) =>
let
val (x, xncs) = E.lookupDatatype env i
@@ -955,7 +1091,11 @@ fun p_file env (ds, ps) =
string (String.toString s),
string "\", ",
string (Int.toString (size s)),
- string ")) {",
+ string ") && (request[",
+ string (Int.toString (size s)),
+ string "] == 0 || request[",
+ string (Int.toString (size s)),
+ string "] == '/')) {",
newline,
string "request += ",
string (Int.toString (size s)),