Mercurial > urweb

annotate src/rpcify.sml @ 711:7292bcb7c02d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Made type class system very general; demo compiles
author Adam Chlipala <adamc@hcoop.net>
date Thu, 09 Apr 2009 12:31:56 -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