Mercurial > urweb

comparison src/monoize.sml @ 1104:72670131dace

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.serialize; separate file for mhash; run transactional finishers in reverse order; set needs_sig properly
author Adam Chlipala <adamc@hcoop.net>
date Thu, 31 Dec 2009 11:41:57 -0500
parents 118ab9641a64
children 52571ca9b777
comparison
equal deleted inserted replaced
1103:2f42c61b8d0a 1104:72670131dace
159 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => 159 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
160 (L'.TFfi ("Basis", "string"), loc) 160 (L'.TFfi ("Basis", "string"), loc)
161 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 161 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
162 (L'.TFfi ("Basis", "string"), loc) 162 (L'.TFfi ("Basis", "string"), loc)
163 | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc) 163 | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc)
164
165 | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
166 (L'.TFfi ("Basis", "string"), loc)
164 167
165 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => 168 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
166 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) 169 (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
167 | L.CApp ((L.CFfi ("Basis", "source"), _), t) => 170 | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
168 (L'.TSource, loc) 171 (L'.TSource, loc)
1973 fm) 1976 fm)
1974 | L.EFfi ("Basis", "sql_client") => 1977 | L.EFfi ("Basis", "sql_client") =>
1975 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc), 1978 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
1976 (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc), 1979 (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
1977 fm) 1980 fm)
1981 | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
1982 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
1983 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
1984 fm)
1978 | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) => 1985 | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
1979 let 1986 let
1980 val t = monoType env t 1987 val t = monoType env t
1981 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc) 1988 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
1982 in 1989 in
3233 (L'.EAbs ("_", un, t, 3240 (L'.EAbs ("_", un, t,
3234 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc), 3241 (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc),
3235 fm) 3242 fm)
3236 end 3243 end
3237 3244
3245 | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) =>
3246 let
3247 val t = monoType env t
3248 val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t)
3249 in
3250 ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc),
3251 fm)
3252 end
3253 | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) =>
3254 let
3255 val t = monoType env t
3256 in
3257 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t), loc)), loc),
3258 fm)
3259 end
3260
3238 | L.EFfiApp ("Basis", "url", [e]) => 3261 | L.EFfiApp ("Basis", "url", [e]) =>
3239 let 3262 let
3240 val (e, fm) = monoExp (env, st, fm) e 3263 val (e, fm) = monoExp (env, st, fm) e
3241 in 3264 in
3242 urlifyExp env fm (e, dummyTyp) 3265 urlifyExp env fm (e, dummyTyp)
3430 in 3453 in
3431 SOME (env, 3454 SOME (env,
3432 fm, 3455 fm,
3433 [(L'.DValRec vis, loc)]) 3456 [(L'.DValRec vis, loc)])
3434 end 3457 end
3435 | L.DExport (ek, n) => 3458 | L.DExport (ek, n, b) =>
3436 let 3459 let
3437 val (_, t, _, s) = Env.lookupENamed env n 3460 val (_, t, _, s) = Env.lookupENamed env n
3438 3461
3439 fun unwind (t, args) = 3462 fun unwind (t, args) =
3440 case #1 t of 3463 case #1 t of
3445 3468
3446 val (ts, ran) = unwind (t, []) 3469 val (ts, ran) = unwind (t, [])
3447 val ts = map (monoType env) ts 3470 val ts = map (monoType env) ts
3448 val ran = monoType env ran 3471 val ran = monoType env ran
3449 in 3472 in
3450 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) 3473 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)])
3451 end 3474 end
3452 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => 3475 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
3453 let 3476 let
3454 val t = (L.CFfi ("Basis", "string"), loc) 3477 val t = (L.CFfi ("Basis", "string"), loc)
3455 val t' = (L'.TFfi ("Basis", "string"), loc) 3478 val t' = (L'.TFfi ("Basis", "string"), loc)
3536 fun monoize env file = 3559 fun monoize env file =
3537 let 3560 let
3538 (* Calculate which exported functions need cookie signature protection *) 3561 (* Calculate which exported functions need cookie signature protection *)
3539 val rcook = foldl (fn ((d, _), rcook) => 3562 val rcook = foldl (fn ((d, _), rcook) =>
3540 case d of 3563 case d of
3541 L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n) 3564 L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
3542 | L.DExport (L.Rpc L.ReadCookieWrite, n) => IS.add (rcook, n) 3565 | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
3543 | _ => rcook) 3566 | _ => rcook)
3544 IS.empty file 3567 IS.empty file
3545 val () = readCookie := rcook 3568 val () = readCookie := rcook
3546 3569
3547 val loc = E.dummySpan 3570 val loc = E.dummySpan