summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/mono.sml3
-rw-r--r--src/mono_env.sml12
-rw-r--r--src/mono_print.sml21
-rw-r--r--src/mono_shake.sml16
-rw-r--r--src/mono_util.sml28
-rw-r--r--src/monoize.sml9
7 files changed, 82 insertions, 11 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6796b467..062e2a5a 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -160,7 +160,9 @@ fun cifyExp ((e, loc), sm) =
fun cifyDecl ((d, loc), sm) =
case d of
- L.DVal (x, n, t, e, _) =>
+ L.DDatatype _ => raise Fail "Cjrize DDatatype"
+
+ | L.DVal (x, n, t, e, _) =>
let
val (t, sm) = cifyTyp (t, sm)
diff --git a/src/mono.sml b/src/mono.sml
index 13ba3adf..cdfcecd3 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -60,7 +60,8 @@ datatype exp' =
withtype exp = exp' located
datatype decl' =
- DVal of string * int * typ * exp * string
+ DDatatype of string * int * (string * int * typ option) list
+ | DVal of string * int * typ * exp * string
| DValRec of (string * int * typ * exp * string) list
| DExport of Core.export_kind * string * int * typ list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 0134b471..00f31c16 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -81,9 +81,17 @@ fun lookupENamed (env : env) n =
NONE => raise UnboundNamed n
| SOME x => x
-fun declBinds env (d, _) =
+fun declBinds env (d, loc) =
case d of
- DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
+ 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) NONE ""
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "")
+ env xncs
+ end
+ | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
| DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c485e3c8..4ab38af3 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -162,9 +162,28 @@ fun p_vali env (x, n, t, e, s) =
p_exp env e]
end
+fun p_datatype env (x, n, cons) =
+ let
+ val env = E.pushTNamed env x n NONE
+ in
+ box [string "datatype",
+ space,
+ string x,
+ space,
+ string "=",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x
+ | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x, space, string "of", space, p_typ env t])
+ cons]
+ end
+
fun p_decl env (dAll as (d, _) : decl) =
case d of
- DVal vi => box [string "val",
+ DDatatype x => p_datatype env x
+ | DVal vi => box [string "val",
space,
p_vali env vi]
| DValRec vis =>
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 76d05061..490c33c8 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -47,13 +47,22 @@ fun shake file =
(fn ((DExport (_, _, n, _), _), page_es) => n :: page_es
| (_, page_es) => page_es) [] file
- val (cdef, edef) = foldl (fn ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
+ val (cdef, edef) = foldl (fn ((DDatatype _, _), acc) => acc
+ | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
| ((DValRec vis, _), (cdef, edef)) =>
(cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
| ((DExport _, _), acc) => acc)
(IM.empty, IM.empty) file
- fun typ (_, s) = s
+ fun typ (c, s) =
+ case c of
+ TNamed n =>
+ if IS.member (#con s, n) then
+ s
+ else
+ {exp = #exp s,
+ con = IS.add (#con s, n)}
+ | _ => s
fun exp (e, s) =
case e of
@@ -80,7 +89,8 @@ fun shake file =
NONE => raise Fail "Shake: Couldn't find 'val'"
| SOME (t, e) => shakeExp s e) s page_es
in
- List.filter (fn (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
+ List.filter (fn (DDatatype (_, n, _), _) => IS.member (#con s, n)
+ | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
| (DExport _, _) => true) file
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2395cc90..1232e7dd 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -258,7 +258,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
and mfd' ctx (dAll as (d, loc)) =
case d of
- DVal vi =>
+ DDatatype (x, n, xncs) =>
+ S.map2 (ListUtil.mapfold (fn (x, n, c) =>
+ case c of
+ NONE => S.return2 (x, n, c)
+ | SOME c =>
+ S.map2 (mft c,
+ fn c' => (x, n, SOME c'))) xncs,
+ fn xncs' =>
+ (DDatatype (x, n, xncs'), loc))
+ | DVal vi =>
S.map2 (mfvi ctx vi,
fn vi' =>
(DVal vi', loc))
@@ -313,7 +322,22 @@ fun mapfoldB (all as {bind, ...}) =
let
val ctx' =
case #1 d' of
- DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
+ DDatatype (x, n, xncs) =>
+ let
+ val ctx = bind (ctx, NamedT (x, n, NONE))
+ val t = (TNamed n, #2 d')
+ in
+ foldl (fn ((x, n, to), ctx) =>
+ let
+ val t = case to of
+ NONE => t
+ | SOME t' => (TFun (t', t), #2 d')
+ in
+ bind (ctx, NamedE (x, n, t, NONE, ""))
+ end)
+ ctx xncs
+ end
+ | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
| DValRec vis => foldl (fn ((x, n, t, e, s), ctx) =>
bind (ctx, NamedE (x, n, t, SOME e, s))) ctx vis
| DExport _ => ctx
diff --git a/src/monoize.sml b/src/monoize.sml
index b17fe805..8e3bfaba 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -115,6 +115,8 @@ fun fooifyExp name env =
| L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
| L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
+ | L'.TNamed _ => (L'.EPrim (Prim.String ""), loc)
+
| _ => (E.errorAt loc "Don't know how to encode attribute type";
Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
dummyExp)
@@ -453,7 +455,12 @@ fun monoDecl env (all as (d, loc)) =
in
case d of
L.DCon _ => NONE
- | L.DDatatype _ => raise Fail "Monoize DDatatype"
+ | L.DDatatype (x, n, xncs) =>
+ let
+ val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
+ in
+ SOME (Env.declBinds env all, d)
+ end
| L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
(L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
| L.DValRec vis =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 09:43:53 +0000