Mercurial > urweb

annotate src/cjrize.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 0577be31a435
children e8149592990e
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) =
adam@1601 240 let
adam@1601 241 fun fail msg =
adam@1601 242 (ErrorMsg.errorAt loc msg;
adam@1601 243 ((L'.EPrim (Prim.String ""), loc), sm))
adam@1601 244 in
adam@1601 245 case e of
adam@1601 246 L.EPrim p => ((L'.EPrim p, loc), sm)
adam@1601 247 | L.ERel n => ((L'.ERel n, loc), sm)
adam@1601 248 | L.ENamed n => ((L'.ENamed n, loc), sm)
adam@1601 249 | L.ECon (dk, pc, eo) =>
adam@1601 250 let
adam@1601 251 val (eo, sm) =
adam@1601 252 case eo of
adam@1601 253 NONE => (NONE, sm)
adam@1601 254 | SOME e =>
adam@1601 255 let
adam@1601 256 val (e, sm) = cifyExp (e, sm)
adam@1601 257 in
adam@1601 258 (SOME e, sm)
adam@1601 259 end
adam@1601 260 val (pc, sm) = cifyPatCon (pc, sm)
adam@1601 261 in
adam@1601 262 ((L'.ECon (dk, pc, eo), loc), sm)
adam@1601 263 end
adam@1601 264 | L.ENone t =>
adam@1601 265 let
adam@1601 266 val (t, sm) = cifyTyp (t, sm)
adam@1601 267 in
adam@1601 268 ((L'.ENone t, loc), sm)
adam@1601 269 end
adam@1601 270 | L.ESome (t, e) =>
adam@1601 271 let
adam@1601 272 val (t, sm) = cifyTyp (t, sm)
adam@1601 273 val (e, sm) = cifyExp (e, sm)
adam@1601 274 in
adam@1601 275 ((L'.ESome (t, e), loc), sm)
adam@1601 276 end
adam@1601 277 | L.EFfi mx => ((L'.EFfi mx, loc), sm)
adam@1601 278 | L.EFfiApp (m, x, es) =>
adam@1601 279 let
adam@1663 280 val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) =>
adam@1663 281 let
adam@1663 282 val (t, sm) = cifyTyp (t, sm)
adam@1663 283 val (e, sm) = cifyExp (e, sm)
adam@1663 284 in
adam@1663 285 ((e, t), sm)
adam@1663 286 end) sm es
adam@1601 287 in
adam@1601 288 ((L'.EFfiApp (m, x, es), loc), sm)
adam@1601 289 end
adam@1601 290 | L.EApp (e1, e2) =>
adam@1601 291 let
adam@1601 292 fun unravel (e, args) =
adam@1601 293 case e of
adam@1601 294 (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
adam@1601 295 | _ => (e, args)
adamc@316 296
adam@1601 297 val (f, es) = unravel (e1, [e2])
adamc@316 298
adam@1601 299 val (f, sm) = cifyExp (f, sm)
adam@1601 300 val (es, sm) = ListUtil.foldlMap cifyExp sm es
adam@1601 301 in
adam@1601 302 ((L'.EApp (f, es), loc), sm)
adam@1601 303 end
adam@1601 304 | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
adam@1601 305 Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
adam@1601 306 (dummye, sm))
adamc@29 307
adam@1601 308 | L.EUnop (s, e1) =>
adam@1601 309 let
adam@1601 310 val (e1, sm) = cifyExp (e1, sm)
adam@1601 311 in
adam@1601 312 ((L'.EUnop (s, e1), loc), sm)
adam@1601 313 end
adam@1601 314 | L.EBinop (_, s, e1, e2) =>
adam@1601 315 let
adam@1601 316 val (e1, sm) = cifyExp (e1, sm)
adam@1601 317 val (e2, sm) = cifyExp (e2, sm)
adam@1601 318 in
adam@1601 319 ((L'.EBinop (s, e1, e2), loc), sm)
adam@1601 320 end
adamc@387 321
adam@1601 322 | L.ERecord xes =>
adam@1601 323 let
adam@1601 324 val old_xts = map (fn (x, _, t) => (x, t)) xes
adamc@29 325
adam@1601 326 val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
adam@1601 327 let
adam@1601 328 val (e, sm) = cifyExp (e, sm)
adam@1601 329 val (t, sm) = cifyTyp (t, sm)
adam@1601 330 in
adam@1601 331 ((x, e, t), sm)
adam@1601 332 end)
adam@1601 333 sm xes
adamc@29 334
adam@1601 335 val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
adamc@29 336
adam@1601 337 val xes = map (fn (x, e, _) => (x, e)) xets
adam@1601 338 val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
adam@1601 339 in
adam@1601 340 ((L'.ERecord (si, xes), loc), sm)
adam@1601 341 end
adam@1601 342 | L.EField (e, x) =>
adam@1601 343 let
adam@1601 344 val (e, sm) = cifyExp (e, sm)
adam@1601 345 in
adam@1601 346 ((L'.EField (e, x), loc), sm)
adam@1601 347 end
adamc@29 348
adam@1601 349 | L.ECase (e, pes, {disc, result}) =>
adam@1601 350 let
adamc@181 351 val (e, sm) = cifyExp (e, sm)
adamc@181 352 val (pes, sm) = ListUtil.foldlMap
adamc@181 353 (fn ((p, e), sm) =>
adamc@181 354 let
adamc@181 355 val (e, sm) = cifyExp (e, sm)
adamc@182 356 val (p, sm) = cifyPat (p, sm)
adamc@181 357 in
adamc@182 358 ((p, e), sm)
adamc@181 359 end) sm pes
adamc@182 360 val (disc, sm) = cifyTyp (disc, sm)
adamc@182 361 val (result, sm) = cifyTyp (result, sm)
adamc@181 362 in
adamc@182 363 ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
adamc@181 364 end
adamc@178 365
adam@1601 366 | L.EError (e, t) =>
adam@1601 367 let
adam@1601 368 val (e, sm) = cifyExp (e, sm)
adam@1601 369 val (t, sm) = cifyTyp (t, sm)
adam@1601 370 in
adam@1601 371 ((L'.EError (e, t), loc), sm)
adam@1601 372 end
adam@1601 373 | L.EReturnBlob {blob, mimeType, t} =>
adam@1601 374 let
adam@1601 375 val (blob, sm) = cifyExp (blob, sm)
adam@1601 376 val (mimeType, sm) = cifyExp (mimeType, sm)
adam@1601 377 val (t, sm) = cifyTyp (t, sm)
adam@1601 378 in
adam@1601 379 ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
adam@1601 380 end
adam@1601 381 | L.ERedirect (e, t) =>
adam@1601 382 let
adam@1601 383 val (e, sm) = cifyExp (e, sm)
adam@1601 384 val (t, sm) = cifyTyp (t, sm)
adam@1601 385 in
adam@1601 386 ((L'.ERedirect (e, t), loc), sm)
adam@1601 387 end
adamc@283 388
adam@1601 389 | L.EStrcat (e1, e2) =>
adam@1601 390 let
adam@1601 391 val (e1, sm) = cifyExp (e1, sm)
adam@1601 392 val (e2, sm) = cifyExp (e2, sm)
adam@1663 393 val s = (L'.TFfi ("Basis", "string"), loc)
adam@1601 394 in
adam@1663 395 ((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm)
adam@1601 396 end
adamc@102 397
adam@1601 398 | L.EWrite e =>
adam@1601 399 let
adam@1601 400 val (e, sm) = cifyExp (e, sm)
adam@1601 401 in
adam@1601 402 ((L'.EWrite e, loc), sm)
adam@1601 403 end
adamc@102 404
adam@1601 405 | L.ESeq (e1, e2) =>
adam@1601 406 let
adam@1601 407 val (e1, sm) = cifyExp (e1, sm)
adam@1601 408 val (e2, sm) = cifyExp (e2, sm)
adam@1601 409 in
adam@1601 410 ((L'.ESeq (e1, e2), loc), sm)
adam@1601 411 end
adamc@106 412
adam@1601 413 | L.ELet (x, t, e1, e2) =>
adam@1601 414 let
adam@1601 415 val (t, sm) = cifyTyp (t, sm)
adam@1601 416 val (e1, sm) = cifyExp (e1, sm)
adam@1601 417 val (e2, sm) = cifyExp (e2, sm)
adam@1601 418 in
adam@1601 419 ((L'.ELet (x, t, e1, e2), loc), sm)
adam@1601 420 end
adamc@251 421
adam@1601 422 | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
adam@1601 423 (dummye, sm))
adamc@111 424
adam@1601 425 | L.EQuery {exps, tables, state, query, body, initial} =>
adam@1601 426 let
adam@1601 427 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adam@1601 428 let
adam@1601 429 val (t, sm) = cifyTyp (t, sm)
adam@1601 430 in
adam@1601 431 ((x, t), sm)
adam@1601 432 end) sm exps
adam@1601 433 val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
adam@1601 434 let
adam@1601 435 val (xts, sm) = ListUtil.foldlMap
adam@1601 436 (fn ((x, t), sm) =>
adam@1601 437 let
adam@1601 438 val (t, sm) = cifyTyp (t, sm)
adam@1601 439 in
adam@1601 440 ((x, t), sm)
adam@1601 441 end) sm xts
adam@1601 442 in
adam@1601 443 ((x, xts), sm)
adam@1601 444 end) sm tables
adamc@269 445
adam@1601 446 val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
adam@1601 447 val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
adamc@269 448
adam@1601 449 val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
adam@1601 450 let
adam@1601 451 val (sm, rnum) = Sm.find (sm, xts, xts')
adam@1601 452 in
adam@1601 453 ((x, rnum), sm)
adam@1601 454 end)
adam@1601 455 sm (ListPair.zip (tables, tables'))
adam@1601 456 val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
adam@1601 457 val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
adamc@269 458
adam@1601 459 val (sm, rnum) = Sm.find (sm, row, row')
adamc@269 460
adam@1601 461 val (state, sm) = cifyTyp (state, sm)
adam@1601 462 val (query, sm) = cifyExp (query, sm)
adam@1601 463 val (body, sm) = cifyExp (body, sm)
adam@1601 464 val (initial, sm) = cifyExp (initial, sm)
adam@1601 465 in
adam@1601 466 ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
adam@1601 467 query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
adam@1601 468 end
adamc@269 469
adam@1601 470 | L.EDml (e, mode) =>
adam@1601 471 let
adam@1601 472 val (e, sm) = cifyExp (e, sm)
adam@1601 473 in
adam@1601 474 ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
adam@1601 475 end
adamc@307 476
adam@1601 477 | L.ENextval e =>
adam@1601 478 let
adam@1601 479 val (e, sm) = cifyExp (e, sm)
adam@1601 480 in
adam@1601 481 ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
adam@1601 482 end
adam@1601 483 | L.ESetval (e1, e2) =>
adam@1601 484 let
adam@1601 485 val (e1, sm) = cifyExp (e1, sm)
adam@1601 486 val (e2, sm) = cifyExp (e2, sm)
adam@1601 487 in
adam@1601 488 ((L'.ESetval {seq = e1, count = e2}, loc), sm)
adam@1601 489 end
adamc@338 490
adam@1601 491 | L.EUnurlify (e, t, b) =>
adam@1601 492 let
adam@1601 493 val (e, sm) = cifyExp (e, sm)
adam@1601 494 val (t, sm) = cifyTyp (t, sm)
adam@1601 495 in
adam@1601 496 ((L'.EUnurlify (e, t, b), loc), sm)
adam@1601 497 end
adamc@252 498
adam@1601 499 | L.EJavaScript _ => fail "Uncompilable JavaScript remains"
adamc@578 500
adam@1601 501 | L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code"
adam@1601 502 | L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code"
adam@1601 503 | L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code"
adamc@566 504
adam@1601 505 | L.EServerCall _ => fail "RPC in server-side code"
adam@1601 506 | L.ERecv _ => fail "Message receive in server-side code"
adam@1601 507 | L.ESleep _ => fail "Sleep in server-side code"
adam@1601 508 | L.ESpawn _ => fail "Thread spawn in server-side code"
adam@1601 509 end
adamc@608 510
adamc@29 511 fun cifyDecl ((d, loc), sm) =
adamc@29 512 case d of
adamc@809 513 L.DDatatype dts =>
adamc@165 514 let
adamc@809 515 val (dts, sm) = ListUtil.foldlMap
adamc@809 516 (fn ((x, n, xncs), sm) =>
adamc@809 517 let
adamc@809 518 val dk = ElabUtil.classifyDatatype xncs
adamc@809 519 val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
adamc@809 520 case to of
adamc@809 521 NONE => ((x, n, NONE), sm)
adamc@809 522 | SOME t =>
adamc@809 523 let
adamc@809 524 val (t, sm) = cifyTyp (t, sm)
adamc@809 525 in
adamc@809 526 ((x, n, SOME t), sm)
adamc@809 527 end) sm xncs
adamc@809 528 in
adamc@809 529 ((dk, x, n, xncs), sm)
adamc@809 530 end)
adamc@809 531 sm dts
adamc@165 532 in
adamc@809 533 (SOME (L'.DDatatype dts, loc), NONE, sm)
adamc@809 534 end
adamc@164 535
adamc@164 536 | L.DVal (x, n, t, e, _) =>
adamc@29 537 let
adamc@29 538 val (t, sm) = cifyTyp (t, sm)
adamc@109 539
adamc@109 540 val (d, sm) = case #1 t of
adamc@121 541 L'.TFun _ =>
adamc@121 542 let
adamc@121 543 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@121 544 case (t, e) of
adamc@121 545 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@121 546 let
adamc@121 547 val (args, t, e) = unravel (ran, e)
adamc@121 548 in
adamc@121 549 ((ax, dom) :: args, t, e)
adamc@121 550 end
adamc@993 551 | (L'.TFun (dom, ran), _) =>
adamc@993 552 let
adamc@993 553 val e = MonoEnv.liftExpInExp 0 eAll
adamc@993 554 val e = (L.EApp (e, (L.ERel 0, loc)), loc)
adamc@993 555 val (args, t, e) = unravel (ran, e)
adamc@993 556 in
adamc@993 557 (("x", dom) :: args, t, e)
adamc@993 558 end
adamc@121 559 | _ => ([], tAll, eAll)
adamc@121 560
adamc@121 561 val (args, ran, e) = unravel (t, e)
adamc@121 562 val (e, sm) = cifyExp (e, sm)
adamc@121 563 in
adamc@121 564 (L'.DFun (x, n, args, ran, e), sm)
adamc@121 565 end
adamc@121 566
adamc@109 567 | _ =>
adamc@109 568 let
adamc@109 569 val (e, sm) = cifyExp (e, sm)
adamc@109 570 in
adamc@109 571 (L'.DVal (x, n, t, e), sm)
adamc@109 572 end
adamc@29 573 in
adamc@109 574 (SOME (d, loc), NONE, sm)
adamc@29 575 end
adamc@129 576 | L.DValRec vis =>
adamc@129 577 let
adamc@129 578 val (vis, sm) = ListUtil.foldlMap
adamc@129 579 (fn ((x, n, t, e, _), sm) =>
adamc@129 580 let
adamc@129 581 val (t, sm) = cifyTyp (t, sm)
adamc@129 582
adamc@129 583 fun unravel (tAll as (t, _), eAll as (e, _)) =
adamc@129 584 case (t, e) of
adamc@129 585 (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) =>
adamc@129 586 let
adamc@129 587 val (args, t, e) = unravel (ran, e)
adamc@129 588 in
adamc@129 589 ((ax, dom) :: args, t, e)
adamc@129 590 end
adamc@129 591 | (L'.TFun _, _) =>
adamc@129 592 (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
adamc@129 593 ([], tAll, eAll))
adamc@129 594 | _ => ([], tAll, eAll)
adamc@129 595
adamc@129 596 val (args, ran, e) = unravel (t, e)
adamc@129 597 val (e, sm) = cifyExp (e, sm)
adamc@129 598 in
adamc@129 599 ((x, n, args, ran, e), sm)
adamc@129 600 end)
adamc@129 601 sm vis
adamc@129 602 in
adamc@129 603 (SOME (L'.DFunRec vis, loc), NONE, sm)
adamc@129 604 end
adamc@129 605
adamc@1104 606 | L.DExport (ek, s, n, ts, t, b) =>
adamc@120 607 let
adamc@120 608 val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
adamc@609 609 val (t, sm) = cifyTyp (t, sm)
adamc@120 610 in
adamc@1104 611 (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm)
adamc@120 612 end
adamc@29 613
adamc@707 614 | L.DTable (s, xts, pe, ce) =>
adamc@273 615 let
adamc@273 616 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@273 617 let
adamc@273 618 val (t, sm) = cifyTyp (t, sm)
adamc@273 619 in
adamc@273 620 ((x, t), sm)
adamc@273 621 end) sm xts
adamc@704 622
adamc@704 623 fun flatten e =
adamc@704 624 case #1 e of
adamc@704 625 L.ERecord [] => []
adamc@704 626 | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
adamc@704 627 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@704 628 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@704 629 Print.prefaces "Undetermined constraint"
adamc@707 630 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@704 631 [])
adamc@707 632
adamc@707 633 val pe = case #1 pe of
adamc@707 634 L.EPrim (Prim.String s) => s
adamc@707 635 | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
adamc@707 636 Print.prefaces "Undetermined constraint"
adamc@707 637 [("e", MonoPrint.p_exp MonoEnv.empty pe)];
adamc@707 638 "")
adamc@273 639 in
adamc@707 640 (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm)
adamc@273 641 end
adamc@338 642 | L.DSequence s =>
adamc@338 643 (SOME (L'.DSequence s, loc), NONE, sm)
adamc@754 644 | L.DView (s, xts, e) =>
adamc@754 645 let
adamc@754 646 val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
adamc@754 647 let
adamc@754 648 val (t, sm) = cifyTyp (t, sm)
adamc@754 649 in
adamc@754 650 ((x, t), sm)
adamc@754 651 end) sm xts
adamc@754 652
adamc@754 653 fun flatten e =
adamc@754 654 case #1 e of
adamc@754 655 L.ERecord [] => []
adamc@754 656 | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
adamc@754 657 | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
adamc@754 658 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
adamc@754 659 Print.prefaces "Undetermined constraint"
adamc@754 660 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 661 [])
adamc@754 662
adamc@754 663 val e = case #1 e of
adamc@754 664 L.EPrim (Prim.String s) => s
adamc@754 665 | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
adamc@754 666 Print.prefaces "Undetermined VIEW query"
adamc@754 667 [("e", MonoPrint.p_exp MonoEnv.empty e)];
adamc@754 668 "")
adamc@754 669 in
adamc@754 670 (SOME (L'.DView (s, xts, e), loc), NONE, sm)
adamc@754 671 end
adamc@271 672 | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
adamc@569 673 | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
adamc@725 674 | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
adamc@718 675 | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
adamc@1075 676 | L.DTask (e1, e2) =>
adamc@1075 677 (case #1 e2 of
adam@1348 678 L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) =>
adamc@1073 679 let
adamc@1075 680 val tk = case #1 e1 of
adamc@1075 681 L.EFfi ("Basis", "initialize") => L'.Initialize
adam@1348 682 | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
adam@1663 683 | L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n
adamc@1075 684 | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
adamc@1075 685 L'.Initialize)
adamc@1073 686 val (e, sm) = cifyExp (e, sm)
adamc@1073 687 in
adam@1348 688 (SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm)
adamc@1073 689 end
adamc@1073 690 | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
adamc@1073 691 (NONE, NONE, sm)))
adamc@1199 692 | L.DPolicy _ => (NONE, NONE, sm)
adam@1294 693 | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
adamc@271 694
adamc@29 695 fun cjrize ds =
adamc@29 696 let
adamc@196 697 val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
adamc@196 698 let
adamc@196 699 val (dop, pop, sm) = cifyDecl (d, sm)
adamc@453 700
adamc@640 701 val dsF = case dop of
adamc@809 702 SOME (L'.DDatatype dts, loc) =>
adamc@809 703 map (fn (dk, x, n, _) =>
adamc@809 704 (L'.DDatatypeForward (dk, x, n), loc)) dts @ dsF
adamc@640 705 | _ => dsF
adamc@640 706
adamc@640 707 val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
adamc@640 708 @ dsF
adamc@640 709
adamc@196 710 val (dsF, ds) = case dop of
adamc@196 711 NONE => (dsF, ds)
adamc@453 712 | SOME (d as (L'.DDatatype _, loc)) =>
adamc@453 713 (d :: dsF, ds)
adamc@196 714 | SOME d => (dsF, d :: ds)
adamc@453 715
adamc@196 716 val ps = case pop of
adamc@196 717 NONE => ps
adamc@196 718 | SOME p => p :: ps
adamc@196 719 in
adamc@453 720 (dsF, ds, ps, Sm.clearDeclares sm)
adamc@196 721 end)
adamc@196 722 ([], [], [], Sm.empty) ds
adamc@29 723 in
adamc@453 724 (List.revAppend (dsF, rev ds),
adamc@101 725 ps)
adamc@29 726 end
adamc@29 727
adamc@29 728 end