Mercurial > urweb

annotate src/cjr_print.sml @ 181:31dfab1d4050

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cjrize ECon
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 11:17:33 -0400
parents 25b169416ea8
children d11754ffe252
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@29 88 fun p_exp' par env (e, _) =
adamc@29 89 case e of
adamc@29 90 EPrim p => Prim.p_t p
adamc@29 91 | ERel n => p_rel env n
adamc@109 92 | ENamed n => p_enamed env n
adamc@181 93 | ECon (n, eo) =>
adamc@181 94 let
adamc@181 95 val (x, _, dn) = E.lookupConstructor env n
adamc@181 96 val (dx, _) = E.lookupDatatype env dn
adamc@181 97 in
adamc@181 98 box [string "{(",
adamc@181 99 newline,
adamc@181 100 string "struct",
adamc@181 101 space,
adamc@181 102 string "__lwd_",
adamc@181 103 string dx,
adamc@181 104 string "_",
adamc@181 105 string (Int.toString dn),
adamc@181 106 space,
adamc@181 107 string "*tmp",
adamc@181 108 space,
adamc@181 109 string "=",
adamc@181 110 space,
adamc@181 111 string "lw_malloc(ctx, sizeof(struct __lwd_",
adamc@181 112 string dx,
adamc@181 113 string "_",
adamc@181 114 string (Int.toString dn),
adamc@181 115 string "));",
adamc@181 116 newline,
adamc@181 117 string "tmp->tag",
adamc@181 118 space,
adamc@181 119 string "=",
adamc@181 120 space,
adamc@181 121 string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
adamc@181 122 string ";",
adamc@181 123 newline,
adamc@181 124 case eo of
adamc@181 125 NONE => box []
adamc@181 126 | SOME e => box [string "tmp->data.",
adamc@181 127 string x,
adamc@181 128 space,
adamc@181 129 string "=",
adamc@181 130 space,
adamc@181 131 p_exp env e,
adamc@181 132 string ";",
adamc@181 133 newline],
adamc@181 134 string "tmp;",
adamc@181 135 newline,
adamc@181 136 string "})"]
adamc@181 137 end
adamc@109 138
adamc@53 139 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53 140 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 141 string m,
adamc@53 142 string "_",
adamc@53 143 string x,
adamc@117 144 string "(ctx, ",
adamc@53 145 p_list (p_exp env) es,
adamc@53 146 string ")"]
adamc@129 147 | EApp (e1, e2) =>
adamc@129 148 let
adamc@129 149 fun unravel (f, acc) =
adamc@129 150 case #1 f of
adamc@129 151 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 152 | _ => (f, acc)
adamc@129 153
adamc@129 154 val (f, args) = unravel (e1, [e2])
adamc@129 155 in
adamc@129 156 parenIf par (box [p_exp' true env e1,
adamc@129 157 string "(ctx,",
adamc@129 158 space,
adamc@129 159 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 160 string ")"])
adamc@129 161 end
adamc@29 162
adamc@29 163 | ERecord (i, xes) => box [string "({",
adamc@29 164 space,
adamc@29 165 string "struct",
adamc@29 166 space,
adamc@29 167 string ("__lws_" ^ Int.toString i),
adamc@29 168 space,
adamc@181 169 string "tmp",
adamc@29 170 space,
adamc@29 171 string "=",
adamc@29 172 space,
adamc@29 173 string "{",
adamc@29 174 p_list (fn (_, e) =>
adamc@29 175 p_exp env e) xes,
adamc@29 176 string "};",
adamc@29 177 space,
adamc@181 178 string "tmp;",
adamc@29 179 space,
adamc@29 180 string "})" ]
adamc@29 181 | EField (e, x) =>
adamc@29 182 box [p_exp' true env e,
adamc@29 183 string ".",
adamc@29 184 string x]
adamc@29 185
adamc@181 186 | ECase _ => raise Fail "CjrPrint ECase"
adamc@181 187
adamc@117 188 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 189 p_exp env e,
adamc@102 190 string "), lw_unit_v)"]
adamc@102 191
adamc@106 192 | ESeq (e1, e2) => box [string "(",
adamc@106 193 p_exp env e1,
adamc@106 194 string ",",
adamc@106 195 space,
adamc@106 196 p_exp env e2,
adamc@106 197 string ")"]
adamc@106 198
adamc@29 199 and p_exp env = p_exp' false env
adamc@29 200
adamc@129 201 fun p_fun env (fx, n, args, ran, e) =
adamc@129 202 let
adamc@129 203 val nargs = length args
adamc@129 204 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 205 in
adamc@129 206 box [string "static",
adamc@129 207 space,
adamc@129 208 p_typ env ran,
adamc@129 209 space,
adamc@129 210 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 211 string "(",
adamc@129 212 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 213 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 214 box [p_typ env dom,
adamc@129 215 space,
adamc@129 216 p_rel env' (nargs - i - 1)]) args),
adamc@129 217 string ")",
adamc@129 218 space,
adamc@129 219 string "{",
adamc@129 220 newline,
adamc@129 221 box[string "return(",
adamc@129 222 p_exp env' e,
adamc@129 223 string ");"],
adamc@129 224 newline,
adamc@129 225 string "}"]
adamc@129 226 end
adamc@129 227
adamc@129 228 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 229 case d of
adamc@29 230 DStruct (n, xts) =>
adamc@29 231 box [string "struct",
adamc@29 232 space,
adamc@29 233 string ("__lws_" ^ Int.toString n),
adamc@29 234 space,
adamc@29 235 string "{",
adamc@29 236 newline,
adamc@29 237 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 238 space,
adamc@29 239 string x,
adamc@29 240 string ";",
adamc@29 241 newline]) xts,
adamc@29 242 string "};"]
adamc@165 243 | DDatatype (x, n, xncs) =>
adamc@165 244 let
adamc@165 245 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@165 246 | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@165 247 in
adamc@165 248 box [string "enum",
adamc@165 249 space,
adamc@165 250 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 251 space,
adamc@165 252 string "{",
adamc@165 253 space,
adamc@165 254 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@165 255 space,
adamc@165 256 string "};",
adamc@165 257 newline,
adamc@165 258 newline,
adamc@165 259 string "struct",
adamc@165 260 space,
adamc@167 261 string ("__lwd_" ^ x ^ "_" ^ Int.toString n),
adamc@165 262 space,
adamc@165 263 string "{",
adamc@165 264 newline,
adamc@165 265 string "enum",
adamc@165 266 space,
adamc@165 267 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165 268 space,
adamc@165 269 string "tag;",
adamc@165 270 newline,
adamc@165 271 box (case xncsArgs of
adamc@165 272 [] => []
adamc@165 273 | _ => [string "union",
adamc@165 274 space,
adamc@165 275 string "{",
adamc@165 276 newline,
adamc@165 277 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@165 278 space,
adamc@165 279 string ("__lwc_" ^ x),
adamc@165 280 string ";"]) xncsArgs,
adamc@165 281 newline,
adamc@165 282 string "}",
adamc@165 283 space,
adamc@165 284 string "data;",
adamc@165 285 newline]),
adamc@165 286 string "};"]
adamc@165 287 end
adamc@29 288
adamc@29 289 | DVal (x, n, t, e) =>
adamc@29 290 box [p_typ env t,
adamc@29 291 space,
adamc@29 292 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 293 space,
adamc@29 294 string "=",
adamc@29 295 space,
adamc@29 296 p_exp env e,
adamc@29 297 string ";"]
adamc@129 298 | DFun vi => p_fun env vi
adamc@129 299 | DFunRec vis =>
adamc@29 300 let
adamc@129 301 val env = E.declBinds env dAll
adamc@29 302 in
adamc@129 303 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 304 box [string "static",
adamc@129 305 space,
adamc@129 306 p_typ env ran,
adamc@129 307 space,
adamc@129 308 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 309 string "(lw_context,",
adamc@129 310 space,
adamc@129 311 p_list_sep (box [string ",", space])
adamc@129 312 (fn (_, dom) => p_typ env dom) args,
adamc@129 313 string ");"]) vis,
adamc@29 314 newline,
adamc@129 315 p_list_sep newline (p_fun env) vis,
adamc@129 316 newline]
adamc@29 317 end
adamc@29 318
adamc@144 319 datatype 'a search =
adamc@144 320 Found of 'a
adamc@144 321 | NotFound
adamc@144 322 | Error
adamc@120 323
adamc@101 324
adamc@101 325 fun p_file env (ds, ps) =
adamc@29 326 let
adamc@101 327 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 328 (p_decl env d,
adamc@31 329 E.declBinds env d))
adamc@101 330 env ds
adamc@144 331
adamc@144 332 val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144 333 case ek of
adamc@144 334 Core.Link => fields
adamc@144 335 | Core.Action =>
adamc@144 336 case List.last ts of
adamc@144 337 (TRecord i, _) =>
adamc@144 338 let
adamc@144 339 val xts = E.lookupStruct env i
adamc@144 340 val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144 341 in
adamc@144 342 foldl (fn ((x, _), fields) =>
adamc@144 343 let
adamc@144 344 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144 345 in
adamc@144 346 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144 347 xtsSet'))
adamc@144 348 end) fields xts
adamc@144 349 end
adamc@144 350 | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144 351 SM.empty ps
adamc@144 352
adamc@144 353 val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144 354 let
adamc@144 355 val unusable = SS.foldl (fn (x', unusable) =>
adamc@144 356 case SM.find (fnums, x') of
adamc@144 357 NONE => unusable
adamc@144 358 | SOME n => IS.add (unusable, n))
adamc@144 359 IS.empty xs
adamc@144 360
adamc@144 361 fun findAvailable n =
adamc@144 362 if IS.member (unusable, n) then
adamc@144 363 findAvailable (n + 1)
adamc@144 364 else
adamc@144 365 n
adamc@144 366 in
adamc@144 367 SM.insert (fnums, x, findAvailable 0)
adamc@144 368 end)
adamc@144 369 SM.empty fields
adamc@144 370
adamc@144 371 fun makeSwitch (fnums, i) =
adamc@144 372 case SM.foldl (fn (n, NotFound) => Found n
adamc@144 373 | (n, Error) => Error
adamc@144 374 | (n, Found n') => if n = n' then
adamc@144 375 Found n'
adamc@144 376 else
adamc@144 377 Error) NotFound fnums of
adamc@144 378 NotFound => box [string "return",
adamc@144 379 space,
adamc@144 380 string "-1;"]
adamc@144 381 | Found n => box [string "return",
adamc@144 382 space,
adamc@144 383 string (Int.toString n),
adamc@144 384 string ";"]
adamc@144 385 | Error =>
adamc@144 386 let
adamc@144 387 val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144 388 let
adamc@144 389 val ch = if i < size x then
adamc@144 390 String.sub (x, i)
adamc@144 391 else
adamc@144 392 chr 0
adamc@144 393
adamc@144 394 val fnums = case CM.find (cmap, ch) of
adamc@144 395 NONE => SM.empty
adamc@144 396 | SOME fnums => fnums
adamc@144 397 val fnums = SM.insert (fnums, x, n)
adamc@144 398 in
adamc@144 399 CM.insert (cmap, ch, fnums)
adamc@144 400 end)
adamc@144 401 CM.empty fnums
adamc@144 402
adamc@144 403 val cmap = CM.listItemsi cmap
adamc@144 404 in
adamc@144 405 case cmap of
adamc@144 406 [(_, fnums)] =>
adamc@144 407 box [string "if",
adamc@144 408 space,
adamc@144 409 string "(name[",
adamc@144 410 string (Int.toString i),
adamc@144 411 string "]",
adamc@144 412 space,
adamc@144 413 string "==",
adamc@144 414 space,
adamc@144 415 string "0)",
adamc@144 416 space,
adamc@144 417 string "return",
adamc@144 418 space,
adamc@144 419 string "-1;",
adamc@144 420 newline,
adamc@144 421 makeSwitch (fnums, i+1)]
adamc@144 422 | _ =>
adamc@144 423 box [string "switch",
adamc@144 424 space,
adamc@144 425 string "(name[",
adamc@144 426 string (Int.toString i),
adamc@144 427 string "])",
adamc@144 428 space,
adamc@144 429 string "{",
adamc@144 430 newline,
adamc@144 431 box (map (fn (ch, fnums) =>
adamc@144 432 box [string "case",
adamc@144 433 space,
adamc@144 434 if ch = chr 0 then
adamc@144 435 string "0:"
adamc@144 436 else
adamc@144 437 box [string "'",
adamc@144 438 string (Char.toString ch),
adamc@144 439 string "':"],
adamc@144 440 newline,
adamc@144 441 makeSwitch (fnums, i+1),
adamc@144 442 newline]) cmap),
adamc@144 443 string "default:",
adamc@144 444 newline,
adamc@144 445 string "return",
adamc@144 446 space,
adamc@144 447 string "-1;",
adamc@144 448 newline,
adamc@144 449 string "}"]
adamc@144 450 end
adamc@144 451
adamc@144 452 fun unurlify (t, loc) =
adamc@144 453 case t of
adamc@144 454 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@144 455 | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@144 456 | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
adamc@144 457
adamc@144 458 | TRecord 0 => string "lw_unit_v"
adamc@144 459 | TRecord i =>
adamc@144 460 let
adamc@144 461 val xts = E.lookupStruct env i
adamc@144 462 in
adamc@144 463 box [string "({",
adamc@144 464 newline,
adamc@144 465 box (map (fn (x, t) =>
adamc@144 466 box [p_typ env t,
adamc@144 467 space,
adamc@144 468 string x,
adamc@144 469 space,
adamc@144 470 string "=",
adamc@144 471 space,
adamc@144 472 unurlify t,
adamc@144 473 string ";",
adamc@144 474 newline]) xts),
adamc@144 475 string "struct",
adamc@144 476 space,
adamc@144 477 string "__lws_",
adamc@144 478 string (Int.toString i),
adamc@144 479 space,
adamc@181 480 string "tmp",
adamc@144 481 space,
adamc@144 482 string "=",
adamc@144 483 space,
adamc@144 484 string "{",
adamc@144 485 space,
adamc@144 486 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144 487 space,
adamc@144 488 string "};",
adamc@144 489 newline,
adamc@181 490 string "tmp;",
adamc@144 491 newline,
adamc@144 492 string "})"]
adamc@144 493 end
adamc@144 494
adamc@168 495 | TDatatype (i, _) =>
adamc@166 496 let
adamc@166 497 val (x, xncs) = E.lookupDatatype env i
adamc@166 498
adamc@166 499 fun doEm xncs =
adamc@166 500 case xncs of
adamc@167 501 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
adamc@167 502 | (x', n, to) :: rest =>
adamc@167 503 box [string "((!strncmp(request, \"",
adamc@167 504 string x',
adamc@167 505 string "\", ",
adamc@167 506 string (Int.toString (size x')),
adamc@167 507 string ") && (request[",
adamc@167 508 string (Int.toString (size x')),
adamc@167 509 string "] == 0 || request[",
adamc@167 510 string (Int.toString (size x')),
adamc@167 511 string "] == '/')) ? ({",
adamc@166 512 newline,
adamc@167 513 string "struct",
adamc@167 514 space,
adamc@166 515 string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
adamc@166 516 space,
adamc@181 517 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
adamc@167 518 string x,
adamc@167 519 string "_",
adamc@167 520 string (Int.toString i),
adamc@167 521 string "));",
adamc@166 522 newline,
adamc@181 523 string "tmp->tag",
adamc@166 524 space,
adamc@166 525 string "=",
adamc@166 526 space,
adamc@167 527 string ("__lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@166 528 string ";",
adamc@166 529 newline,
adamc@166 530 string "request",
adamc@166 531 space,
adamc@166 532 string "+=",
adamc@166 533 space,
adamc@167 534 string (Int.toString (size x')),
adamc@166 535 string ";",
adamc@166 536 newline,
adamc@167 537 string "if (request[0] == '/') ++request;",
adamc@167 538 newline,
adamc@166 539 case to of
adamc@166 540 NONE => box []
adamc@181 541 | SOME t => box [string "tmp->data.",
adamc@167 542 string x',
adamc@166 543 space,
adamc@166 544 string "=",
adamc@166 545 space,
adamc@166 546 unurlify t,
adamc@166 547 string ";",
adamc@166 548 newline],
adamc@181 549 string "tmp;",
adamc@166 550 newline,
adamc@166 551 string "})",
adamc@166 552 space,
adamc@166 553 string ":",
adamc@166 554 space,
adamc@166 555 doEm rest,
adamc@166 556 string ")"]
adamc@166 557 in
adamc@166 558 doEm xncs
adamc@166 559 end
adamc@166 560
adamc@144 561 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144 562 space)
adamc@144 563
adamc@144 564
adamc@144 565 fun p_page (ek, s, n, ts) =
adamc@144 566 let
adamc@144 567 val (ts, defInputs, inputsVar) =
adamc@144 568 case ek of
adamc@144 569 Core.Link => (ts, string "", string "")
adamc@144 570 | Core.Action =>
adamc@144 571 case List.last ts of
adamc@144 572 (TRecord i, _) =>
adamc@144 573 let
adamc@144 574 val xts = E.lookupStruct env i
adamc@144 575 in
adamc@144 576 (List.drop (ts, 1),
adamc@144 577 box [box (map (fn (x, t) => box [p_typ env t,
adamc@144 578 space,
adamc@144 579 string "lw_input_",
adamc@144 580 string x,
adamc@144 581 string ";",
adamc@144 582 newline]) xts),
adamc@144 583 newline,
adamc@144 584 box (map (fn (x, t) =>
adamc@144 585 let
adamc@144 586 val n = case SM.find (fnums, x) of
adamc@144 587 NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144 588 | SOME n => n
adamc@144 589 in
adamc@144 590 box [string "request = lw_get_input(ctx, ",
adamc@144 591 string (Int.toString n),
adamc@144 592 string ");",
adamc@144 593 newline,
adamc@144 594 string "if (request == NULL) {",
adamc@144 595 newline,
adamc@144 596 box [string "printf(\"Missing input ",
adamc@144 597 string x,
adamc@144 598 string "\\n\");",
adamc@144 599 newline,
adamc@144 600 string "exit(1);"],
adamc@144 601 newline,
adamc@144 602 string "}",
adamc@144 603 newline,
adamc@144 604 string "lw_input_",
adamc@144 605 string x,
adamc@144 606 space,
adamc@144 607 string "=",
adamc@144 608 space,
adamc@144 609 unurlify t,
adamc@144 610 string ";",
adamc@144 611 newline]
adamc@144 612 end) xts),
adamc@144 613 string "struct __lws_",
adamc@144 614 string (Int.toString i),
adamc@144 615 space,
adamc@144 616 string "lw_inputs",
adamc@144 617 space,
adamc@144 618 string "= {",
adamc@144 619 newline,
adamc@144 620 box (map (fn (x, _) => box [string "lw_input_",
adamc@144 621 string x,
adamc@144 622 string ",",
adamc@144 623 newline]) xts),
adamc@144 624 string "};",
adamc@144 625 newline],
adamc@144 626 box [string ",",
adamc@144 627 space,
adamc@144 628 string "lw_inputs"])
adamc@144 629 end
adamc@144 630
adamc@144 631 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144 632 in
adamc@144 633 box [string "if (!strncmp(request, \"",
adamc@144 634 string (String.toString s),
adamc@144 635 string "\", ",
adamc@144 636 string (Int.toString (size s)),
adamc@144 637 string ")) {",
adamc@144 638 newline,
adamc@144 639 string "request += ",
adamc@144 640 string (Int.toString (size s)),
adamc@144 641 string ";",
adamc@144 642 newline,
adamc@144 643 string "if (*request == '/') ++request;",
adamc@144 644 newline,
adamc@144 645 box [string "{",
adamc@144 646 newline,
adamc@144 647 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144 648 space,
adamc@144 649 string "arg",
adamc@144 650 string (Int.toString i),
adamc@144 651 space,
adamc@144 652 string "=",
adamc@144 653 space,
adamc@144 654 unurlify t,
adamc@144 655 string ";",
adamc@144 656 newline]) ts),
adamc@144 657 defInputs,
adamc@144 658 p_enamed env n,
adamc@144 659 string "(",
adamc@144 660 p_list_sep (box [string ",", space])
adamc@144 661 (fn x => x)
adamc@144 662 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144 663 inputsVar,
adamc@144 664 string ");",
adamc@144 665 newline,
adamc@144 666 string "return;",
adamc@144 667 newline,
adamc@144 668 string "}",
adamc@144 669 newline,
adamc@144 670 string "}"]
adamc@144 671 ]
adamc@144 672 end
adamc@144 673
adamc@144 674 val pds' = map p_page ps
adamc@29 675 in
adamc@144 676 box [string "#include <stdio.h>",
adamc@144 677 newline,
adamc@144 678 string "#include <stdlib.h>",
adamc@144 679 newline,
adamc@144 680 newline,
adamc@144 681 string "#include \"lacweb.h\"",
adamc@101 682 newline,
adamc@101 683 newline,
adamc@101 684 p_list_sep newline (fn x => x) pds,
adamc@101 685 newline,
adamc@144 686 string "int lw_inputs_len = ",
adamc@144 687 string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144 688 string ";",
adamc@144 689 newline,
adamc@144 690 newline,
adamc@144 691 string "int lw_input_num(char *name) {",
adamc@144 692 newline,
adamc@144 693 string "if",
adamc@144 694 space,
adamc@144 695 string "(name[0]",
adamc@144 696 space,
adamc@144 697 string "==",
adamc@144 698 space,
adamc@144 699 string "0)",
adamc@144 700 space,
adamc@144 701 string "return",
adamc@144 702 space,
adamc@144 703 string "-1;",
adamc@144 704 newline,
adamc@144 705 makeSwitch (fnums, 0),
adamc@144 706 string "}",
adamc@144 707 newline,
adamc@144 708 newline,
adamc@117 709 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 710 newline,
adamc@101 711 p_list_sep newline (fn x => x) pds',
adamc@101 712 newline,
adamc@101 713 string "}",
adamc@101 714 newline]
adamc@29 715 end
adamc@29 716
adamc@29 717 end