Mercurial > urweb
changeset 164:6847741e1f5f
Datatypes through monoize
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 29 Jul 2008 13:32:07 -0400 |
| parents | 80192edca30d |
| children | e52dfb1e6b19 |
| files | src/cjrize.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml |
| diffstat | 7 files changed, 82 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjrize.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/cjrize.sml Tue Jul 29 13:32:07 2008 -0400 @@ -160,7 +160,9 @@ 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)
--- a/src/mono.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/mono.sml Tue Jul 29 13:32:07 2008 -0400 @@ -60,7 +60,8 @@ 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
--- a/src/mono_env.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/mono_env.sml Tue Jul 29 13:32:07 2008 -0400 @@ -81,9 +81,17 @@ 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
--- a/src/mono_print.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/mono_print.sml Tue Jul 29 13:32:07 2008 -0400 @@ -162,9 +162,28 @@ 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 =>
--- a/src/mono_shake.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/mono_shake.sml Tue Jul 29 13:32:07 2008 -0400 @@ -47,13 +47,22 @@ (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 @@ 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
--- a/src/mono_util.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/mono_util.sml Tue Jul 29 13:32:07 2008 -0400 @@ -258,7 +258,16 @@ 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 @@ 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
--- a/src/monoize.sml Tue Jul 29 13:16:21 2008 -0400 +++ b/src/monoize.sml Tue Jul 29 13:32:07 2008 -0400 @@ -115,6 +115,8 @@ | 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 @@ 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 =>