Mercurial > urweb

annotate src/cjr_print.sml @ 182:d11754ffe252

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