Mercurial > urweb

annotate src/cjrize.sml @ 1591:20f898c29525

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweaks to choices of source positions to use in error messages, including for subSgn
author Adam Chlipala <adam@chlipala.net>
date Sat, 05 Nov 2011 13:12:07 -0400
parents 36f7d1debb37
children 78e0d56b594e
rev   line source
adam@1348 1 (* Copyright (c) 2008-2010, Adam Chlipala
adamc@29 2 * All rights reserved.
adamc@29 3 *
adamc@29 4 * Redistribution and use in source and binary forms, with or without
adamc@29 5 * modification, are permitted provided that the following conditions are met:
adamc@29 6 *
adamc@29 7 * - Redistributions of source code must retain the above copyright notice,
adamc@29 8 * this list of conditions and the following disclaimer.
adamc@29 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29 10 * this list of conditions and the following disclaimer in the documentation
adamc@29 11 * and/or other materials provided with the distribution.
adamc@29 12 * - The names of contributors may not be used to endorse or promote products
adamc@29 13 * derived from this software without specific prior written permission.
adamc@29 14 *
adamc@29 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@29 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@29 26 *)
adamc@29 27
adamc@29 28 structure Cjrize :> CJRIZE = struct
adamc@29 29
adamc@109 30 structure L = Mono
adamc@29 31 structure L' = Cjr
adamc@29 32
adamc@196 33 structure IM = IntBinaryMap
adamc@196 34
adamc@29 35 structure Sm :> sig
adamc@29 36 type t
adamc@29 37
adamc@29 38 val empty : t
adamc@29 39 val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
adamc@757 40 val findList : t * L.typ * L'.typ -> t * int
adamc@29 41
adamc@29 42 val declares : t -> (int * (string * L'.typ) list) list
adamc@453 43 val clearDeclares : t -> t
adamc@29 44 end = struct
adamc@29 45
adamc@29 46 structure FM = BinaryMapFn(struct
adamc@29 47 type ord_key = L.typ
adamc@109 48 val compare = MonoUtil.Typ.compare
adamc@29 49 end)
adamc@29 50
adamc@757 51 type t = {
adamc@757 52 count : int,
adamc@757 53 normal : int FM.map,
adamc@757 54 lists : int FM.map,
adamc@757 55 decls : (int * (string * L'.typ) list) list
adamc@757 56 }
adamc@29 57
adamc@757 58 val empty : t = {
adamc@757 59 count = 1,
adamc@757 60 normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0),
adamc@757 61 lists = FM.empty,
adamc@757 62 decls = []
adamc@757 63 }
adamc@29 64
adamc@757 65 fun find (v as {count, normal, decls, lists}, xts, xts') =
adamc@29 66 let
adamc@29 67 val t = (L.TRecord xts, ErrorMsg.dummySpan)
adamc@29 68 in
adamc@757 69 case FM.find (normal, t) of
adamc@757 70 SOME i => (v, i)
adamc@757 71 | NONE => ({count = count+1,
adamc@757 72 normal = FM.insert (normal, t, count),
adamc@757 73 lists = lists,
adamc@757 74 decls = (count, xts') :: decls},
adamc@757 75 count)
adamc@29 76 end
adamc@29 77
adamc@757 78 fun findList (v as {count, normal, decls, lists}, t, t') =
adamc@757 79 case FM.find (lists, t) of
adamc@757 80 SOME i => (v, i)
adamc@757 81 | NONE =>
adamc@757 82 let
adamc@757 83 val xts = [("1", t), ("2", (L.TList t, #2 t))]
adamc@757 84 val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))]
adamc@757 85 in
adamc@757 86 ({count = count+1,
adamc@757 87 normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count),
adamc@757 88 lists = FM.insert (lists, t, count),
adamc@757 89 decls = (count, xts') :: decls},
adamc@757 90 count)
adamc@757 91 end
adamc@29 92
adamc@757 93 fun declares (v : t) = #decls v
adamc@757 94
adamc@757 95 fun clearDeclares (v : t) = {count = #count v,
adamc@757 96 normal = #normal v,
adamc@757 97 lists = #lists v,
adamc@757 98 decls = []}
adamc@453 99
adamc@29 100 end
adamc@29 101
adamc@196 102 fun cifyTyp x =
adamc@196 103 let
adamc@196 104 fun cify dtmap ((t, loc), sm) =
adamc@196 105 case t of
adamc@196 106 L.TFun (t1, t2) =>
adamc@196 107 let
adamc@196 108 val (t1, sm) = cify dtmap (t1, sm)
adamc@196 109 val (t2, sm) = cify dtmap (t2, sm)
adamc@196 110 in
adamc@196 111 ((L'.TFun (t1, t2), loc), sm)
adamc@196 112 end
adamc@196 113 | L.TRecord xts =>
adamc@196 114 let
adam@1314 115 val xts = MonoUtil.Typ.sortFields xts
adamc@196 116 val old_xts = xts
adamc@196 117 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@196 118 let
adamc@196 119 val (t, sm) = cify dtmap (t, sm)
adamc@196 120 in
adamc@196 121 ((x, t), sm)
adamc@196 122 end)
adamc@196 123 sm xts
adamc@196 124 val (sm, si) = Sm.find (sm, old_xts, xts)
adamc@196 125 in
adamc@196 126 ((L'.TRecord si, loc), sm)
adamc@196 127 end
adamc@196 128 | L.TDatatype (n, ref (dk, xncs)) =>
adamc@196 129 (case IM.find (dtmap, n) of
adamc@196 130 SOME r => ((L'.TDatatype (dk, n, r), loc), sm)
adamc@196 131 | NONE =>
adamc@196 132 let
adamc@196 133 val r = ref []
adamc@196 134 val dtmap = IM.insert (dtmap, n, r)
adamc@196 135
adamc@196 136 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
adamc@196 137 case to of
adamc@196 138 NONE => ((x, n, NONE), sm)
adamc@196 139 | SOME t =>
adamc@196 140 let
adamc@196 141 val (t, sm) = cify dtmap (t, sm)
adamc@196 142 in
adamc@196 143 ((x, n, SOME t), sm)
adamc@196 144 end)
adamc@196 145 sm xncs
adamc@196 146 in
adamc@196 147 r := xncs;
adamc@196 148 ((L'.TDatatype (dk, n, r), loc), sm)
adamc@196 149 end)
adamc@196 150 | L.TFfi mx => ((L'.TFfi mx, loc), sm)
adamc@288 151 | L.TOption t =>
adamc@288 152 let
adamc@288 153 val (t, sm) = cify dtmap (t, sm)
adamc@288 154 in
adamc@288 155 ((L'.TOption t, loc), sm)
adamc@288 156 end
adamc@757 157 | L.TList t =>
adamc@757 158 let
adamc@757 159 val (t', sm) = cify dtmap (t, sm)
adamc@757 160 val (sm, si) = Sm.findList (sm, t, t')
adamc@757 161 in
adamc@757 162 ((L'.TList (t', si), loc), sm)
adamc@757 163 end
adam@1446 164 | L.TSource => ((L'.TFfi ("Basis", "source"), loc), sm)
adamc@568 165 | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
adamc@196 166 in
adamc@196 167 cify IM.empty x
adamc@196 168 end
adamc@29 169
adamc@109 170 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
adamc@109 171
adamc@186 172 fun cifyPatCon (pc, sm) =
adamc@181 173 case pc of
adamc@186 174 L.PConVar n => (L'.PConVar n, sm)
adamc@186 175 | L.PConFfi {mod = m, datatyp, con, arg} =>
adamc@186 176 let
adamc@186 177 val (arg, sm) =
adamc@186 178 case arg of
adamc@186 179 NONE => (NONE, sm)
adamc@186 180 | SOME t =>
adamc@186 181 let
adamc@186 182 val (t, sm) = cifyTyp (t, sm)
adamc@186 183 in
adamc@186 184 (SOME t, sm)
adamc@186 185 end
adamc@186 186 in
adamc@186 187 (L'.PConFfi {mod = m, datatyp = datatyp, con = con, arg = arg}, sm)
adamc@186 188 end
adamc@181 189
adamc@182 190 fun cifyPat ((p, loc), sm) =
adamc@181 191 case p of
adamc@182 192 L.PWild => ((L'.PWild, loc), sm)
adamc@182 193 | L.PVar (x, t) =>
adamc@182 194 let
adamc@182 195 val (t, sm) = cifyTyp (t, sm)
adamc@182 196 in
adamc@182 197 ((L'.PVar (x, t), loc), sm)
adamc@182 198 end
adamc@182 199 | L.PPrim p => ((L'.PPrim p, loc), sm)
adamc@188 200 | L.PCon (dk, pc, NONE) =>
adamc@186 201 let
adamc@186 202 val (pc, sm) = cifyPatCon (pc, sm)
adamc@186 203 in
adamc@188 204 ((L'.PCon (dk, pc, NONE), loc), sm)
adamc@186 205 end
adamc@188 206 | L.PCon (dk, pc, SOME p) =>
adamc@182 207 let
adamc@186 208 val (pc, sm) = cifyPatCon (pc, sm)
adamc@182 209 val (p, sm) = cifyPat (p, sm)
adamc@182 210 in
adamc@188 211 ((L'.PCon (dk, pc, SOME p), loc), sm)
adamc@182 212 end
adamc@182 213 | L.PRecord xps =>
adamc@182 214 let
adamc@182 215 val (xps, sm) = ListUtil.foldlMap (fn ((x, p, t), sm) =>
adamc@182 216 let
adamc@182 217 val (p, sm) = cifyPat (p, sm)
adamc@182 218 val (t, sm) = cifyTyp (t, sm)
adamc@182 219 in
adamc@182 220 ((x, p, t), sm)
adamc@182 221 end) sm xps
adamc@182 222 in
adamc@182 223 ((L'.PRecord xps, loc), sm)
adamc@182 224 end
adamc@288 225 | L.PNone t =>
adamc@288 226 let
adamc@288 227 val (t, sm) = cifyTyp (t, sm)
adamc@288 228 in
adamc@288 229 ((L'.PNone t, loc), sm)
adamc@288 230 end
adamc@288 231 | L.PSome (t, p) =>
adamc@288 232 let
adamc@288 233 val (t, sm) = cifyTyp (t, sm)
adamc@288 234 val (p, sm) = cifyPat (p, sm)
adamc@288 235 in
adamc@288 236 ((L'.PSome (t, p), loc), sm)
adamc@288 237 end
adamc@288 238
adamc@280 239 fun cifyExp (eAll as (e, loc), sm) =
adamc@29 240 case e of
adamc@29 241 L.EPrim p => ((L'.EPrim p, loc), sm)
adamc@29 242 | L.ERel n => ((L'.ERel n, loc), sm)
adamc@29 243 | L.ENamed n => ((L'.ENamed n, loc), sm)
adamc@188 244 | L.ECon (dk, pc, eo) =>
adamc@181 245 let
adamc@181 246 val (eo, sm) =
adamc@181 247 case eo of
adamc@181 248 NONE => (NONE, sm)
adamc@181 249 | SOME e =>
adamc@181 250 let
adamc@181 251 val (e, sm) = cifyExp (e, sm)
adamc@181 252 in
adamc@181 253 (SOME e, sm)
adamc@181 254 end
adamc@186 255 val (pc, sm) = cifyPatCon (pc, sm)
adamc@181 256 in
adamc@188 257 ((L'.ECon (dk, pc, eo), loc), sm)
adamc@181 258 end
adamc@297 259 | L.ENone t =>
adamc@297 260 let
adamc@297 261 val (t, sm) = cifyTyp (t, sm)
adamc@297 262 in
adamc@297 263 ((L'.ENone t, loc), sm)
adamc@297 264 end
adamc@290 265 | L.ESome (t, e) =>
adamc@290 266 let
adamc@290 267 val (t, sm) = cifyTyp (t, sm)
adamc@290 268 val (e, sm) = cifyExp (e, sm)
adamc@290 269 in
adamc@290 270 ((L'.ESome (t, e), loc), sm)
adamc@290 271 end
adamc@53 272 | L.EFfi mx => ((L'.EFfi mx, loc), sm)
adamc@53 273 | L.EFfiApp (m, x, es) =>
adamc@53 274 let
adamc@53 275 val (es, sm) = ListUtil.foldlMap cifyExp sm es
adamc@53 276 in
adamc@53 277 ((L'.EFfiApp (m, x, es), loc), sm)
adamc@53 278 end
adamc@29 279 | L.EApp (e1, e2) =>
adamc@29 280 let
adamc@316 281 fun unravel (e, args) =
adamc@316 282 case e of
adamc@316 283 (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
adamc@316 284 | _ => (e, args)
adamc@316 285
adamc@316 286 val (f, es) = unravel (e1, [e2])
adamc@316 287
adamc@316 288 val (f, sm) = cifyExp (f, sm)
adamc@316 289 val (es, sm) = ListUtil.foldlMap cifyExp sm es
adamc@29 290 in
adamc@316 291 ((L'.EApp (f, es), loc), sm)
adamc@29 292 end
adamc@109 293 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
adamc@280 294 Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
adamc@109 295 (dummye, sm))
adamc@29 296
adamc@387 297 | L.EUnop (s, e1) =>
adamc@387 298 let
adamc@387 299 val (e1, sm) = cifyExp (e1, sm)
adamc@387 300 in
adamc@387 301 ((L'.EUnop (s, e1), loc), sm)
adamc@387 302 end
adam@1360 303 | L.EBinop (_, s, e1, e2) =>
adamc@387 304 let
adamc@387 305 val (e1, sm) = cifyExp (e1, sm)
adamc@387 306 val (e2, sm) = cifyExp (e2, sm)
adamc@387 307 in
adamc@387 308 ((L'.EBinop (s, e1, e2), loc), sm)
adamc@387 309 end
adamc@387 310
adamc@29 311 | L.ERecord xes =>
adamc@29 312 let
adamc@29 313 val old_xts = map (fn (x, _, t) => (x, t)) xes
adamc@29 314
adamc@29 315 val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
adamc@29 316 let
adamc@29 317 val (e, sm) = cifyExp (e, sm)
adamc@29 318 val (t, sm) = cifyTyp (t, sm)
adamc@29 319 in
adamc@29 320 ((x, e, t), sm)
adamc@29 321 end)
adamc@29 322 sm xes
adamc@29 323
adamc@29 324 val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
adamc@29 325
adamc@29 326 val xes = map (fn (x, e, _) => (x, e)) xets
adamc@29 327 val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
adamc@29 328 in
adamc@29 329 ((L'.ERecord (si, xes), loc), sm)
adamc@29 330 end
adamc@29 331 | L.EField (e, x) =>
adamc@29 332 let
adamc@29 333 val (e, sm) = cifyExp (e, sm)
adamc@29 334 in
adamc@29 335 ((L'.EField (e, x), loc), sm)
adamc@29 336 end
adamc@29 337
adamc@182 338 | L.ECase (e, pes, {disc, result}) =>
adamc@181 339 let
adamc@181 340 val (e, sm) = cifyExp (e, sm)
adamc@181 341 val (pes, sm) = ListUtil.foldlMap
adamc@181 342 (fn ((p, e), sm) =>
adamc@181 343 let
adamc@181 344 val (e, sm) = cifyExp (e, sm)
adamc@182 345 val (p, sm) = cifyPat (p, sm)
adamc@181 346 in
adamc@182 347 ((p, e), sm)
adamc@181 348 end) sm pes
adamc@182 349 val (disc, sm) = cifyTyp (disc, sm)
adamc@182 350 val (result, sm) = cifyTyp (result, sm)
adamc@181 351 in
adamc@182 352 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
adamc@181 353 end
adamc@178 354
adamc@283 355 | L.EError (e, t) =>
adamc@283 356 let
adamc@283 357 val (e, sm) = cifyExp (e, sm)
adamc@283 358 val (t, sm) = cifyTyp (t, sm)
adamc@283 359 in
adamc@283 360 ((L'.EError (e, t), loc), sm)
adamc@283 361 end
adamc@741 362 | L.EReturnBlob {blob, mimeType, t} =>
adamc@741 363 let
adamc@741 364 val (blob, sm) = cifyExp (blob, sm)
adamc@741 365 val (mimeType, sm) = cifyExp (mimeType, sm)
adamc@741 366 val (t, sm) = cifyTyp (t, sm)
adamc@741 367 in
adamc@741 368 ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
adamc@741 369 end
adamc@1065 370 | L.ERedirect (e, t) =>
adamc@1065 371 let
adamc@1065 372 val (e, sm) = cifyExp (e, sm)
adamc@1065 373 val (t, sm) = cifyTyp (t, sm)
adamc@1065 374 in
adamc@1065 375 ((L'.ERedirect (e, t), loc), sm)
adamc@1065 376 end
adamc@283 377
adamc@180 378 | L.EStrcat (e1, e2) =>
adamc@180 379 let
adamc@180 380 val (e1, sm) = cifyExp (e1, sm)
adamc@180 381 val (e2, sm) = cifyExp (e2, sm)
adamc@180 382 in
adamc@180 383 ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm)
adamc@180 384 end
adamc@102 385
adamc@102 386 | L.EWrite e =>
adamc@102 387 let
adamc@102 388 val (e, sm) = cifyExp (e, sm)
adamc@102 389 in
adamc@102 390 ((L'.EWrite e, loc), sm)
adamc@102 391 end
adamc@102 392
adamc@106 393 | L.ESeq (e1, e2) =>
adamc@106 394 let
adamc@106 395 val (e1, sm) = cifyExp (e1, sm)
adamc@106 396 val (e2, sm) = cifyExp (e2, sm)
adamc@106 397 in
adamc@106 398 ((L'.ESeq (e1, e2), loc), sm)
adamc@106 399 end
adamc@106 400
adamc@269 401 | L.ELet (x, t, e1, e2) =>
adamc@269 402 let
adamc@269 403 val (t, sm) = cifyTyp (t, sm)
adamc@269 404 val (e1, sm) = cifyExp (e1, sm)
adamc@269 405 val (e2, sm) = cifyExp (e2, sm)
adamc@269 406 in
adamc@269 407 ((L'.ELet (x, t, e1, e2), loc), sm)
adamc@269 408 end
adamc@251 409
adamc@111 410 | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
adamc@111 411 (dummye, sm))
adamc@111 412
adamc@269 413 | L.EQuery {exps, tables, state, query, body, initial} =>
adamc@269 414 let
adamc@269 415 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@269 416 let
adamc@269 417 val (t, sm) = cifyTyp (t, sm)
adamc@269 418 in
adamc@269 419 ((x, t), sm)
adamc@269 420 end) sm exps
adamc@269 421 val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
adamc@269 422 let
adamc@269 423 val (xts, sm) = ListUtil.foldlMap
adamc@269 424 (fn ((x, t), sm) =>
adamc@269 425 let
adamc@269 426 val (t, sm) = cifyTyp (t, sm)
adamc@269 427 in
adamc@269 428 ((x, t), sm)
adamc@269 429 end) sm xts
adamc@269 430 in
adamc@269 431 ((x, xts), sm)
adamc@269 432 end) sm tables
adamc@269 433
adamc@269 434 val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
adamc@269 435 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
adamc@269 436
adamc@269 437 val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
adamc@269 438 let
adamc@269 439 val (sm, rnum) = Sm.find (sm, xts, xts')
adamc@269 440 in
adamc@269 441 ((x, rnum), sm)
adamc@269 442 end)
adamc@269 443 sm (ListPair.zip (tables, tables'))
adamc@269 444 val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
adamc@269 445 val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
adamc@269 446
adamc@269 447 val (sm, rnum) = Sm.find (sm, row, row')
adamc@269 448
adamc@269 449 val (state, sm) = cifyTyp (state, sm)
adamc@269 450 val (query, sm) = cifyExp (query, sm)
adamc@269 451 val (body, sm) = cifyExp (body, sm)
adamc@269 452 val (initial, sm) = cifyExp (initial, sm)
adamc@269 453 in
adamc@269 454 ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
adamc@282 455 query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
adamc@269 456 end
adamc@269 457
adam@1293 458 | L.EDml (e, mode) =>
adamc@307 459 let
adamc@307 460 val (e, sm) = cifyExp (e, sm)
adamc@307 461 in
adam@1293 462 ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
adamc@307 463 end
adamc@307 464
adamc@338 465 | L.ENextval e =>
adamc@338 466 let
adamc@338 467 val (e, sm) = cifyExp (e, sm)
adamc@338 468 in
adamc@338 469 ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
adamc@338 470 end
adamc@1073 471 | L.ESetval (e1, e2) =>
adamc@1073 472 let
adamc@1073 473 val (e1, sm) = cifyExp (e1, sm)
adamc@1073 474 val (e2, sm) = cifyExp (e2, sm)
adamc@1073 475 in
adamc@1073 476 ((L'.ESetval {seq = e1, count = e2}, loc), sm)
adamc@1073 477 end
adamc@338 478
adamc@1112 479 | L.EUnurlify (e, t, b) =>
adamc@463 480 let
adamc@463 481 val (e, sm) = cifyExp (e, sm)
adamc@463 482 val (t, sm) = cifyTyp (t, sm)
adamc@463 483 in
adamc@1112 484 ((L'.EUnurlify (e, t, b), loc), sm)
adamc@463 485 end
adamc@252 486
adamc@568 487 | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
adamc@578 488
adamc@568 489 | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
adamc@572 490 | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
adamc@574 491 | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
adamc@566 492
adamc@608 493 | L.EServerCall _ => raise Fail "Cjrize EServerCall"
adamc@670 494 | L.ERecv _ => raise Fail "Cjrize ERecv"
adamc@695 495 | L.ESleep _ => raise Fail "Cjrize ESleep"
adamc@1021 496 | L.ESpawn _ => raise Fail "Cjrize ESpawn"
adamc@608 497
adamc@29 498 fun cifyDecl ((d, loc), sm) =
adamc@29 499 case d of
adamc@809 500 L.DDatatype dts =>
adamc@165 501 let
adamc@809 502 val (dts, sm) = ListUtil.foldlMap
adamc@809 503 (fn ((x, n, xncs), sm) =>
adamc@809 504 let
adamc@809 505 val dk = ElabUtil.classifyDatatype xncs
adamc@809 506 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
adamc@809 507 case to of
adamc@809 508 NONE => ((x, n, NONE), sm)
adamc@809 509 | SOME t =>
adamc@809 510 let
adamc@809 511 val (t, sm) = cifyTyp (t, sm)
adamc@809 512 in
adamc@809 513 ((x, n, SOME t), sm)
adamc@809 514 end) sm xncs
adamc@809 515 in
adamc@809 516 ((dk, x, n, xncs), sm)
adamc@809 517 end)
adamc@809 518 sm dts
adamc@165 519 in
adamc@809 520 (SOME (L'.DDatatype dts, loc), NONE, sm)
adamc@809 521 end
adamc@164 522
adamc@164 523 | L.DVal (x, n, t, e, _) =>
adamc@29 524 let
adamc@29 525 val (t, sm) = cifyTyp (t, sm)
adamc@109 526
adamc@109 527 val (d, sm) = case #1 t of
adamc@121 528 L'.TFun _ =>
adamc@121 529 let
adamc@121 530 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@121 531 case (t, e) of
adamc@121 532 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@121 533 let
adamc@121 534 val (args, t, e) = unravel (ran, e)
adamc@121 535 in
adamc@121 536 ((ax, dom) :: args, t, e)
adamc@121 537 end
adamc@993 538 | (L'.TFun (dom, ran), _) =>
adamc@993 539 let
adamc@993 540 val e = MonoEnv.liftExpInExp 0 eAll
adamc@993 541 val e = (L.EApp (e, (L.ERel 0, loc)), loc)
adamc@993 542 val (args, t, e) = unravel (ran, e)
adamc@993 543 in
adamc@993 544 (("x", dom) :: args, t, e)
adamc@993 545 end
adamc@121 546 | _ => ([], tAll, eAll)
adamc@121 547
adamc@121 548 val (args, ran, e) = unravel (t, e)
adamc@121 549 val (e, sm) = cifyExp (e, sm)
adamc@121 550 in
adamc@121 551 (L'.DFun (x, n, args, ran, e), sm)
adamc@121 552 end
adamc@121 553
adamc@109 554 | _ =>
adamc@109 555 let
adamc@109 556 val (e, sm) = cifyExp (e, sm)
adamc@109 557 in
adamc@109 558 (L'.DVal (x, n, t, e), sm)
adamc@109 559 end
adamc@29 560 in
adamc@109 561 (SOME (d, loc), NONE, sm)
adamc@29 562 end
adamc@129 563 | L.DValRec vis =>
adamc@129 564 let
adamc@129 565 val (vis, sm) = ListUtil.foldlMap
adamc@129 566 (fn ((x, n, t, e, _), sm) =>
adamc@129 567 let
adamc@129 568 val (t, sm) = cifyTyp (t, sm)
adamc@129 569
adamc@129 570 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@129 571 case (t, e) of
adamc@129 572 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@129 573 let
adamc@129 574 val (args, t, e) = unravel (ran, e)
adamc@129 575 in
adamc@129 576 ((ax, dom) :: args, t, e)
adamc@129 577 end
adamc@129 578 | (L'.TFun _, _) =>
adamc@129 579 (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
adamc@129 580 ([], tAll, eAll))
adamc@129 581 | _ => ([], tAll, eAll)
adamc@129 582
adamc@129 583 val (args, ran, e) = unravel (t, e)
adamc@129 584 val (e, sm) = cifyExp (e, sm)
adamc@129 585 in
adamc@129 586 ((x, n, args, ran, e), sm)
adamc@129 587 end)
adamc@129 588 sm vis
adamc@129 589 in
adamc@129 590 (SOME (L'.DFunRec vis, loc), NONE, sm)
adamc@129 591 end
adamc@129 592
adamc@1104 593 | L.DExport (ek, s, n, ts, t, b) =>
adamc@120 594 let
adamc@120 595 val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
adamc@609 596 val (t, sm) = cifyTyp (t, sm)
adamc@120 597 in
adamc@1104 598 (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm)
adamc@120 599 end
adamc@29 600
adamc@707 601 | L.DTable (s, xts, pe, ce) =>
adamc@273 602 let
adamc@273 603 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@273 604 let
adamc@273 605 val (t, sm) = cifyTyp (t, sm)
adamc@273 606 in
adamc@273 607 ((x, t), sm)
adamc@273 608 end) sm xts
adamc@704 609
adamc@704 610 fun flatten e =
adamc@704 611 case #1 e of
adamc@704 612 L.ERecord [] => []
adamc@704 613 | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
adamc@704 614 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@704 615 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@704 616 Print.prefaces "Undetermined constraint"
adamc@707 617 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@704 618 [])
adamc@707 619
adamc@707 620 val pe = case #1 pe of
adamc@707 621 L.EPrim (Prim.String s) => s
adamc@707 622 | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
adamc@707 623 Print.prefaces "Undetermined constraint"
adamc@707 624 [("e", MonoPrint.p_exp MonoEnv.empty pe)];
adamc@707 625 "")
adamc@273 626 in
adamc@707 627 (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm)
adamc@273 628 end
adamc@338 629 | L.DSequence s =>
adamc@338 630 (SOME (L'.DSequence s, loc), NONE, sm)
adamc@754 631 | L.DView (s, xts, e) =>
adamc@754 632 let
adamc@754 633 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@754 634 let
adamc@754 635 val (t, sm) = cifyTyp (t, sm)
adamc@754 636 in
adamc@754 637 ((x, t), sm)
adamc@754 638 end) sm xts
adamc@754 639
adamc@754 640 fun flatten e =
adamc@754 641 case #1 e of
adamc@754 642 L.ERecord [] => []
adamc@754 643 | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
adamc@754 644 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@754 645 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@754 646 Print.prefaces "Undetermined constraint"
adamc@754 647 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 648 [])
adamc@754 649
adamc@754 650 val e = case #1 e of
adamc@754 651 L.EPrim (Prim.String s) => s
adamc@754 652 | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
adamc@754 653 Print.prefaces "Undetermined VIEW query"
adamc@754 654 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 655 "")
adamc@754 656 in
adamc@754 657 (SOME (L'.DView (s, xts, e), loc), NONE, sm)
adamc@754 658 end
adamc@271 659 | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
adamc@569 660 | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
adamc@725 661 | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
adamc@718 662 | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
adamc@1075 663 | L.DTask (e1, e2) =>
adamc@1075 664 (case #1 e2 of
adam@1348 665 L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) =>
adamc@1073 666 let
adamc@1075 667 val tk = case #1 e1 of
adamc@1075 668 L.EFfi ("Basis", "initialize") => L'.Initialize
adam@1348 669 | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
adam@1349 670 | L.EFfiApp ("Basis", "periodic", [(L.EPrim (Prim.Int n), _)]) => L'.Periodic n
adamc@1075 671 | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
adamc@1075 672 L'.Initialize)
adamc@1073 673 val (e, sm) = cifyExp (e, sm)
adamc@1073 674 in
adam@1348 675 (SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm)
adamc@1073 676 end
adamc@1073 677 | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
adamc@1073 678 (NONE, NONE, sm)))
adamc@1199 679 | L.DPolicy _ => (NONE, NONE, sm)
adam@1294 680 | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
adamc@271 681
adamc@29 682 fun cjrize ds =
adamc@29 683 let
adamc@196 684 val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
adamc@196 685 let
adamc@196 686 val (dop, pop, sm) = cifyDecl (d, sm)
adamc@453 687
adamc@640 688 val dsF = case dop of
adamc@809 689 SOME (L'.DDatatype dts, loc) =>
adamc@809 690 map (fn (dk, x, n, _) =>
adamc@809 691 (L'.DDatatypeForward (dk, x, n), loc)) dts @ dsF
adamc@640 692 | _ => dsF
adamc@640 693
adamc@640 694 val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
adamc@640 695 @ dsF
adamc@640 696
adamc@196 697 val (dsF, ds) = case dop of
adamc@196 698 NONE => (dsF, ds)
adamc@453 699 | SOME (d as (L'.DDatatype _, loc)) =>
adamc@453 700 (d :: dsF, ds)
adamc@196 701 | SOME d => (dsF, d :: ds)
adamc@453 702
adamc@196 703 val ps = case pop of
adamc@196 704 NONE => ps
adamc@196 705 | SOME p => p :: ps
adamc@196 706 in
adamc@453 707 (dsF, ds, ps, Sm.clearDeclares sm)
adamc@196 708 end)
adamc@196 709 ([], [], [], Sm.empty) ds
adamc@29 710 in
adamc@453 711 (List.revAppend (dsF, rev ds),
adamc@101 712 ps)
adamc@29 713 end
adamc@29 714
adamc@29 715 end