Mercurial > urweb

annotate src/cjr_print.sml @ 185:19ee24bffbc0

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