Mercurial > urweb

annotate src/cjr_print.sml @ 190:3eb53c957d10

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Checkboxes
author Adam Chlipala <adamc@hcoop.net>
date Thu, 07 Aug 2008 13:09:26 -0400
parents 8e9f97508f0d
children 890a61991263
rev   line source
adamc@29 1 (* Copyright (c) 2008, 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 (* Pretty-printing C jr. *)
adamc@29 29
adamc@29 30 structure CjrPrint :> CJR_PRINT = struct
adamc@29 31
adamc@29 32 open Print.PD
adamc@29 33 open Print
adamc@29 34
adamc@29 35 open Cjr
adamc@29 36
adamc@29 37 structure E = CjrEnv
adamc@29 38 structure EM = ErrorMsg
adamc@29 39
adamc@144 40 structure SK = struct
adamc@144 41 type ord_key = string
adamc@144 42 val compare = String.compare
adamc@144 43 end
adamc@144 44
adamc@144 45 structure SS = BinarySetFn(SK)
adamc@144 46 structure SM = BinaryMapFn(SK)
adamc@144 47 structure IS = IntBinarySet
adamc@144 48
adamc@144 49 structure CM = BinaryMapFn(struct
adamc@144 50 type ord_key = char
adamc@144 51 val compare = Char.compare
adamc@144 52 end)
adamc@144 53
adamc@29 54 val debug = ref false
adamc@29 55
adamc@188 56 val dummyTyp = (TDatatype (Enum, 0, []), ErrorMsg.dummySpan)
adamc@29 57
adamc@29 58 fun p_typ' par env (t, loc) =
adamc@29 59 case t of
adamc@101 60 TTop => string "void*"
adamc@109 61 | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@109 62 space,
adamc@109 63 string "(*)",
adamc@109 64 space,
adamc@109 65 string "(",
adamc@109 66 p_typ env t1,
adamc@109 67 string ")"])
adamc@29 68 | TRecord i => box [string "struct",
adamc@29 69 space,
adamc@29 70 string "__lws_",
adamc@29 71 string (Int.toString i)]
adamc@188 72 | TDatatype (Enum, n, _) =>
adamc@188 73 (box [string "enum",
adamc@188 74 space,
adamc@188 75 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
adamc@188 76 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
adamc@188 77 | TDatatype (Default, n, _) =>
adamc@165 78 (box [string "struct",
adamc@165 79 space,
adamc@166 80 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
adamc@166 81 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
adamc@53 82 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29 83
adamc@29 84 and p_typ env = p_typ' false env
adamc@29 85
adamc@29 86 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 87 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 88
adamc@109 89 fun p_enamed env n =
adamc@109 90 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109 91 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109 92
adamc@182 93 fun p_con_named env n =
adamc@182 94 string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
adamc@182 95 handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n)
adamc@182 96
adamc@182 97 fun p_pat_preamble env (p, _) =
adamc@182 98 case p of
adamc@182 99 PWild => (box [],
adamc@182 100 env)
adamc@182 101 | PVar (x, t) => (box [p_typ env t,
adamc@182 102 space,
adamc@182 103 string "__lwr_",
adamc@182 104 string x,
adamc@182 105 string "_",
adamc@182 106 string (Int.toString (E.countERels env)),
adamc@182 107 string ";",
adamc@182 108 newline],
adamc@182 109 env)
adamc@182 110 | PPrim _ => (box [], env)
adamc@188 111 | PCon (_, _, NONE) => (box [], env)
adamc@188 112 | PCon (_, _, SOME p) => p_pat_preamble env p
adamc@182 113 | PRecord xps =>
adamc@182 114 foldl (fn ((_, p, _), (pp, env)) =>
adamc@182 115 let
adamc@182 116 val (pp', env) = p_pat_preamble env p
adamc@182 117 in
adamc@182 118 (box [pp', pp], env)
adamc@182 119 end) (box [], env) xps
adamc@182 120
adamc@182 121 fun p_patCon env pc =
adamc@182 122 case pc of
adamc@182 123 PConVar n => p_con_named env n
adamc@186 124 | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ con)
adamc@182 125
adamc@182 126 fun p_pat (env, exit, depth) (p, _) =
adamc@182 127 case p of
adamc@182 128 PWild =>
adamc@182 129 (box [], env)
adamc@182 130 | PVar (x, t) =>
adamc@182 131 (box [string "__lwr_",
adamc@182 132 string x,
adamc@182 133 string "_",
adamc@182 134 string (Int.toString (E.countERels env)),
adamc@182 135 space,
adamc@182 136 string "=",
adamc@182 137 space,
adamc@182 138 string "disc",
adamc@182 139 string (Int.toString depth),
adamc@182 140 string ";"],
adamc@182 141 E.pushERel env x t)
adamc@182 142 | PPrim (Prim.Int n) =>
adamc@182 143 (box [string "if",
adamc@182 144 space,
adamc@182 145 string "(disc",
adamc@182 146 string (Int.toString depth),
adamc@182 147 space,
adamc@182 148 string "!=",
adamc@182 149 space,
adamc@182 150 Prim.p_t (Prim.Int n),
adamc@182 151 string ")",
adamc@182 152 space,
adamc@182 153 exit],
adamc@182 154 env)
adamc@182 155 | PPrim (Prim.String s) =>
adamc@182 156 (box [string "if",
adamc@182 157 space,
adamc@182 158 string "(strcmp(disc",
adamc@182 159 string (Int.toString depth),
adamc@182 160 string ",",
adamc@182 161 space,
adamc@182 162 Prim.p_t (Prim.String s),
adamc@182 163 string "))",
adamc@182 164 space,
adamc@182 165 exit],
adamc@182 166 env)
adamc@182 167 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
adamc@182 168
adamc@188 169 | PCon (dk, pc, po) =>
adamc@182 170 let
adamc@182 171 val (p, env) =
adamc@182 172 case po of
adamc@182 173 NONE => (box [], env)
adamc@182 174 | SOME p =>
adamc@182 175 let
adamc@182 176 val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182 177
adamc@182 178 val (x, to) = case pc of
adamc@182 179 PConVar n =>
adamc@182 180 let
adamc@182 181 val (x, to, _) = E.lookupConstructor env n
adamc@182 182 in
adamc@188 183 ("__lwc_" ^ x, to)
adamc@182 184 end
adamc@188 185 | PConFfi {mod = m, con, arg, ...} =>
adamc@188 186 ("lw_" ^ m ^ "_" ^ con, arg)
adamc@182 187
adamc@182 188 val t = case to of
adamc@182 189 NONE => raise Fail "CjrPrint: Constructor mismatch"
adamc@182 190 | SOME t => t
adamc@182 191 in
adamc@182 192 (box [string "{",
adamc@182 193 newline,
adamc@182 194 p_typ env t,
adamc@182 195 space,
adamc@182 196 string "disc",
adamc@182 197 string (Int.toString (depth + 1)),
adamc@182 198 space,
adamc@182 199 string "=",
adamc@182 200 space,
adamc@182 201 string "disc",
adamc@182 202 string (Int.toString depth),
adamc@188 203 string "->data.",
adamc@182 204 string x,
adamc@182 205 string ";",
adamc@182 206 newline,
adamc@182 207 p,
adamc@182 208 newline,
adamc@182 209 string "}"],
adamc@182 210 env)
adamc@182 211 end
adamc@182 212 in
adamc@182 213 (box [string "if",
adamc@182 214 space,
adamc@182 215 string "(disc",
adamc@182 216 string (Int.toString depth),
adamc@188 217 case dk of
adamc@188 218 Enum => box []
adamc@188 219 | Default => string "->tag",
adamc@182 220 space,
adamc@182 221 string "!=",
adamc@182 222 space,
adamc@182 223 p_patCon env pc,
adamc@182 224 string ")",
adamc@182 225 space,
adamc@182 226 exit,
adamc@182 227 newline,
adamc@182 228 p],
adamc@182 229 env)
adamc@182 230 end
adamc@182 231
adamc@182 232 | PRecord xps =>
adamc@182 233 let
adamc@182 234 val (xps, env) =
adamc@182 235 ListUtil.foldlMap (fn ((x, p, t), env) =>
adamc@182 236 let
adamc@182 237 val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182 238
adamc@182 239 val p = box [string "{",
adamc@182 240 newline,
adamc@182 241 p_typ env t,
adamc@182 242 space,
adamc@182 243 string "disc",
adamc@182 244 string (Int.toString (depth + 1)),
adamc@182 245 space,
adamc@182 246 string "=",
adamc@182 247 space,
adamc@182 248 string "disc",
adamc@182 249 string (Int.toString depth),
adamc@182 250 string ".",
adamc@182 251 string x,
adamc@182 252 string ";",
adamc@182 253 newline,
adamc@182 254 p,
adamc@182 255 newline,
adamc@182 256 string "}"]
adamc@182 257 in
adamc@182 258 (p, env)
adamc@182 259 end) env xps
adamc@182 260 in
adamc@182 261 (p_list_sep newline (fn x => x) xps,
adamc@182 262 env)
adamc@182 263 end
adamc@182 264
adamc@182 265 local
adamc@182 266 val count = ref 0
adamc@182 267 in
adamc@182 268 fun newGoto () =
adamc@182 269 let
adamc@182 270 val r = !count
adamc@182 271 in
adamc@182 272 count := r + 1;
adamc@182 273 string ("L" ^ Int.toString r)
adamc@182 274 end
adamc@182 275 end
adamc@182 276
adamc@185 277 fun patConInfo env pc =
adamc@185 278 case pc of
adamc@185 279 PConVar n =>
adamc@185 280 let
adamc@185 281 val (x, _, dn) = E.lookupConstructor env n
adamc@185 282 val (dx, _) = E.lookupDatatype env dn
adamc@185 283 in
adamc@185 284 ("__lwd_" ^ dx ^ "_" ^ Int.toString dn,
adamc@185 285 "__lwc_" ^ x ^ "_" ^ Int.toString n)
adamc@185 286 end
adamc@186 287 | PConFfi {mod = m, datatyp, con, ...} =>
adamc@185 288 ("lw_" ^ m ^ "_" ^ datatyp,
adamc@185 289 "lw_" ^ m ^ "_" ^ con)
adamc@185 290
adamc@182 291 fun p_exp' par env (e, loc) =
adamc@29 292 case e of
adamc@29 293 EPrim p => Prim.p_t p
adamc@29 294 | ERel n => p_rel env n
adamc@109 295 | ENamed n => p_enamed env n
adamc@188 296 | ECon (Enum, pc, _) => p_patCon env pc
adamc@188 297 | ECon (Default, pc, eo) =>
adamc@181 298 let
adamc@185 299 val (xd, xc) = patConInfo env pc
adamc@181 300 in
adamc@182 301 box [string "({",
adamc@181 302 newline,
adamc@181 303 string "struct",
adamc@181 304 space,
adamc@185 305 string xd,
adamc@181 306 space,
adamc@181 307 string "*tmp",
adamc@181 308 space,
adamc@181 309 string "=",
adamc@181 310 space,
adamc@185 311 string "lw_malloc(ctx, sizeof(struct ",
adamc@185 312 string xd,
adamc@181 313 string "));",
adamc@181 314 newline,
adamc@181 315 string "tmp->tag",
adamc@181 316 space,
adamc@181 317 string "=",
adamc@181 318 space,
adamc@185 319 string xc,
adamc@181 320 string ";",
adamc@181 321 newline,
adamc@181 322 case eo of
adamc@181 323 NONE => box []
adamc@185 324 | SOME e => box [string "tmp->data.",
adamc@185 325 string xd,
adamc@181 326 space,
adamc@181 327 string "=",
adamc@181 328 space,
adamc@181 329 p_exp env e,
adamc@181 330 string ";",
adamc@181 331 newline],
adamc@181 332 string "tmp;",
adamc@181 333 newline,
adamc@181 334 string "})"]
adamc@181 335 end
adamc@109 336
adamc@53 337 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53 338 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 339 string m,
adamc@53 340 string "_",
adamc@53 341 string x,
adamc@117 342 string "(ctx, ",
adamc@53 343 p_list (p_exp env) es,
adamc@53 344 string ")"]
adamc@129 345 | EApp (e1, e2) =>
adamc@129 346 let
adamc@129 347 fun unravel (f, acc) =
adamc@129 348 case #1 f of
adamc@129 349 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 350 | _ => (f, acc)
adamc@129 351
adamc@129 352 val (f, args) = unravel (e1, [e2])
adamc@129 353 in
adamc@129 354 parenIf par (box [p_exp' true env e1,
adamc@129 355 string "(ctx,",
adamc@129 356 space,
adamc@129 357 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 358 string ")"])
adamc@129 359 end
adamc@29 360
adamc@29 361 | ERecord (i, xes) => box [string "({",
adamc@29 362 space,
adamc@29 363 string "struct",
adamc@29 364 space,
adamc@29 365 string ("__lws_" ^ Int.toString i),
adamc@29 366 space,
adamc@181 367 string "tmp",
adamc@29 368 space,
adamc@29 369 string "=",
adamc@29 370 space,
adamc@29 371 string "{",
adamc@29 372 p_list (fn (_, e) =>
adamc@29 373 p_exp env e) xes,
adamc@29 374 string "};",
adamc@29 375 space,
adamc@181 376 string "tmp;",
adamc@29 377 space,
adamc@29 378 string "})" ]
adamc@29 379 | EField (e, x) =>
adamc@29 380 box [p_exp' true env e,
adamc@182 381 string ".__lwf_",
adamc@29 382 string x]
adamc@29 383
adamc@182 384 | ECase (e, pes, {disc, result}) =>
adamc@182 385 let
adamc@182 386 val final = newGoto ()
adamc@182 387
adamc@182 388 val body = foldl (fn ((p, e), body) =>
adamc@182 389 let
adamc@182 390 val exit = newGoto ()
adamc@182 391 val (pr, _) = p_pat_preamble env p
adamc@182 392 val (p, env) = p_pat (env,
adamc@182 393 box [string "goto",
adamc@182 394 space,
adamc@182 395 exit,
adamc@182 396 string ";"],
adamc@182 397 0) p
adamc@182 398 in
adamc@182 399 box [body,
adamc@182 400 box [string "{",
adamc@182 401 newline,
adamc@182 402 pr,
adamc@182 403 newline,
adamc@182 404 p,
adamc@182 405 newline,
adamc@182 406 string "result",
adamc@182 407 space,
adamc@182 408 string "=",
adamc@182 409 space,
adamc@182 410 p_exp env e,
adamc@182 411 string ";",
adamc@182 412 newline,
adamc@182 413 string "goto",
adamc@182 414 space,
adamc@182 415 final,
adamc@182 416 string ";",
adamc@182 417 newline,
adamc@182 418 string "}"],
adamc@182 419 newline,
adamc@182 420 exit,
adamc@182 421 string ":",
adamc@182 422 newline]
adamc@182 423 end) (box []) pes
adamc@182 424 in
adamc@182 425 box [string "({",
adamc@182 426 newline,
adamc@182 427 p_typ env disc,
adamc@182 428 space,
adamc@182 429 string "disc0",
adamc@182 430 space,
adamc@182 431 string "=",
adamc@182 432 space,
adamc@182 433 p_exp env e,
adamc@182 434 string ";",
adamc@182 435 newline,
adamc@182 436 p_typ env result,
adamc@182 437 space,
adamc@182 438 string "result;",
adamc@182 439 newline,
adamc@182 440 body,
adamc@182 441 string "lw_error(ctx, FATAL, \"",
adamc@182 442 string (ErrorMsg.spanToString loc),
adamc@182 443 string ": pattern match failure\");",
adamc@182 444 newline,
adamc@182 445 final,
adamc@182 446 string ":",
adamc@182 447 space,
adamc@182 448 string "result;",
adamc@182 449 newline,
adamc@182 450 string "})"]
adamc@182 451 end
adamc@181 452
adamc@117 453 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 454 p_exp env e,
adamc@102 455 string "), lw_unit_v)"]
adamc@102 456
adamc@106 457 | ESeq (e1, e2) => box [string "(",
adamc@106 458 p_exp env e1,
adamc@106 459 string ",",
adamc@106 460 space,
adamc@106 461 p_exp env e2,
adamc@106 462 string ")"]
adamc@106 463
adamc@29 464 and p_exp env = p_exp' false env
adamc@29 465
adamc@129 466 fun p_fun env (fx, n, args, ran, e) =
adamc@129 467 let
adamc@129 468 val nargs = length args
adamc@129 469 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 470 in
adamc@129 471 box [string "static",
adamc@129 472 space,
adamc@129 473 p_typ env ran,
adamc@129 474 space,
adamc@129 475 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 476 string "(",
adamc@129 477 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 478 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 479 box [p_typ env dom,
adamc@129 480 space,
adamc@129 481 p_rel env' (nargs - i - 1)]) args),
adamc@129 482 string ")",
adamc@129 483 space,
adamc@129 484 string "{",
adamc@129 485 newline,
adamc@129 486 box[string "return(",
adamc@129 487 p_exp env' e,
adamc@129 488 string ");"],
adamc@129 489 newline,
adamc@129 490 string "}"]
adamc@129 491 end
adamc@129 492
adamc@129 493 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 494 case d of
adamc@29 495 DStruct (n, xts) =>
adamc@29 496 box [string "struct",
adamc@29 497 space,
adamc@29 498 string ("__lws_" ^ Int.toString n),
adamc@29 499 space,
adamc@29 500 string "{",
adamc@29 501 newline,
adamc@29 502 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 503 space,
adamc@182 504 string "__lwf_",
adamc@29 505 string x,
adamc@29 506 string ";",
adamc@29 507 newline]) xts,
adamc@29 508 string "};"]
adamc@188 509 | DDatatype (Enum, x, n, xncs) =>
adamc@188 510 box [string "enum",
adamc@188 511 space,
adamc@188 512 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@188 513 space,
adamc@188 514 string "{",
adamc@188 515 space,
adamc@188 516 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@188 517 space,
adamc@188 518 string "};"]
adamc@188 519 | DDatatype (Default, x, n, xncs) =>
adamc@165 520 let
adamc@165 521 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@165 522 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@165 523 in
adamc@165 524 box [string "enum",
adamc@165 525 space,
adamc@165 526 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 527 space,
adamc@165 528 string "{",
adamc@165 529 space,
adamc@165 530 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@165 531 space,
adamc@165 532 string "};",
adamc@165 533 newline,
adamc@165 534 newline,
adamc@165 535 string "struct",
adamc@165 536 space,
adamc@167 537 string ("__lwd_" ^ x ^ "_" ^ Int.toString n),
adamc@165 538 space,
adamc@165 539 string "{",
adamc@165 540 newline,
adamc@165 541 string "enum",
adamc@165 542 space,
adamc@165 543 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 544 space,
adamc@165 545 string "tag;",
adamc@165 546 newline,
adamc@165 547 box (case xncsArgs of
adamc@165 548 [] => []
adamc@165 549 | _ => [string "union",
adamc@165 550 space,
adamc@165 551 string "{",
adamc@165 552 newline,
adamc@165 553 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@165 554 space,
adamc@165 555 string ("__lwc_" ^ x),
adamc@165 556 string ";"]) xncsArgs,
adamc@165 557 newline,
adamc@165 558 string "}",
adamc@165 559 space,
adamc@165 560 string "data;",
adamc@165 561 newline]),
adamc@165 562 string "};"]
adamc@188 563 end
adamc@29 564
adamc@29 565 | DVal (x, n, t, e) =>
adamc@29 566 box [p_typ env t,
adamc@29 567 space,
adamc@29 568 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 569 space,
adamc@29 570 string "=",
adamc@29 571 space,
adamc@29 572 p_exp env e,
adamc@29 573 string ";"]
adamc@129 574 | DFun vi => p_fun env vi
adamc@129 575 | DFunRec vis =>
adamc@29 576 let
adamc@129 577 val env = E.declBinds env dAll
adamc@29 578 in
adamc@129 579 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 580 box [string "static",
adamc@129 581 space,
adamc@129 582 p_typ env ran,
adamc@129 583 space,
adamc@129 584 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 585 string "(lw_context,",
adamc@129 586 space,
adamc@129 587 p_list_sep (box [string ",", space])
adamc@129 588 (fn (_, dom) => p_typ env dom) args,
adamc@129 589 string ");"]) vis,
adamc@29 590 newline,
adamc@129 591 p_list_sep newline (p_fun env) vis,
adamc@129 592 newline]
adamc@29 593 end
adamc@29 594
adamc@144 595 datatype 'a search =
adamc@144 596 Found of 'a
adamc@144 597 | NotFound
adamc@144 598 | Error
adamc@120 599
adamc@101 600
adamc@101 601 fun p_file env (ds, ps) =
adamc@29 602 let
adamc@101 603 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 604 (p_decl env d,
adamc@31 605 E.declBinds env d))
adamc@101 606 env ds
adamc@144 607
adamc@144 608 val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144 609 case ek of
adamc@144 610 Core.Link => fields
adamc@144 611 | Core.Action =>
adamc@144 612 case List.last ts of
adamc@144 613 (TRecord i, _) =>
adamc@144 614 let
adamc@144 615 val xts = E.lookupStruct env i
adamc@144 616 val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144 617 in
adamc@144 618 foldl (fn ((x, _), fields) =>
adamc@144 619 let
adamc@144 620 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144 621 in
adamc@144 622 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144 623 xtsSet'))
adamc@144 624 end) fields xts
adamc@144 625 end
adamc@144 626 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144 627 SM.empty ps
adamc@144 628
adamc@144 629 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 630 let
adamc@144 631 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 632 case SM.find (fnums, x') of
adamc@144 633 NONE => unusable
adamc@144 634 | SOME n => IS.add (unusable, n))
adamc@144 635 IS.empty xs
adamc@144 636
adamc@144 637 fun findAvailable n =
adamc@144 638 if IS.member (unusable, n) then
adamc@144 639 findAvailable (n + 1)
adamc@144 640 else
adamc@144 641 n
adamc@144 642 in
adamc@144 643 SM.insert (fnums, x, findAvailable 0)
adamc@144 644 end)
adamc@144 645 SM.empty fields
adamc@144 646
adamc@144 647 fun makeSwitch (fnums, i) =
adamc@144 648 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 649 | (n, Error) => Error
adamc@144 650 | (n, Found n') => if n = n' then
adamc@144 651 Found n'
adamc@144 652 else
adamc@144 653 Error) NotFound fnums of
adamc@144 654 NotFound => box [string "return",
adamc@144 655 space,
adamc@144 656 string "-1;"]
adamc@144 657 | Found n => box [string "return",
adamc@144 658 space,
adamc@144 659 string (Int.toString n),
adamc@144 660 string ";"]
adamc@144 661 | Error =>
adamc@144 662 let
adamc@144 663 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 664 let
adamc@144 665 val ch = if i < size x then
adamc@144 666 String.sub (x, i)
adamc@144 667 else
adamc@144 668 chr 0
adamc@144 669
adamc@144 670 val fnums = case CM.find (cmap, ch) of
adamc@144 671 NONE => SM.empty
adamc@144 672 | SOME fnums => fnums
adamc@144 673 val fnums = SM.insert (fnums, x, n)
adamc@144 674 in
adamc@144 675 CM.insert (cmap, ch, fnums)
adamc@144 676 end)
adamc@144 677 CM.empty fnums
adamc@144 678
adamc@144 679 val cmap = CM.listItemsi cmap
adamc@144 680 in
adamc@144 681 case cmap of
adamc@144 682 [(_, fnums)] =>
adamc@144 683 box [string "if",
adamc@144 684 space,
adamc@144 685 string "(name[",
adamc@144 686 string (Int.toString i),
adamc@144 687 string "]",
adamc@144 688 space,
adamc@144 689 string "==",
adamc@144 690 space,
adamc@144 691 string "0)",
adamc@144 692 space,
adamc@144 693 string "return",
adamc@144 694 space,
adamc@144 695 string "-1;",
adamc@144 696 newline,
adamc@144 697 makeSwitch (fnums, i+1)]
adamc@144 698 | _ =>
adamc@144 699 box [string "switch",
adamc@144 700 space,
adamc@144 701 string "(name[",
adamc@144 702 string (Int.toString i),
adamc@144 703 string "])",
adamc@144 704 space,
adamc@144 705 string "{",
adamc@144 706 newline,
adamc@144 707 box (map (fn (ch, fnums) =>
adamc@144 708 box [string "case",
adamc@144 709 space,
adamc@144 710 if ch = chr 0 then
adamc@144 711 string "0:"
adamc@144 712 else
adamc@144 713 box [string "'",
adamc@144 714 string (Char.toString ch),
adamc@144 715 string "':"],
adamc@144 716 newline,
adamc@144 717 makeSwitch (fnums, i+1),
adamc@144 718 newline]) cmap),
adamc@144 719 string "default:",
adamc@144 720 newline,
adamc@144 721 string "return",
adamc@144 722 space,
adamc@144 723 string "-1;",
adamc@144 724 newline,
adamc@144 725 string "}"]
adamc@144 726 end
adamc@144 727
adamc@186 728 fun capitalize s =
adamc@186 729 if s = "" then
adamc@186 730 ""
adamc@186 731 else
adamc@186 732 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@186 733
adamc@144 734 fun unurlify (t, loc) =
adamc@144 735 case t of
adamc@186 736 TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
adamc@144 737
adamc@144 738 | TRecord 0 => string "lw_unit_v"
adamc@144 739 | TRecord i =>
adamc@144 740 let
adamc@144 741 val xts = E.lookupStruct env i
adamc@144 742 in
adamc@144 743 box [string "({",
adamc@144 744 newline,
adamc@144 745 box (map (fn (x, t) =>
adamc@144 746 box [p_typ env t,
adamc@144 747 space,
adamc@144 748 string x,
adamc@144 749 space,
adamc@144 750 string "=",
adamc@144 751 space,
adamc@144 752 unurlify t,
adamc@144 753 string ";",
adamc@144 754 newline]) xts),
adamc@144 755 string "struct",
adamc@144 756 space,
adamc@144 757 string "__lws_",
adamc@144 758 string (Int.toString i),
adamc@144 759 space,
adamc@181 760 string "tmp",
adamc@144 761 space,
adamc@144 762 string "=",
adamc@144 763 space,
adamc@144 764 string "{",
adamc@144 765 space,
adamc@144 766 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144 767 space,
adamc@144 768 string "};",
adamc@144 769 newline,
adamc@181 770 string "tmp;",
adamc@144 771 newline,
adamc@144 772 string "})"]
adamc@144 773 end
adamc@144 774
adamc@188 775 | TDatatype (Enum, i, _) =>
adamc@188 776 let
adamc@188 777 val (x, xncs) = E.lookupDatatype env i
adamc@188 778
adamc@188 779 fun doEm xncs =
adamc@188 780 case xncs of
adamc@188 781 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_"
adamc@188 782 ^ x ^ "_" ^ Int.toString i ^ ")0)")
adamc@188 783 | (x', n, to) :: rest =>
adamc@188 784 box [string "((!strncmp(request, \"",
adamc@188 785 string x',
adamc@188 786 string "\", ",
adamc@188 787 string (Int.toString (size x')),
adamc@188 788 string ") && (request[",
adamc@188 789 string (Int.toString (size x')),
adamc@188 790 string "] == 0 || request[",
adamc@188 791 string (Int.toString (size x')),
adamc@188 792 string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@188 793 space,
adamc@188 794 string ":",
adamc@188 795 space,
adamc@188 796 doEm rest,
adamc@188 797 string ")"]
adamc@188 798 in
adamc@188 799 doEm xncs
adamc@188 800 end
adamc@188 801
adamc@188 802 | TDatatype (Default, i, _) =>
adamc@166 803 let
adamc@166 804 val (x, xncs) = E.lookupDatatype env i
adamc@166 805
adamc@166 806 fun doEm xncs =
adamc@166 807 case xncs of
adamc@167 808 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
adamc@167 809 | (x', n, to) :: rest =>
adamc@167 810 box [string "((!strncmp(request, \"",
adamc@167 811 string x',
adamc@167 812 string "\", ",
adamc@167 813 string (Int.toString (size x')),
adamc@167 814 string ") && (request[",
adamc@167 815 string (Int.toString (size x')),
adamc@167 816 string "] == 0 || request[",
adamc@167 817 string (Int.toString (size x')),
adamc@167 818 string "] == '/')) ? ({",
adamc@166 819 newline,
adamc@167 820 string "struct",
adamc@167 821 space,
adamc@166 822 string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
adamc@166 823 space,
adamc@181 824 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
adamc@167 825 string x,
adamc@167 826 string "_",
adamc@167 827 string (Int.toString i),
adamc@167 828 string "));",
adamc@166 829 newline,
adamc@181 830 string "tmp->tag",
adamc@166 831 space,
adamc@166 832 string "=",
adamc@166 833 space,
adamc@167 834 string ("__lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@166 835 string ";",
adamc@166 836 newline,
adamc@166 837 string "request",
adamc@166 838 space,
adamc@166 839 string "+=",
adamc@166 840 space,
adamc@167 841 string (Int.toString (size x')),
adamc@166 842 string ";",
adamc@166 843 newline,
adamc@167 844 string "if (request[0] == '/') ++request;",
adamc@167 845 newline,
adamc@166 846 case to of
adamc@166 847 NONE => box []
adamc@182 848 | SOME t => box [string "tmp->data.__lwc_",
adamc@167 849 string x',
adamc@166 850 space,
adamc@166 851 string "=",
adamc@166 852 space,
adamc@166 853 unurlify t,
adamc@166 854 string ";",
adamc@166 855 newline],
adamc@181 856 string "tmp;",
adamc@166 857 newline,
adamc@166 858 string "})",
adamc@166 859 space,
adamc@166 860 string ":",
adamc@166 861 space,
adamc@166 862 doEm rest,
adamc@166 863 string ")"]
adamc@166 864 in
adamc@166 865 doEm xncs
adamc@166 866 end
adamc@166 867
adamc@144 868 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144 869 space)
adamc@144 870
adamc@144 871
adamc@144 872 fun p_page (ek, s, n, ts) =
adamc@144 873 let
adamc@144 874 val (ts, defInputs, inputsVar) =
adamc@144 875 case ek of
adamc@144 876 Core.Link => (ts, string "", string "")
adamc@144 877 | Core.Action =>
adamc@144 878 case List.last ts of
adamc@144 879 (TRecord i, _) =>
adamc@144 880 let
adamc@144 881 val xts = E.lookupStruct env i
adamc@144 882 in
adamc@144 883 (List.drop (ts, 1),
adamc@144 884 box [box (map (fn (x, t) => box [p_typ env t,
adamc@144 885 space,
adamc@144 886 string "lw_input_",
adamc@144 887 string x,
adamc@144 888 string ";",
adamc@144 889 newline]) xts),
adamc@144 890 newline,
adamc@144 891 box (map (fn (x, t) =>
adamc@144 892 let
adamc@144 893 val n = case SM.find (fnums, x) of
adamc@144 894 NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144 895 | SOME n => n
adamc@190 896
adamc@190 897 val f = case t of
adamc@190 898 (TFfi ("Basis", "bool"), _) => "optional_"
adamc@190 899 | _ => ""
adamc@144 900 in
adamc@190 901 box [string "request = lw_get_",
adamc@190 902 string f,
adamc@190 903 string "input(ctx, ",
adamc@144 904 string (Int.toString n),
adamc@144 905 string ");",
adamc@144 906 newline,
adamc@144 907 string "if (request == NULL) {",
adamc@144 908 newline,
adamc@144 909 box [string "printf(\"Missing input ",
adamc@144 910 string x,
adamc@144 911 string "\\n\");",
adamc@144 912 newline,
adamc@144 913 string "exit(1);"],
adamc@144 914 newline,
adamc@144 915 string "}",
adamc@144 916 newline,
adamc@144 917 string "lw_input_",
adamc@144 918 string x,
adamc@144 919 space,
adamc@144 920 string "=",
adamc@144 921 space,
adamc@144 922 unurlify t,
adamc@144 923 string ";",
adamc@144 924 newline]
adamc@144 925 end) xts),
adamc@144 926 string "struct __lws_",
adamc@144 927 string (Int.toString i),
adamc@144 928 space,
adamc@144 929 string "lw_inputs",
adamc@144 930 space,
adamc@144 931 string "= {",
adamc@144 932 newline,
adamc@144 933 box (map (fn (x, _) => box [string "lw_input_",
adamc@144 934 string x,
adamc@144 935 string ",",
adamc@144 936 newline]) xts),
adamc@144 937 string "};",
adamc@144 938 newline],
adamc@144 939 box [string ",",
adamc@144 940 space,
adamc@144 941 string "lw_inputs"])
adamc@144 942 end
adamc@144 943
adamc@144 944 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144 945 in
adamc@144 946 box [string "if (!strncmp(request, \"",
adamc@144 947 string (String.toString s),
adamc@144 948 string "\", ",
adamc@144 949 string (Int.toString (size s)),
adamc@144 950 string ")) {",
adamc@144 951 newline,
adamc@144 952 string "request += ",
adamc@144 953 string (Int.toString (size s)),
adamc@144 954 string ";",
adamc@144 955 newline,
adamc@144 956 string "if (*request == '/') ++request;",
adamc@144 957 newline,
adamc@144 958 box [string "{",
adamc@144 959 newline,
adamc@144 960 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 961 space,
adamc@144 962 string "arg",
adamc@144 963 string (Int.toString i),
adamc@144 964 space,
adamc@144 965 string "=",
adamc@144 966 space,
adamc@144 967 unurlify t,
adamc@144 968 string ";",
adamc@144 969 newline]) ts),
adamc@144 970 defInputs,
adamc@144 971 p_enamed env n,
adamc@144 972 string "(",
adamc@144 973 p_list_sep (box [string ",", space])
adamc@144 974 (fn x => x)
adamc@144 975 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 976 inputsVar,
adamc@144 977 string ");",
adamc@144 978 newline,
adamc@144 979 string "return;",
adamc@144 980 newline,
adamc@144 981 string "}",
adamc@144 982 newline,
adamc@144 983 string "}"]
adamc@144 984 ]
adamc@144 985 end
adamc@144 986
adamc@144 987 val pds' = map p_page ps
adamc@29 988 in
adamc@144 989 box [string "#include <stdio.h>",
adamc@144 990 newline,
adamc@144 991 string "#include <stdlib.h>",
adamc@144 992 newline,
adamc@144 993 newline,
adamc@144 994 string "#include \"lacweb.h\"",
adamc@101 995 newline,
adamc@101 996 newline,
adamc@101 997 p_list_sep newline (fn x => x) pds,
adamc@101 998 newline,
adamc@144 999 string "int lw_inputs_len = ",
adamc@144 1000 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144 1001 string ";",
adamc@144 1002 newline,
adamc@144 1003 newline,
adamc@144 1004 string "int lw_input_num(char *name) {",
adamc@144 1005 newline,
adamc@144 1006 string "if",
adamc@144 1007 space,
adamc@144 1008 string "(name[0]",
adamc@144 1009 space,
adamc@144 1010 string "==",
adamc@144 1011 space,
adamc@144 1012 string "0)",
adamc@144 1013 space,
adamc@144 1014 string "return",
adamc@144 1015 space,
adamc@144 1016 string "-1;",
adamc@144 1017 newline,
adamc@144 1018 makeSwitch (fnums, 0),
adamc@144 1019 string "}",
adamc@144 1020 newline,
adamc@144 1021 newline,
adamc@117 1022 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 1023 newline,
adamc@101 1024 p_list_sep newline (fn x => x) pds',
adamc@101 1025 newline,
adamc@101 1026 string "}",
adamc@101 1027 newline]
adamc@29 1028 end
adamc@29 1029
adamc@29 1030 end