Mercurial > urweb

comparison src/monoize.sml @ 764:7f653298dd66

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
C FFI compiler options
author Adam Chlipala <adamc@hcoop.net>
date Thu, 30 Apr 2009 17:15:14 -0400
parents 16b34dc2e29c
children a8bdd5a0d9b0
comparison
equal deleted inserted replaced
763:af41ec2f302a 764:7f653298dd66
33 structure L = Core 33 structure L = Core
34 structure L' = Mono 34 structure L' = Mono
35 35
36 structure IM = IntBinaryMap 36 structure IM = IntBinaryMap
37 structure IS = IntBinarySet 37 structure IS = IntBinarySet
38
39 val urlPrefix = ref "/"
40 38
41 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) 39 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
42 40
43 structure U = MonoUtil 41 structure U = MonoUtil
44 42
374 case #1 e of 372 case #1 e of
375 L'.EClosure (fnam, [(L'.ERecord [], _)]) => 373 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
376 let 374 let
377 val (_, _, _, s) = Env.lookupENamed env fnam 375 val (_, _, _, s) = Env.lookupENamed env fnam
378 in 376 in
379 ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm) 377 ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
380 end 378 end
381 | L'.EClosure (fnam, args) => 379 | L'.EClosure (fnam, args) =>
382 let 380 let
383 val (_, ft, _, s) = Env.lookupENamed env fnam 381 val (_, ft, _, s) = Env.lookupENamed env fnam
384 val ft = monoType env ft 382 val ft = monoType env ft
397 fm) 395 fm)
398 end 396 end
399 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 397 | _ => (E.errorAt loc "Type mismatch encoding attribute";
400 (e, fm)) 398 (e, fm))
401 in 399 in
402 attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm) 400 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
403 end 401 end
404 | _ => 402 | _ =>
405 case t of 403 case t of
406 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) 404 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
407 405
1255 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t) 1253 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
1256 in 1254 in
1257 ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc), 1255 ((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc),
1258 (L'.EAbs ("v", t, (L'.TFun (un, un), loc), 1256 (L'.EAbs ("v", t, (L'.TFun (un, un), loc),
1259 (L'.EAbs ("_", un, un, 1257 (L'.EAbs ("_", un, un,
1260 (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String (!urlPrefix)), 1258 (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String
1259 (Settings.getUrlPrefix ())),
1261 loc), 1260 loc),
1262 (L'.ERel 2, loc), 1261 (L'.ERel 2, loc),
1263 e]), loc)), 1262 e]), loc)),
1264 loc)), loc)), loc), 1263 loc)), loc)), loc),
1265 fm) 1264 fm)
3136 3135
3137 datatype expungable = Client | Channel 3136 datatype expungable = Client | Channel
3138 3137
3139 fun monoize env file = 3138 fun monoize env file =
3140 let 3139 let
3141 val p = !urlPrefix 3140
3142 val () =
3143 if p = "" then
3144 urlPrefix := "/"
3145 else if String.sub (p, size p - 1) <> #"/" then
3146 urlPrefix := p ^ "/"
3147 else
3148 ()
3149 3141
3150 (* Calculate which exported functions need cookie signature protection *) 3142 (* Calculate which exported functions need cookie signature protection *)
3151 val rcook = foldl (fn ((d, _), rcook) => 3143 val rcook = foldl (fn ((d, _), rcook) =>
3152 case d of 3144 case d of
3153 L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n) 3145 L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n)