Mercurial > urweb

annotate src/cjr_print.sml @ 168:25b169416ea8

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