Mercurial > urweb
changeset 196:890a61991263
Lists all the way through
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 09 Aug 2008 16:48:32 -0400 |
| parents | 85b5f663bb86 |
| children | b1b9bcfd8c42 |
| files | src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/core_util.sml src/lacweb.grm src/mono.sml src/mono_env.sml src/mono_opt.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml tests/list.lac |
| diffstat | 14 files changed, 220 insertions(+), 155 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/cjr.sml Sat Aug 09 16:48:32 2008 -0400 @@ -35,7 +35,7 @@ TTop | TFun of typ * typ | TRecord of int - | TDatatype of datatype_kind * int * (string * int * typ option) list + | TDatatype of datatype_kind * int * (string * int * typ option) list ref | TFfi of string * string withtype typ = typ' located @@ -75,6 +75,7 @@ datatype decl' = DStruct of int * (string * typ) list | DDatatype of datatype_kind * string * int * (string * int * typ option) list + | DDatatypeForward of datatype_kind * string * int | 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
--- a/src/cjr_env.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/cjr_env.sml Sat Aug 09 16:48:32 2008 -0400 @@ -140,12 +140,13 @@ DDatatype (_, x, n, xncs) => let val env = pushDatatype env x n xncs - val dt = (TDatatype (classifyDatatype xncs, n, xncs), loc) + val dt = (TDatatype (classifyDatatype xncs, n, ref xncs), loc) in foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc)) env xncs end + | DDatatypeForward (_, x, n) => pushDatatype env x n [] | DStruct (n, xts) => pushStruct env n xts | DVal (x, n, t, _) => pushENamed env x n t | DFun (fx, n, args, ran, _) =>
--- a/src/cjr_print.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/cjr_print.sml Sat Aug 09 16:48:32 2008 -0400 @@ -53,7 +53,7 @@ val debug = ref false -val dummyTyp = (TDatatype (Enum, 0, []), ErrorMsg.dummySpan) +val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) fun p_typ' par env (t, loc) = case t of @@ -106,7 +106,7 @@ string (Int.toString (E.countERels env)), string ";", newline], - env) + E.pushERel env x t) | PPrim _ => (box [], env) | PCon (_, _, NONE) => (box [], env) | PCon (_, _, SOME p) => p_pat_preamble env p @@ -180,7 +180,7 @@ let val (x, to, _) = E.lookupConstructor env n in - ("__lwc_" ^ x, to) + ("lw_" ^ x, to) end | PConFfi {mod = m, con, arg, ...} => ("lw_" ^ m ^ "_" ^ con, arg) @@ -247,7 +247,7 @@ space, string "disc", string (Int.toString depth), - string ".", + string ".__lwf_", string x, string ";", newline, @@ -282,11 +282,13 @@ val (dx, _) = E.lookupDatatype env dn in ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, - "__lwc_" ^ x ^ "_" ^ Int.toString n) + "__lwc_" ^ x ^ "_" ^ Int.toString n, + "lw_" ^ x) end | PConFfi {mod = m, datatyp, con, ...} => ("lw_" ^ m ^ "_" ^ datatyp, - "lw_" ^ m ^ "_" ^ con) + "lw_" ^ m ^ "_" ^ con, + "lw_" ^ con) fun p_exp' par env (e, loc) = case e of @@ -296,7 +298,7 @@ | ECon (Enum, pc, _) => p_patCon env pc | ECon (Default, pc, eo) => let - val (xd, xc) = patConInfo env pc + val (xd, xc, xn) = patConInfo env pc in box [string "({", newline, @@ -322,7 +324,7 @@ case eo of NONE => box [] | SOME e => box [string "tmp->data.", - string xd, + string xn, space, string "=", space, @@ -493,19 +495,23 @@ fun p_decl env (dAll as (d, _) : decl) = case d of DStruct (n, xts) => - box [string "struct", - space, - string ("__lws_" ^ Int.toString n), - space, - string "{", - newline, - p_list_sep (box []) (fn (x, t) => box [p_typ env t, - space, - string "__lwf_", - string x, - string ";", - newline]) xts, - string "};"] + let + val env = E.declBinds env dAll + in + box [string "struct", + space, + string ("__lws_" ^ Int.toString n), + space, + string "{", + newline, + p_list_sep (box []) (fn (x, t) => box [p_typ env t, + space, + string "__lwf_", + string x, + string ";", + newline]) xts, + string "};"] + end | DDatatype (Enum, x, n, xncs) => box [string "enum", space, @@ -552,7 +558,7 @@ newline, p_list_sep newline (fn (x, n, t) => box [p_typ env t, space, - string ("__lwc_" ^ x), + string ("lw_" ^ x), string ";"]) xncsArgs, newline, string "}", @@ -562,6 +568,8 @@ string "};"] end + | DDatatypeForward _ => box [] + | DVal (x, n, t, e) => box [p_typ env t, space, @@ -1003,18 +1011,6 @@ newline, string "int lw_input_num(char *name) {", newline, - string "if", - space, - string "(name[0]", - space, - string "==", - space, - string "0)", - space, - string "return", - space, - string "-1;", - newline, makeSwitch (fnums, 0), string "}", newline,
--- a/src/cjrize.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/cjrize.sml Sat Aug 09 16:48:32 2008 -0400 @@ -30,6 +30,8 @@ structure L = Mono structure L' = Cjr +structure IM = IntBinaryMap + structure Sm :> sig type t @@ -61,45 +63,57 @@ end -fun cifyTyp ((t, loc), sm) = - case t of - L.TFun (t1, t2) => - let - val (t1, sm) = cifyTyp (t1, sm) - val (t2, sm) = cifyTyp (t2, sm) - in - ((L'.TFun (t1, t2), loc), sm) - end - | L.TRecord xts => - let - val old_xts = xts - val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => - let - val (t, sm) = cifyTyp (t, sm) - in - ((x, t), sm) - end) - sm xts - val (sm, si) = Sm.find (sm, old_xts, xts) - in - ((L'.TRecord si, loc), sm) - end - | L.TDatatype (dk, 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 - ((L'.TDatatype (dk, n, xncs), loc), sm) - end - | L.TFfi mx => ((L'.TFfi mx, loc), sm) +fun cifyTyp x = + let + fun cify dtmap ((t, loc), sm) = + case t of + L.TFun (t1, t2) => + let + val (t1, sm) = cify dtmap (t1, sm) + val (t2, sm) = cify dtmap (t2, sm) + in + ((L'.TFun (t1, t2), loc), sm) + end + | L.TRecord xts => + let + val old_xts = xts + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cify dtmap (t, sm) + in + ((x, t), sm) + end) + sm xts + val (sm, si) = Sm.find (sm, old_xts, xts) + in + ((L'.TRecord si, loc), sm) + end + | L.TDatatype (n, ref (dk, xncs)) => + (case IM.find (dtmap, n) of + SOME r => ((L'.TDatatype (dk, n, r), loc), sm) + | NONE => + let + val r = ref [] + val dtmap = IM.insert (dtmap, n, r) + + val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => + case to of + NONE => ((x, n, NONE), sm) + | SOME t => + let + val (t, sm) = cify dtmap (t, sm) + in + ((x, n, SOME t), sm) + end) + sm xncs + in + r := xncs; + ((L'.TDatatype (dk, n, r), loc), sm) + end) + | L.TFfi mx => ((L'.TFfi mx, loc), sm) + in + cify IM.empty x + end val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) @@ -356,22 +370,26 @@ fun cjrize ds = let - val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) => - let - val (dop, pop, sm) = cifyDecl (d, sm) - val ds = case dop of - NONE => ds - | SOME d => d :: ds - val ps = case pop of - NONE => ps - | SOME p => p :: ps - in - (ds, ps, sm) - end) - ([], [], Sm.empty) ds + val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => + let + val (dop, pop, sm) = cifyDecl (d, sm) + val (dsF, ds) = case dop of + NONE => (dsF, ds) + | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) => + ((L'.DDatatypeForward (dk, x, n), loc) :: dsF, + d :: ds) + | SOME d => (dsF, d :: ds) + val ps = case pop of + NONE => ps + | SOME p => p :: ps + in + (dsF, ds, ps, sm) + end) + ([], [], [], Sm.empty) ds in - (List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), - rev ds), + (List.revAppend (dsF, + List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), + rev ds)), ps) end
--- a/src/core_util.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/core_util.sml Sat Aug 09 16:48:32 2008 -0400 @@ -571,14 +571,20 @@ fn c' => (DCon (x, n, k', c'), loc))) | DDatatype (x, n, xs, xncs) => - S.map2 (ListUtil.mapfold (fn (x, n, c) => - case c of - NONE => S.return2 (x, n, c) - | SOME c => - S.map2 (mfc ctx c, - fn c' => (x, n, SOME c'))) xncs, - fn xncs' => - (DDatatype (x, n, xs, xncs'), loc)) + let + val k = (KType, loc) + val k' = foldl (fn (_, k') => (KArrow (k, k'), loc)) k xs + val ctx' = bind (ctx, NamedC (x, n, k', NONE)) + in + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx' c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (DDatatype (x, n, xs, xncs'), loc)) + end | DVal vi => S.map2 (mfvi ctx vi, fn vi' =>
--- a/src/lacweb.grm Sat Aug 09 12:50:49 2008 -0400 +++ b/src/lacweb.grm Sat Aug 09 16:48:32 2008 -0400 @@ -308,8 +308,8 @@ | FOLD (CFold, s (FOLDleft, FOLDright)) | UNIT (CUnit, s (UNITleft, UNITright)) -ctuple : cterm STAR cterm ([cterm1, cterm2]) - | cterm STAR ctuple (cterm :: ctuple) +ctuple : capps STAR capps ([capps1, capps2]) + | capps STAR ctuple (capps :: ctuple) rcon : ([]) | ident EQ cexp ([(ident, cexp)]) @@ -341,9 +341,7 @@ (EAbs ("_", SOME (TRecord (CRecord [], loc), loc), eexp), loc) end) - | LPAREN etuple RPAREN COLON cexp(case etuple of - [eexp] => (EAnnot (eexp, cexp), s (LPARENleft, cexpright)) - | _ => raise Fail "Multiple arguments to expression type annotation") + | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) | IF eexp THEN eexp ELSE eexp (let
--- a/src/mono.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono.sml Sat Aug 09 16:48:32 2008 -0400 @@ -34,7 +34,7 @@ datatype typ' = TFun of typ * typ | TRecord of (string * typ) list - | TDatatype of datatype_kind * int * (string * int * typ option) list + | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref | TFfi of string * string withtype typ = typ' located
--- a/src/mono_env.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono_env.sml Sat Aug 09 16:48:32 2008 -0400 @@ -98,7 +98,7 @@ DDatatype (x, n, xncs) => let val env = pushDatatype env x n xncs - val dt = (TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc) + val dt = (TDatatype (n, ref (MonoUtil.classifyDatatype xncs, xncs)), loc) in foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt NONE "" | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc) NONE "")
--- a/src/mono_opt.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono_opt.sml Sat Aug 09 16:48:32 2008 -0400 @@ -135,6 +135,11 @@ | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), (EWrite (EPrim (Prim.String s2), _), _)) => EWrite (EPrim (Prim.String (s1 ^ s2)), loc) + | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), + (ESeq ((EWrite (EPrim (Prim.String s2), _), _), + e), _)) => + ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc), + e) | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) => EPrim (Prim.String (htmlifyString s)) @@ -142,6 +147,8 @@ EWrite (EPrim (Prim.String (htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => EFfiApp ("Basis", "htmlifyString_w", [e]) + | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) => + EWrite (EPrim (Prim.String (htmlifyString s)), loc) | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (attrifyInt n))
--- a/src/mono_print.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono_print.sml Sat Aug 09 16:48:32 2008 -0400 @@ -53,7 +53,7 @@ space, p_typ env t]) xcs, string "}"] - | TDatatype (_, n, _) => + | TDatatype (n, _) => ((if !debug then string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n) else
--- a/src/mono_shake.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono_shake.sml Sat Aug 09 16:48:32 2008 -0400 @@ -58,7 +58,7 @@ fun typ (c, s) = case c of - TDatatype (_, n, _) => + TDatatype (n, _) => if IS.member (#con s, n) then s else
--- a/src/mono_util.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/mono_util.sml Sat Aug 09 16:48:32 2008 -0400 @@ -52,7 +52,7 @@ in joinL compareFields (xts1, xts2) end - | (TDatatype (_, n1, _), TDatatype (_, n2, _)) => Int.compare (n1, n2) + | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) | (TFun _, _) => LESS @@ -297,9 +297,13 @@ fn vi' => (DVal vi', loc)) | DValRec vis => - S.map2 (ListUtil.mapfold (mfvi ctx) vis, - fn vis' => - (DValRec vis', loc)) + let + val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx') vis, + fn vis' => + (DValRec vis', loc)) + end | DExport (ek, s, n, ts) => S.map2 (ListUtil.mapfold mft ts, fn ts' => @@ -350,7 +354,7 @@ DDatatype (x, n, xncs) => let val ctx = bind (ctx, Datatype (x, n, xncs)) - val t = (TDatatype (classifyDatatype xncs, n, xncs), #2 d') + val t = (TDatatype (n, ref (classifyDatatype xncs, xncs)), #2 d') in foldl (fn ((x, n, to), ctx) => let @@ -364,7 +368,7 @@ 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 + bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis | DExport _ => ctx in S.map2 (mff ctx' ds',
--- a/src/monoize.sml Sat Aug 09 12:50:49 2008 -0400 +++ b/src/monoize.sml Sat Aug 09 16:48:32 2008 -0400 @@ -33,7 +33,9 @@ structure L = Core structure L' = Mono -val dummyTyp = (L'.TDatatype (L'.Enum, 0, []), E.dummySpan) +structure IM = IntBinaryMap + +val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) fun monoName env (all as (c, loc)) = let @@ -47,46 +49,58 @@ | _ => poly () end -fun monoType env (all as (c, loc)) = +fun monoType env = let - fun poly () = - (E.errorAt loc "Unsupported type constructor"; - Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; - dummyTyp) + fun mt env dtmap (all as (c, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported type constructor"; + Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; + dummyTyp) + in + case c of + L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc) + | L.TCFun _ => poly () + | L.TRecord (L.CRecord ((L.KType, _), xcs), _) => + (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc) + | L.TRecord _ => poly () + + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + + | L.CRel _ => poly () + | L.CNamed n => + (case IM.find (dtmap, n) of + SOME r => (L'.TDatatype (n, r), loc) + | NONE => + let + val r = ref (L'.Default, []) + val (_, xs, xncs) = Env.lookupDatatype env n + + val dtmap' = IM.insert (dtmap, n, r) + + val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs + in + case xs of + [] =>(r := (MonoUtil.classifyDatatype xncs, xncs); + (L'.TDatatype (n, r), loc)) + | _ => poly () + end) + | L.CFfi mx => (L'.TFfi mx, loc) + | L.CApp _ => poly () + | L.CAbs _ => poly () + + | L.CName _ => poly () + + | L.CRecord _ => poly () + | L.CConcat _ => poly () + | L.CFold _ => poly () + | L.CUnit => poly () + end in - case c of - L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc) - | L.TCFun _ => poly () - | L.TRecord (L.CRecord ((L.KType, _), xcs), _) => - (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc) - | L.TRecord _ => poly () - - | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => - (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => - (L'.TFfi ("Basis", "string"), loc) - - | L.CRel _ => poly () - | L.CNamed n => - let - val (_, xs, xncs) = Env.lookupDatatype env n - - val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs - in - case xs of - [] => (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc) - | _ => poly () - end - | L.CFfi mx => (L'.TFfi mx, loc) - | L.CApp _ => poly () - | L.CAbs _ => poly () - - | L.CName _ => poly () - - | L.CRecord _ => poly () - | L.CConcat _ => poly () - | L.CFold _ => poly () - | L.CUnit => poly () + mt env IM.empty end val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) @@ -204,7 +218,7 @@ L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) - | L'.TDatatype (dk, i, _) => + | L'.TDatatype (i, ref (dk, _)) => let fun makeDecl n fm = let @@ -733,9 +747,10 @@ L.DCon _ => NONE | 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) + val env' = Env.declBinds env all + 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, fm, d) + SOME (env', fm, d) end | L.DDatatype _ => poly () | L.DVal (x, n, t, e, s) =>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/list.lac Sat Aug 09 16:48:32 2008 -0400 @@ -0,0 +1,19 @@ +datatype list a = Nil | Cons of a * list a + +val isNil = fn t ::: Type => fn ls : list t => + case ls of Nil => True | _ => False + +val show = fn b => if b then "True" else "False" + +val rec delist : list string -> xml body [] [] = fn x => + case x of + Nil => <body>Nil</body> + | Cons (h, t) => <body>{cdata h} :: {delist t}</body> + +val main : unit -> page = fn () => <html><body> + {cdata (show (isNil (Nil : list bool)))}, + {cdata (show (isNil (Cons (1, Nil))))}, + {cdata (show (isNil (Cons ("A", Cons ("B", Nil)))))} + + <p>{delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}</p> +</body></html>