Mercurial > urweb

annotate src/cjr_print.sml @ 147:eb16f2aadbe9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Meta-programming forms
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Jul 2008 18:46:04 -0400
parents f0d3402184d1
children e52dfb1e6b19
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@29 56 val dummyTyp = (TNamed 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@29 72 | TNamed n =>
adamc@29 73 (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
adamc@29 74 handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
adamc@53 75 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29 76
adamc@29 77 and p_typ env = p_typ' false env
adamc@29 78
adamc@29 79 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 80 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 81
adamc@109 82 fun p_enamed env n =
adamc@109 83 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109 84 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109 85
adamc@29 86 fun p_exp' par env (e, _) =
adamc@29 87 case e of
adamc@29 88 EPrim p => Prim.p_t p
adamc@29 89 | ERel n => p_rel env n
adamc@109 90 | ENamed n => p_enamed env n
adamc@109 91
adamc@53 92 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53 93 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 94 string m,
adamc@53 95 string "_",
adamc@53 96 string x,
adamc@117 97 string "(ctx, ",
adamc@53 98 p_list (p_exp env) es,
adamc@53 99 string ")"]
adamc@129 100 | EApp (e1, e2) =>
adamc@129 101 let
adamc@129 102 fun unravel (f, acc) =
adamc@129 103 case #1 f of
adamc@129 104 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 105 | _ => (f, acc)
adamc@129 106
adamc@129 107 val (f, args) = unravel (e1, [e2])
adamc@129 108 in
adamc@129 109 parenIf par (box [p_exp' true env e1,
adamc@129 110 string "(ctx,",
adamc@129 111 space,
adamc@129 112 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 113 string ")"])
adamc@129 114 end
adamc@29 115
adamc@29 116 | ERecord (i, xes) => box [string "({",
adamc@29 117 space,
adamc@29 118 string "struct",
adamc@29 119 space,
adamc@29 120 string ("__lws_" ^ Int.toString i),
adamc@29 121 space,
adamc@29 122 string "__lw_tmp",
adamc@29 123 space,
adamc@29 124 string "=",
adamc@29 125 space,
adamc@29 126 string "{",
adamc@29 127 p_list (fn (_, e) =>
adamc@29 128 p_exp env e) xes,
adamc@29 129 string "};",
adamc@29 130 space,
adamc@29 131 string "__lw_tmp;",
adamc@29 132 space,
adamc@29 133 string "})" ]
adamc@29 134 | EField (e, x) =>
adamc@29 135 box [p_exp' true env e,
adamc@29 136 string ".",
adamc@29 137 string x]
adamc@29 138
adamc@117 139 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 140 p_exp env e,
adamc@102 141 string "), lw_unit_v)"]
adamc@102 142
adamc@106 143 | ESeq (e1, e2) => box [string "(",
adamc@106 144 p_exp env e1,
adamc@106 145 string ",",
adamc@106 146 space,
adamc@106 147 p_exp env e2,
adamc@106 148 string ")"]
adamc@106 149
adamc@29 150 and p_exp env = p_exp' false env
adamc@29 151
adamc@129 152 fun p_fun env (fx, n, args, ran, e) =
adamc@129 153 let
adamc@129 154 val nargs = length args
adamc@129 155 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 156 in
adamc@129 157 box [string "static",
adamc@129 158 space,
adamc@129 159 p_typ env ran,
adamc@129 160 space,
adamc@129 161 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 162 string "(",
adamc@129 163 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 164 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 165 box [p_typ env dom,
adamc@129 166 space,
adamc@129 167 p_rel env' (nargs - i - 1)]) args),
adamc@129 168 string ")",
adamc@129 169 space,
adamc@129 170 string "{",
adamc@129 171 newline,
adamc@129 172 box[string "return(",
adamc@129 173 p_exp env' e,
adamc@129 174 string ");"],
adamc@129 175 newline,
adamc@129 176 string "}"]
adamc@129 177 end
adamc@129 178
adamc@129 179 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 180 case d of
adamc@29 181 DStruct (n, xts) =>
adamc@29 182 box [string "struct",
adamc@29 183 space,
adamc@29 184 string ("__lws_" ^ Int.toString n),
adamc@29 185 space,
adamc@29 186 string "{",
adamc@29 187 newline,
adamc@29 188 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 189 space,
adamc@29 190 string x,
adamc@29 191 string ";",
adamc@29 192 newline]) xts,
adamc@29 193 string "};"]
adamc@29 194
adamc@29 195 | DVal (x, n, t, e) =>
adamc@29 196 box [p_typ env t,
adamc@29 197 space,
adamc@29 198 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 199 space,
adamc@29 200 string "=",
adamc@29 201 space,
adamc@29 202 p_exp env e,
adamc@29 203 string ";"]
adamc@129 204 | DFun vi => p_fun env vi
adamc@129 205 | DFunRec vis =>
adamc@29 206 let
adamc@129 207 val env = E.declBinds env dAll
adamc@29 208 in
adamc@129 209 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 210 box [string "static",
adamc@129 211 space,
adamc@129 212 p_typ env ran,
adamc@129 213 space,
adamc@129 214 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 215 string "(lw_context,",
adamc@129 216 space,
adamc@129 217 p_list_sep (box [string ",", space])
adamc@129 218 (fn (_, dom) => p_typ env dom) args,
adamc@129 219 string ");"]) vis,
adamc@29 220 newline,
adamc@129 221 p_list_sep newline (p_fun env) vis,
adamc@129 222 newline]
adamc@29 223 end
adamc@29 224
adamc@144 225 datatype 'a search =
adamc@144 226 Found of 'a
adamc@144 227 | NotFound
adamc@144 228 | Error
adamc@120 229
adamc@101 230
adamc@101 231 fun p_file env (ds, ps) =
adamc@29 232 let
adamc@101 233 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 234 (p_decl env d,
adamc@31 235 E.declBinds env d))
adamc@101 236 env ds
adamc@144 237
adamc@144 238 val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144 239 case ek of
adamc@144 240 Core.Link => fields
adamc@144 241 | Core.Action =>
adamc@144 242 case List.last ts of
adamc@144 243 (TRecord i, _) =>
adamc@144 244 let
adamc@144 245 val xts = E.lookupStruct env i
adamc@144 246 val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144 247 in
adamc@144 248 foldl (fn ((x, _), fields) =>
adamc@144 249 let
adamc@144 250 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144 251 in
adamc@144 252 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144 253 xtsSet'))
adamc@144 254 end) fields xts
adamc@144 255 end
adamc@144 256 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144 257 SM.empty ps
adamc@144 258
adamc@144 259 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 260 let
adamc@144 261 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 262 case SM.find (fnums, x') of
adamc@144 263 NONE => unusable
adamc@144 264 | SOME n => IS.add (unusable, n))
adamc@144 265 IS.empty xs
adamc@144 266
adamc@144 267 fun findAvailable n =
adamc@144 268 if IS.member (unusable, n) then
adamc@144 269 findAvailable (n + 1)
adamc@144 270 else
adamc@144 271 n
adamc@144 272 in
adamc@144 273 SM.insert (fnums, x, findAvailable 0)
adamc@144 274 end)
adamc@144 275 SM.empty fields
adamc@144 276
adamc@144 277 fun makeSwitch (fnums, i) =
adamc@144 278 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 279 | (n, Error) => Error
adamc@144 280 | (n, Found n') => if n = n' then
adamc@144 281 Found n'
adamc@144 282 else
adamc@144 283 Error) NotFound fnums of
adamc@144 284 NotFound => box [string "return",
adamc@144 285 space,
adamc@144 286 string "-1;"]
adamc@144 287 | Found n => box [string "return",
adamc@144 288 space,
adamc@144 289 string (Int.toString n),
adamc@144 290 string ";"]
adamc@144 291 | Error =>
adamc@144 292 let
adamc@144 293 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 294 let
adamc@144 295 val ch = if i < size x then
adamc@144 296 String.sub (x, i)
adamc@144 297 else
adamc@144 298 chr 0
adamc@144 299
adamc@144 300 val fnums = case CM.find (cmap, ch) of
adamc@144 301 NONE => SM.empty
adamc@144 302 | SOME fnums => fnums
adamc@144 303 val fnums = SM.insert (fnums, x, n)
adamc@144 304 in
adamc@144 305 CM.insert (cmap, ch, fnums)
adamc@144 306 end)
adamc@144 307 CM.empty fnums
adamc@144 308
adamc@144 309 val cmap = CM.listItemsi cmap
adamc@144 310 in
adamc@144 311 case cmap of
adamc@144 312 [(_, fnums)] =>
adamc@144 313 box [string "if",
adamc@144 314 space,
adamc@144 315 string "(name[",
adamc@144 316 string (Int.toString i),
adamc@144 317 string "]",
adamc@144 318 space,
adamc@144 319 string "==",
adamc@144 320 space,
adamc@144 321 string "0)",
adamc@144 322 space,
adamc@144 323 string "return",
adamc@144 324 space,
adamc@144 325 string "-1;",
adamc@144 326 newline,
adamc@144 327 makeSwitch (fnums, i+1)]
adamc@144 328 | _ =>
adamc@144 329 box [string "switch",
adamc@144 330 space,
adamc@144 331 string "(name[",
adamc@144 332 string (Int.toString i),
adamc@144 333 string "])",
adamc@144 334 space,
adamc@144 335 string "{",
adamc@144 336 newline,
adamc@144 337 box (map (fn (ch, fnums) =>
adamc@144 338 box [string "case",
adamc@144 339 space,
adamc@144 340 if ch = chr 0 then
adamc@144 341 string "0:"
adamc@144 342 else
adamc@144 343 box [string "'",
adamc@144 344 string (Char.toString ch),
adamc@144 345 string "':"],
adamc@144 346 newline,
adamc@144 347 makeSwitch (fnums, i+1),
adamc@144 348 newline]) cmap),
adamc@144 349 string "default:",
adamc@144 350 newline,
adamc@144 351 string "return",
adamc@144 352 space,
adamc@144 353 string "-1;",
adamc@144 354 newline,
adamc@144 355 string "}"]
adamc@144 356 end
adamc@144 357
adamc@144 358 fun unurlify (t, loc) =
adamc@144 359 case t of
adamc@144 360 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@144 361 | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@144 362 | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
adamc@144 363
adamc@144 364 | TRecord 0 => string "lw_unit_v"
adamc@144 365 | TRecord i =>
adamc@144 366 let
adamc@144 367 val xts = E.lookupStruct env i
adamc@144 368 in
adamc@144 369 box [string "({",
adamc@144 370 newline,
adamc@144 371 box (map (fn (x, t) =>
adamc@144 372 box [p_typ env t,
adamc@144 373 space,
adamc@144 374 string x,
adamc@144 375 space,
adamc@144 376 string "=",
adamc@144 377 space,
adamc@144 378 unurlify t,
adamc@144 379 string ";",
adamc@144 380 newline]) xts),
adamc@144 381 string "struct",
adamc@144 382 space,
adamc@144 383 string "__lws_",
adamc@144 384 string (Int.toString i),
adamc@144 385 space,
adamc@144 386 string "__lw_tmp",
adamc@144 387 space,
adamc@144 388 string "=",
adamc@144 389 space,
adamc@144 390 string "{",
adamc@144 391 space,
adamc@144 392 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144 393 space,
adamc@144 394 string "};",
adamc@144 395 newline,
adamc@144 396 string "__lw_tmp;",
adamc@144 397 newline,
adamc@144 398 string "})"]
adamc@144 399 end
adamc@144 400
adamc@144 401 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144 402 space)
adamc@144 403
adamc@144 404
adamc@144 405 fun p_page (ek, s, n, ts) =
adamc@144 406 let
adamc@144 407 val (ts, defInputs, inputsVar) =
adamc@144 408 case ek of
adamc@144 409 Core.Link => (ts, string "", string "")
adamc@144 410 | Core.Action =>
adamc@144 411 case List.last ts of
adamc@144 412 (TRecord i, _) =>
adamc@144 413 let
adamc@144 414 val xts = E.lookupStruct env i
adamc@144 415 in
adamc@144 416 (List.drop (ts, 1),
adamc@144 417 box [box (map (fn (x, t) => box [p_typ env t,
adamc@144 418 space,
adamc@144 419 string "lw_input_",
adamc@144 420 string x,
adamc@144 421 string ";",
adamc@144 422 newline]) xts),
adamc@144 423 newline,
adamc@144 424 box (map (fn (x, t) =>
adamc@144 425 let
adamc@144 426 val n = case SM.find (fnums, x) of
adamc@144 427 NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144 428 | SOME n => n
adamc@144 429 in
adamc@144 430 box [string "request = lw_get_input(ctx, ",
adamc@144 431 string (Int.toString n),
adamc@144 432 string ");",
adamc@144 433 newline,
adamc@144 434 string "if (request == NULL) {",
adamc@144 435 newline,
adamc@144 436 box [string "printf(\"Missing input ",
adamc@144 437 string x,
adamc@144 438 string "\\n\");",
adamc@144 439 newline,
adamc@144 440 string "exit(1);"],
adamc@144 441 newline,
adamc@144 442 string "}",
adamc@144 443 newline,
adamc@144 444 string "lw_input_",
adamc@144 445 string x,
adamc@144 446 space,
adamc@144 447 string "=",
adamc@144 448 space,
adamc@144 449 unurlify t,
adamc@144 450 string ";",
adamc@144 451 newline]
adamc@144 452 end) xts),
adamc@144 453 string "struct __lws_",
adamc@144 454 string (Int.toString i),
adamc@144 455 space,
adamc@144 456 string "lw_inputs",
adamc@144 457 space,
adamc@144 458 string "= {",
adamc@144 459 newline,
adamc@144 460 box (map (fn (x, _) => box [string "lw_input_",
adamc@144 461 string x,
adamc@144 462 string ",",
adamc@144 463 newline]) xts),
adamc@144 464 string "};",
adamc@144 465 newline],
adamc@144 466 box [string ",",
adamc@144 467 space,
adamc@144 468 string "lw_inputs"])
adamc@144 469 end
adamc@144 470
adamc@144 471 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144 472 in
adamc@144 473 box [string "if (!strncmp(request, \"",
adamc@144 474 string (String.toString s),
adamc@144 475 string "\", ",
adamc@144 476 string (Int.toString (size s)),
adamc@144 477 string ")) {",
adamc@144 478 newline,
adamc@144 479 string "request += ",
adamc@144 480 string (Int.toString (size s)),
adamc@144 481 string ";",
adamc@144 482 newline,
adamc@144 483 string "if (*request == '/') ++request;",
adamc@144 484 newline,
adamc@144 485 box [string "{",
adamc@144 486 newline,
adamc@144 487 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 488 space,
adamc@144 489 string "arg",
adamc@144 490 string (Int.toString i),
adamc@144 491 space,
adamc@144 492 string "=",
adamc@144 493 space,
adamc@144 494 unurlify t,
adamc@144 495 string ";",
adamc@144 496 newline]) ts),
adamc@144 497 defInputs,
adamc@144 498 p_enamed env n,
adamc@144 499 string "(",
adamc@144 500 p_list_sep (box [string ",", space])
adamc@144 501 (fn x => x)
adamc@144 502 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 503 inputsVar,
adamc@144 504 string ");",
adamc@144 505 newline,
adamc@144 506 string "return;",
adamc@144 507 newline,
adamc@144 508 string "}",
adamc@144 509 newline,
adamc@144 510 string "}"]
adamc@144 511 ]
adamc@144 512 end
adamc@144 513
adamc@144 514 val pds' = map p_page ps
adamc@29 515 in
adamc@144 516 box [string "#include <stdio.h>",
adamc@144 517 newline,
adamc@144 518 string "#include <stdlib.h>",
adamc@144 519 newline,
adamc@144 520 newline,
adamc@144 521 string "#include \"lacweb.h\"",
adamc@101 522 newline,
adamc@101 523 newline,
adamc@101 524 p_list_sep newline (fn x => x) pds,
adamc@101 525 newline,
adamc@144 526 string "int lw_inputs_len = ",
adamc@144 527 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144 528 string ";",
adamc@144 529 newline,
adamc@144 530 newline,
adamc@144 531 string "int lw_input_num(char *name) {",
adamc@144 532 newline,
adamc@144 533 string "if",
adamc@144 534 space,
adamc@144 535 string "(name[0]",
adamc@144 536 space,
adamc@144 537 string "==",
adamc@144 538 space,
adamc@144 539 string "0)",
adamc@144 540 space,
adamc@144 541 string "return",
adamc@144 542 space,
adamc@144 543 string "-1;",
adamc@144 544 newline,
adamc@144 545 makeSwitch (fnums, 0),
adamc@144 546 string "}",
adamc@144 547 newline,
adamc@144 548 newline,
adamc@117 549 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 550 newline,
adamc@101 551 p_list_sep newline (fn x => x) pds',
adamc@101 552 newline,
adamc@101 553 string "}",
adamc@101 554 newline]
adamc@29 555 end
adamc@29 556
adamc@29 557 end