summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-07-29 13:50:53 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-07-29 13:50:53 -0400
commit166bccac16d35d8a4b75a4c04c7479b389a81c4f (patch)
tree0674876271c5e871d53bb786e88dd1d2049bdb02
parentac7c66e703f70f57c59697fd90504539c475244d (diff)
Datatypes through cjrize, modulo decoding
-rw-r--r--src/cjr.sml1
-rw-r--r--src/cjr_env.sml13
-rw-r--r--src/cjr_print.sml49
-rw-r--r--src/cjrize.sml15
4 files changed, 74 insertions, 4 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index 129ff4e9..621ccf45 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -56,6 +56,7 @@ withtype exp = exp' located
datatype decl' =
DStruct of int * (string * typ) list
+ | DDatatype of string * int * (string * int * typ option) list
| DVal of string * int * typ * exp
| DFun of string * int * (string * typ) list * typ * exp
| DFunRec of (string * int * (string * typ) list * typ * exp) list
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index a44359db..0d34b98f 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -118,7 +118,16 @@ fun lookupStruct (env : env) n =
fun declBinds env (d, loc) =
case d of
- DVal (x, n, t, _) => pushENamed env x n t
+ DDatatype (x, n, xncs) =>
+ let
+ val env = pushTNamed env x n NONE
+ in
+ foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc)
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc))
+ env xncs
+ end
+ | DStruct (n, xts) => pushStruct env n xts
+ | DVal (x, n, t, _) => pushENamed env x n t
| DFun (fx, n, args, ran, _) =>
let
val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args
@@ -132,6 +141,6 @@ fun declBinds env (d, loc) =
in
pushENamed env fx n t
end) env vis
- | DStruct (n, xts) => pushStruct env n xts
+
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f483d400..c9dfc481 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -70,7 +70,9 @@ fun p_typ' par env (t, loc) =
string "__lws_",
string (Int.toString i)]
| TNamed n =>
- (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
+ (box [string "struct",
+ space,
+ string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n ^ "*")]
handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "lw_", string m, string "_", string x]
@@ -191,6 +193,51 @@ fun p_decl env (dAll as (d, _) : decl) =
string ";",
newline]) xts,
string "};"]
+ | DDatatype (x, n, xncs) =>
+ let
+ val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
+ | (x, n, SOME t) => SOME (x, n, t)) xncs
+ in
+ 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 "};",
+ newline,
+ newline,
+ string "struct",
+ space,
+ string ("_lwd_" ^ x ^ "_" ^ Int.toString n),
+ space,
+ string "{",
+ newline,
+ string "enum",
+ space,
+ string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
+ space,
+ string "tag;",
+ newline,
+ box (case xncsArgs of
+ [] => []
+ | _ => [string "union",
+ space,
+ string "{",
+ newline,
+ p_list_sep newline (fn (x, n, t) => box [p_typ env t,
+ space,
+ string ("__lwc_" ^ x),
+ string ";"]) xncsArgs,
+ newline,
+ string "}",
+ space,
+ string "data;",
+ newline]),
+ string "};"]
+ end
| DVal (x, n, t, e) =>
box [p_typ env t,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 062e2a5a..c60ff75f 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -160,7 +160,20 @@ fun cifyExp ((e, loc), sm) =
fun cifyDecl ((d, loc), sm) =
case d of
- L.DDatatype _ => raise Fail "Cjrize DDatatype"
+ L.DDatatype (x, n, xncs) =>
+ let
+ val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
+ case to of
+ NONE => ((x, n, NONE), sm)
+ | SOME t =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, n, SOME t), sm)
+ end) sm xncs
+ in
+ (SOME (L'.DDatatype (x, n, xncs), loc), NONE, sm)
+ end
| L.DVal (x, n, t, e, _) =>
let