Mercurial > urweb

annotate src/rpcify.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents 9b29ce0babb8
children e0dd85ea58e1
rev   line source
adamc@607 1 (* Copyright (c) 2009, Adam Chlipala
adamc@607 2 * All rights reserved.
adamc@607 3 *
adamc@607 4 * Redistribution and use in source and binary forms, with or without
adamc@607 5 * modification, are permitted provided that the following conditions are met:
adamc@607 6 *
adamc@607 7 * - Redistributions of source code must retain the above copyright notice,
adamc@607 8 * this list of conditions and the following disclaimer.
adamc@607 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@607 10 * this list of conditions and the following disclaimer in the documentation
adamc@607 11 * and/or other materials provided with the distribution.
adamc@607 12 * - The names of contributors may not be used to endorse or promote products
adamc@607 13 * derived from this software without specific prior written permission.
adamc@607 14 *
adamc@607 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@607 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@607 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@607 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@607 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@607 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@607 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@607 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@607 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@607 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@607 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@607 26 *)
adamc@607 27
adamc@607 28 structure Rpcify :> RPCIFY = struct
adamc@607 29
adamc@607 30 open Core
adamc@607 31
adamc@607 32 structure U = CoreUtil
adamc@607 33 structure E = CoreEnv
adamc@607 34
adamc@607 35 structure IS = IntBinarySet
adamc@607 36 structure IM = IntBinaryMap
adamc@607 37
adamc@607 38 structure SS = BinarySetFn(struct
adamc@607 39 type ord_key = string
adamc@607 40 val compare = String.compare
adamc@607 41 end)
adamc@607 42
adamc@642 43 fun multiLiftExpInExp n e =
adamc@642 44 if n = 0 then
adamc@642 45 e
adamc@642 46 else
adamc@642 47 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
adamc@642 48
adamc@607 49 val ssBasis = SS.addList (SS.empty,
adamc@607 50 ["requestHeader",
adamc@607 51 "query",
adamc@607 52 "dml",
adamc@668 53 "nextval",
adamc@679 54 "channel",
adamc@668 55 "subscribe",
adamc@668 56 "send"])
adamc@607 57
adamc@607 58 val csBasis = SS.addList (SS.empty,
adamc@679 59 ["get",
adamc@607 60 "set",
adamc@670 61 "alert",
adamc@698 62 "recv",
adamc@698 63 "sleep",
adamc@698 64 "spawn"])
adamc@607 65
adamc@607 66 type state = {
adamc@608 67 cpsed : int IM.map,
adamc@642 68 cpsed_range : con IM.map,
adamc@608 69 cps_decls : (string * int * con * exp * string) list,
adamc@608 70
adamc@608 71 exported : IS.set,
adamc@642 72 export_decls : decl list,
adamc@642 73
adamc@642 74 maxName : int
adamc@607 75 }
adamc@607 76
adamc@607 77 fun frob file =
adamc@607 78 let
adamc@650 79 fun sideish (basis, ssids) e =
adamc@679 80 U.Exp.exists {kind = fn _ => false,
adamc@679 81 con = fn _ => false,
adamc@679 82 exp = fn ENamed n => IS.member (ssids, n)
adamc@679 83 | EFfi ("Basis", x) => SS.member (basis, x)
adamc@679 84 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
adamc@679 85 | _ => false}
adamc@679 86 (U.Exp.map {kind = fn x => x,
adamc@679 87 con = fn x => x,
adamc@679 88 exp = fn ERecord _ => ERecord []
adamc@679 89 | x => x} e)
adamc@607 90
adamc@607 91 fun whichIds basis =
adamc@607 92 let
adamc@607 93 fun decl ((d, _), ssids) =
adamc@607 94 let
adamc@607 95 val impure = sideish (basis, ssids)
adamc@607 96 in
adamc@607 97 case d of
adamc@607 98 DVal (_, n, _, e, _) => if impure e then
adamc@607 99 IS.add (ssids, n)
adamc@607 100 else
adamc@607 101 ssids
adamc@607 102 | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
adamc@607 103 foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
adamc@607 104 ssids xes
adamc@607 105 else
adamc@607 106 ssids
adamc@607 107 | _ => ssids
adamc@607 108 end
adamc@607 109 in
adamc@607 110 foldl decl IS.empty file
adamc@607 111 end
adamc@607 112
adamc@607 113 val ssids = whichIds ssBasis
adamc@607 114 val csids = whichIds csBasis
adamc@607 115
adamc@642 116 fun sideish' (basis, ids) extra =
adamc@642 117 sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
adamc@642 118
adamc@642 119 val serverSide = sideish' (ssBasis, ssids)
adamc@642 120 val clientSide = sideish' (csBasis, csids)
adamc@607 121
adamc@609 122 val tfuncs = foldl
adamc@609 123 (fn ((d, _), tfuncs) =>
adamc@609 124 let
adamc@642 125 fun doOne ((x, n, t, e, _), tfuncs) =
adamc@609 126 let
adamc@642 127 val loc = #2 e
adamc@642 128
adamc@642 129 fun crawl (t, e, args) =
adamc@642 130 case (#1 t, #1 e) of
adamc@642 131 (CApp (_, ran), _) =>
adamc@642 132 SOME (x, rev args, ran, e)
adamc@642 133 | (TFun (arg, rest), EAbs (x, _, _, e)) =>
adamc@642 134 crawl (rest, e, (x, arg) :: args)
adamc@642 135 | (TFun (arg, rest), _) =>
adamc@642 136 crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
adamc@609 137 | _ => NONE
adamc@609 138 in
adamc@642 139 case crawl (t, e, []) of
adamc@609 140 NONE => tfuncs
adamc@609 141 | SOME sg => IM.insert (tfuncs, n, sg)
adamc@609 142 end
adamc@609 143 in
adamc@609 144 case d of
adamc@609 145 DVal vi => doOne (vi, tfuncs)
adamc@609 146 | DValRec vis => foldl doOne tfuncs vis
adamc@609 147 | _ => tfuncs
adamc@609 148 end)
adamc@609 149 IM.empty file
adamc@609 150
adamc@607 151 fun exp (e, st) =
adamc@649 152 let
adamc@649 153 fun getApp (e', args) =
adamc@649 154 let
adamc@649 155 val loc = #2 e'
adamc@649 156 in
adamc@642 157 case #1 e' of
adamc@642 158 ENamed n => (n, args)
adamc@642 159 | EApp (e1, e2) => getApp (e1, e2 :: args)
adamc@642 160 | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
adamc@679 161 (*Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*)
adamc@642 162 (0, []))
adamc@649 163 end
adamc@642 164
adamc@649 165 fun newRpc (trans1, trans2, st : state) =
adamc@649 166 let
adamc@649 167 val loc = #2 trans1
adamc@642 168
adamc@649 169 val (n, args) = getApp (trans1, [])
adamc@642 170
adamc@649 171 val (exported, export_decls) =
adamc@649 172 if IS.member (#exported st, n) then
adamc@649 173 (#exported st, #export_decls st)
adamc@649 174 else
adamc@649 175 (IS.add (#exported st, n),
adamc@649 176 (DExport (Rpc, n), loc) :: #export_decls st)
adamc@642 177
adamc@649 178 val st = {cpsed = #cpsed st,
adamc@649 179 cpsed_range = #cpsed_range st,
adamc@649 180 cps_decls = #cps_decls st,
adamc@642 181
adamc@649 182 exported = exported,
adamc@649 183 export_decls = export_decls,
adamc@642 184
adamc@649 185 maxName = #maxName st}
adamc@642 186
adamc@649 187 val ran =
adamc@649 188 case IM.find (tfuncs, n) of
adamc@679 189 NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
adamc@649 190 raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
adamc@649 191 | SOME (_, _, ran, _) => ran
adamc@649 192
adamc@649 193 val e' = EServerCall (n, args, trans2, ran)
adamc@649 194 in
adamc@649 195 (e', st)
adamc@649 196 end
adamc@651 197
adamc@651 198 fun newCps (t1, t2, trans1, trans2, st) =
adamc@651 199 let
adamc@651 200 val loc = #2 trans1
adamc@651 201
adamc@651 202 val (n, args) = getApp (trans1, [])
adamc@651 203
adamc@651 204 fun makeCall n' =
adamc@651 205 let
adamc@651 206 val e = (ENamed n', loc)
adamc@651 207 val e = (EApp (e, trans2), loc)
adamc@651 208 in
adamc@651 209 #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
adamc@651 210 end
adamc@651 211 in
adamc@651 212 case IM.find (#cpsed_range st, n) of
adamc@651 213 SOME kdom =>
adamc@651 214 (case args of
adamc@651 215 [] => raise Fail "Rpcify: cps'd function lacks first argument"
adamc@651 216 | ke :: args =>
adamc@651 217 let
adamc@651 218 val ke' = (EFfi ("Basis", "bind"), loc)
adamc@651 219 val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@651 220 val ke' = (ECApp (ke', kdom), loc)
adamc@651 221 val ke' = (ECApp (ke', t2), loc)
adamc@651 222 val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@651 223 val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
adamc@651 224 val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
adamc@651 225 val ke' = (EAbs ("x", kdom,
adamc@651 226 (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
adamc@651 227 ke'), loc)
adamc@651 228
adamc@651 229 val e' = (ENamed n, loc)
adamc@651 230 val e' = (EApp (e', ke'), loc)
adamc@651 231 val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
adamc@651 232 val (e', st) = doExp (e', st)
adamc@651 233 in
adamc@651 234 (#1 e', st)
adamc@651 235 end)
adamc@651 236 | NONE =>
adamc@651 237 case IM.find (#cpsed st, n) of
adamc@651 238 SOME n' => (makeCall n', st)
adamc@651 239 | NONE =>
adamc@651 240 let
adamc@651 241 val (name, fargs, ran, e) =
adamc@651 242 case IM.find (tfuncs, n) of
adamc@651 243 NONE => (Print.prefaces "BAD" [("e",
adamc@651 244 CorePrint.p_exp CoreEnv.empty (e, loc))];
adamc@651 245 raise Fail "Rpcify: Undetected transaction function [2]")
adamc@651 246 | SOME x => x
adamc@651 247
adamc@651 248 val n' = #maxName st
adamc@651 249
adamc@651 250 val st = {cpsed = IM.insert (#cpsed st, n, n'),
adamc@651 251 cpsed_range = IM.insert (#cpsed_range st, n', ran),
adamc@651 252 cps_decls = #cps_decls st,
adamc@651 253 exported = #exported st,
adamc@651 254 export_decls = #export_decls st,
adamc@651 255 maxName = n' + 1}
adamc@651 256
adamc@651 257 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@651 258 val body = (EFfi ("Basis", "bind"), loc)
adamc@651 259 val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
adamc@651 260 val body = (ECApp (body, t1), loc)
adamc@651 261 val body = (ECApp (body, unit), loc)
adamc@651 262 val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@651 263 val body = (EApp (body, e), loc)
adamc@651 264 val body = (EApp (body, (ERel (length args), loc)), loc)
adamc@651 265 val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
adamc@651 266 val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
adamc@651 267 ((EAbs (x, t, bt, body), loc),
adamc@651 268 (TFun (t, bt), loc)))
adamc@651 269 (body, bt) fargs
adamc@651 270 val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
adamc@651 271 unit),
adamc@651 272 loc)), loc)
adamc@651 273 val body = (EAbs ("k", kt, bt, body), loc)
adamc@651 274 val bt = (TFun (kt, bt), loc)
adamc@651 275
adamc@651 276 val (body, st) = doExp (body, st)
adamc@651 277
adamc@651 278 val vi = (name ^ "_cps",
adamc@651 279 n',
adamc@651 280 bt,
adamc@651 281 body,
adamc@651 282 "")
adamc@651 283
adamc@651 284 val st = {cpsed = #cpsed st,
adamc@651 285 cpsed_range = #cpsed_range st,
adamc@651 286 cps_decls = vi :: #cps_decls st,
adamc@651 287 exported = #exported st,
adamc@651 288 export_decls = #export_decls st,
adamc@651 289 maxName = #maxName st}
adamc@651 290 in
adamc@651 291 (makeCall n', st)
adamc@651 292 end
adamc@651 293 end
adamc@651 294
adamc@651 295 fun dummyK loc =
adamc@651 296 let
adamc@651 297 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@651 298
adamc@651 299 val k = (EFfi ("Basis", "return"), loc)
adamc@651 300 val k = (ECApp (k, (CFfi ("Basis", "transaction"), loc)), loc)
adamc@651 301 val k = (ECApp (k, unit), loc)
adamc@651 302 val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@651 303 val k = (EApp (k, (ERecord [], loc)), loc)
adamc@651 304 in
adamc@651 305 (EAbs ("_", unit, unit, k), loc)
adamc@651 306 end
adamc@649 307 in
adamc@649 308 case e of
adamc@649 309 EApp (
adamc@649 310 (EApp
adamc@649 311 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@649 312 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 313 (ECase (ed, pes, {disc, ...}), _)), _),
adamc@649 314 trans2) =>
adamc@649 315 let
adamc@649 316 val e' = (EFfi ("Basis", "bind"), loc)
adamc@649 317 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@649 318 val e' = (ECApp (e', t1), loc)
adamc@649 319 val e' = (ECApp (e', t2), loc)
adamc@649 320 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@649 321
adamc@649 322 val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@649 323 let
adamc@649 324 val e' = (EApp (e', e), loc)
adamc@649 325 val e' = (EApp (e',
adamc@649 326 multiLiftExpInExp (E.patBindsN p)
adamc@649 327 trans2), loc)
adamc@649 328 val (e', st) = doExp (e', st)
adamc@649 329 in
adamc@649 330 ((p, e'), st)
adamc@649 331 end) st pes
adamc@649 332 in
adamc@649 333 (ECase (ed, pes, {disc = disc,
adamc@649 334 result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
adamc@649 335 st)
adamc@649 336 end
adamc@649 337
adamc@649 338 | EApp (
adamc@649 339 (EApp
adamc@649 340 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@649 341 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 342 (EServerCall (n, es, ke, t), _)), _),
adamc@649 343 trans2) =>
adamc@649 344 let
adamc@649 345 val e' = (EFfi ("Basis", "bind"), loc)
adamc@649 346 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@649 347 val e' = (ECApp (e', t), loc)
adamc@649 348 val e' = (ECApp (e', t2), loc)
adamc@649 349 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@649 350 val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
adamc@649 351 val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
adamc@649 352 val e' = (EAbs ("x", t, t2, e'), loc)
adamc@649 353 val e' = (EServerCall (n, es, e', t), loc)
adamc@649 354 val (e', st) = doExp (e', st)
adamc@649 355 in
adamc@649 356 (#1 e', st)
adamc@649 357 end
adamc@649 358
adamc@649 359 | EApp (
adamc@649 360 (EApp
adamc@649 361 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
adamc@649 362 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 363 (EApp ((EApp
adamc@649 364 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@649 365 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 366 trans1), _), trans2), _)), _),
adamc@649 367 trans3) =>
adamc@649 368 let
adamc@649 369 val e'' = (EFfi ("Basis", "bind"), loc)
adamc@649 370 val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@649 371 val e'' = (ECApp (e'', t2), loc)
adamc@649 372 val e'' = (ECApp (e'', t3), loc)
adamc@649 373 val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@649 374 val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
adamc@649 375 val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
adamc@649 376 val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
adamc@649 377
adamc@649 378 val e' = (EFfi ("Basis", "bind"), loc)
adamc@649 379 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@649 380 val e' = (ECApp (e', t1), loc)
adamc@649 381 val e' = (ECApp (e', t3), loc)
adamc@649 382 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@649 383 val e' = (EApp (e', trans1), loc)
adamc@649 384 val e' = (EApp (e', e''), loc)
adamc@649 385 val (e', st) = doExp (e', st)
adamc@649 386 in
adamc@649 387 (#1 e', st)
adamc@649 388 end
adamc@649 389
adamc@649 390 | EApp (
adamc@649 391 (EApp
adamc@649 392 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
adamc@649 393 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 394 _), loc),
adamc@649 395 (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
adamc@649 396
adamc@649 397 | EApp (
adamc@649 398 (EApp
adamc@649 399 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@649 400 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@649 401 trans1), loc),
adamc@649 402 trans2) =>
adamc@649 403 (case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
adamc@649 404 serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
adamc@649 405 (true, false, _, true) => newRpc (trans1, trans2, st)
adamc@651 406 | (_, true, true, false) =>
adamc@651 407 (case #1 trans2 of
adamc@651 408 EAbs (x, dom, ran, trans2) =>
adamc@651 409 let
adamc@651 410 val (trans2, st) = newRpc (trans2, dummyK loc, st)
adamc@651 411 val trans2 = (EAbs (x, dom, ran, (trans2, loc)), loc)
adamc@649 412
adamc@651 413 val e = (EFfi ("Basis", "bind"), loc)
adamc@651 414 val e = (ECApp (e, (CFfi ("Basis", "transaction"), loc)), loc)
adamc@651 415 val e = (ECApp (e, t1), loc)
adamc@651 416 val e = (ECApp (e, t2), loc)
adamc@651 417 val e = (EApp (e, (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@651 418 val e = (EApp (e, trans1), loc)
adamc@651 419 val e = EApp (e, trans2)
adamc@651 420 in
adamc@651 421 (e, st)
adamc@651 422 end
adamc@651 423 | _ => (e, st))
adamc@651 424 | (true, true, _, _) => newCps (t1, t2, trans1, trans2, st)
adamc@649 425
adamc@649 426 | _ => (e, st))
adamc@642 427
adamc@649 428 | ERecord xes =>
adamc@649 429 let
adamc@649 430 val loc = case xes of
adamc@649 431 [] => ErrorMsg.dummySpan
adamc@649 432 | (_, (_, loc), _) :: _ => loc
adamc@642 433
adamc@649 434 fun candidate (x, e) =
adamc@649 435 String.isPrefix "On" x
adamc@649 436 andalso serverSide (#cpsed_range st) e
adamc@649 437 andalso not (clientSide (#cpsed_range st) e)
adamc@649 438 in
adamc@649 439 if List.exists (fn ((CName x, _), e, _) => candidate (x, e)
adamc@649 440 | _ => false) xes then
adamc@649 441 let
adamc@649 442 val (xes, st) = ListUtil.foldlMap
adamc@649 443 (fn (y as (nm as (CName x, _), e, t), st) =>
adamc@649 444 if candidate (x, e) then
adamc@649 445 let
adamc@651 446 val (e, st) = newRpc (e, dummyK loc, st)
adamc@649 447 in
adamc@649 448 ((nm, (e, loc), t), st)
adamc@649 449 end
adamc@649 450 else
adamc@649 451 (y, st)
adamc@649 452 | y => y)
adamc@649 453 st xes
adamc@649 454 in
adamc@649 455 (ERecord xes, st)
adamc@649 456 end
adamc@649 457 else
adamc@649 458 (e, st)
adamc@649 459 end
adamc@642 460
adamc@649 461 | _ => (e, st)
adamc@649 462 end
adamc@607 463
adamc@642 464 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
adamc@642 465 con = fn x => x,
adamc@642 466 exp = exp} st (ReduceLocal.reduceExp e)
adamc@642 467
adamc@607 468 fun decl (d, st : state) =
adamc@607 469 let
adamc@607 470 val (d, st) = U.Decl.foldMap {kind = fn x => x,
adamc@607 471 con = fn x => x,
adamc@607 472 exp = exp,
adamc@607 473 decl = fn x => x}
adamc@607 474 st d
adamc@607 475 in
adamc@608 476 (List.revAppend (case #cps_decls st of
adamc@608 477 [] => [d]
adamc@608 478 | ds =>
adamc@608 479 case d of
adamc@608 480 (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
adamc@608 481 | (_, loc) => [d, (DValRec ds, loc)],
adamc@608 482 #export_decls st),
adamc@608 483 {cpsed = #cpsed st,
adamc@642 484 cpsed_range = #cpsed_range st,
adamc@608 485 cps_decls = [],
adamc@608 486
adamc@608 487 exported = #exported st,
adamc@642 488 export_decls = [],
adamc@642 489
adamc@642 490 maxName = #maxName st})
adamc@607 491 end
adamc@607 492
adamc@607 493 val (file, _) = ListUtil.foldlMapConcat decl
adamc@608 494 {cpsed = IM.empty,
adamc@642 495 cpsed_range = IM.empty,
adamc@608 496 cps_decls = [],
adamc@608 497
adamc@608 498 exported = IS.empty,
adamc@642 499 export_decls = [],
adamc@642 500
adamc@642 501 maxName = U.File.maxName file + 1}
adamc@607 502 file
adamc@607 503 in
adamc@607 504 file
adamc@607 505 end
adamc@607 506
adamc@607 507 end