Mercurial > urweb

annotate src/cjr_print.sml @ 129:78d59cf0a0cc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Compiled (non-mutual) 'val rec'
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Jul 2008 11:02:10 -0400
parents 91027db5a07c
children 133fa2d51bb4
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@29 40 val debug = ref false
adamc@29 41
adamc@29 42 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
adamc@29 43
adamc@29 44 fun p_typ' par env (t, loc) =
adamc@29 45 case t of
adamc@101 46 TTop => string "void*"
adamc@109 47 | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@109 48 space,
adamc@109 49 string "(*)",
adamc@109 50 space,
adamc@109 51 string "(",
adamc@109 52 p_typ env t1,
adamc@109 53 string ")"])
adamc@29 54 | TRecord i => box [string "struct",
adamc@29 55 space,
adamc@29 56 string "__lws_",
adamc@29 57 string (Int.toString i)]
adamc@29 58 | TNamed n =>
adamc@29 59 (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
adamc@29 60 handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
adamc@53 61 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29 62
adamc@29 63 and p_typ env = p_typ' false env
adamc@29 64
adamc@29 65 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 66 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 67
adamc@109 68 fun p_enamed env n =
adamc@109 69 string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109 70 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109 71
adamc@29 72 fun p_exp' par env (e, _) =
adamc@29 73 case e of
adamc@29 74 EPrim p => Prim.p_t p
adamc@29 75 | ERel n => p_rel env n
adamc@109 76 | ENamed n => p_enamed env n
adamc@109 77
adamc@53 78 | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53 79 | EFfiApp (m, x, es) => box [string "lw_",
adamc@53 80 string m,
adamc@53 81 string "_",
adamc@53 82 string x,
adamc@117 83 string "(ctx, ",
adamc@53 84 p_list (p_exp env) es,
adamc@53 85 string ")"]
adamc@129 86 | EApp (e1, e2) =>
adamc@129 87 let
adamc@129 88 fun unravel (f, acc) =
adamc@129 89 case #1 f of
adamc@129 90 EApp (f', arg) => unravel (f', arg :: acc)
adamc@129 91 | _ => (f, acc)
adamc@129 92
adamc@129 93 val (f, args) = unravel (e1, [e2])
adamc@129 94 in
adamc@129 95 parenIf par (box [p_exp' true env e1,
adamc@129 96 string "(ctx,",
adamc@129 97 space,
adamc@129 98 p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129 99 string ")"])
adamc@129 100 end
adamc@29 101
adamc@29 102 | ERecord (i, xes) => box [string "({",
adamc@29 103 space,
adamc@29 104 string "struct",
adamc@29 105 space,
adamc@29 106 string ("__lws_" ^ Int.toString i),
adamc@29 107 space,
adamc@29 108 string "__lw_tmp",
adamc@29 109 space,
adamc@29 110 string "=",
adamc@29 111 space,
adamc@29 112 string "{",
adamc@29 113 p_list (fn (_, e) =>
adamc@29 114 p_exp env e) xes,
adamc@29 115 string "};",
adamc@29 116 space,
adamc@29 117 string "__lw_tmp;",
adamc@29 118 space,
adamc@29 119 string "})" ]
adamc@29 120 | EField (e, x) =>
adamc@29 121 box [p_exp' true env e,
adamc@29 122 string ".",
adamc@29 123 string x]
adamc@29 124
adamc@117 125 | EWrite e => box [string "(lw_write(ctx, ",
adamc@102 126 p_exp env e,
adamc@102 127 string "), lw_unit_v)"]
adamc@102 128
adamc@106 129 | ESeq (e1, e2) => box [string "(",
adamc@106 130 p_exp env e1,
adamc@106 131 string ",",
adamc@106 132 space,
adamc@106 133 p_exp env e2,
adamc@106 134 string ")"]
adamc@106 135
adamc@29 136 and p_exp env = p_exp' false env
adamc@29 137
adamc@129 138 fun p_fun env (fx, n, args, ran, e) =
adamc@129 139 let
adamc@129 140 val nargs = length args
adamc@129 141 val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129 142 in
adamc@129 143 box [string "static",
adamc@129 144 space,
adamc@129 145 p_typ env ran,
adamc@129 146 space,
adamc@129 147 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 148 string "(",
adamc@129 149 p_list_sep (box [string ",", space]) (fn x => x)
adamc@129 150 (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129 151 box [p_typ env dom,
adamc@129 152 space,
adamc@129 153 p_rel env' (nargs - i - 1)]) args),
adamc@129 154 string ")",
adamc@129 155 space,
adamc@129 156 string "{",
adamc@129 157 newline,
adamc@129 158 box[string "return(",
adamc@129 159 p_exp env' e,
adamc@129 160 string ");"],
adamc@129 161 newline,
adamc@129 162 string "}"]
adamc@129 163 end
adamc@129 164
adamc@129 165 fun p_decl env (dAll as (d, _) : decl) =
adamc@29 166 case d of
adamc@29 167 DStruct (n, xts) =>
adamc@29 168 box [string "struct",
adamc@29 169 space,
adamc@29 170 string ("__lws_" ^ Int.toString n),
adamc@29 171 space,
adamc@29 172 string "{",
adamc@29 173 newline,
adamc@29 174 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 175 space,
adamc@29 176 string x,
adamc@29 177 string ";",
adamc@29 178 newline]) xts,
adamc@29 179 string "};"]
adamc@29 180
adamc@29 181 | DVal (x, n, t, e) =>
adamc@29 182 box [p_typ env t,
adamc@29 183 space,
adamc@29 184 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 185 space,
adamc@29 186 string "=",
adamc@29 187 space,
adamc@29 188 p_exp env e,
adamc@29 189 string ";"]
adamc@129 190 | DFun vi => p_fun env vi
adamc@129 191 | DFunRec vis =>
adamc@29 192 let
adamc@129 193 val env = E.declBinds env dAll
adamc@29 194 in
adamc@129 195 box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129 196 box [string "static",
adamc@129 197 space,
adamc@129 198 p_typ env ran,
adamc@129 199 space,
adamc@129 200 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129 201 string "(lw_context,",
adamc@129 202 space,
adamc@129 203 p_list_sep (box [string ",", space])
adamc@129 204 (fn (_, dom) => p_typ env dom) args,
adamc@129 205 string ");"]) vis,
adamc@29 206 newline,
adamc@129 207 p_list_sep newline (p_fun env) vis,
adamc@129 208 newline]
adamc@29 209 end
adamc@29 210
adamc@120 211 fun unurlify (t, loc) =
adamc@120 212 case t of
adamc@120 213 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@120 214 | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@120 215 | TFfi ("Basis", "string") => string "lw_unurlifyString(&request)"
adamc@120 216
adamc@120 217 | TRecord 0 => string "lw_unit_v"
adamc@120 218
adamc@120 219 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@120 220 space)
adamc@120 221
adamc@120 222 fun p_page env (s, n, ts) =
adamc@120 223 box [string "if (!strncmp(request, \"",
adamc@116 224 string (String.toString s),
adamc@120 225 string "\", ",
adamc@120 226 string (Int.toString (size s)),
adamc@120 227 string ")) {",
adamc@116 228 newline,
adamc@120 229 string "request += ",
adamc@120 230 string (Int.toString (size s)),
adamc@120 231 string ";",
adamc@116 232 newline,
adamc@120 233 string "if (*request == '/') ++request;",
adamc@119 234 newline,
adamc@120 235 box [string "{",
adamc@120 236 newline,
adamc@120 237 box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@120 238 space,
adamc@120 239 string "arg",
adamc@120 240 string (Int.toString i),
adamc@120 241 space,
adamc@120 242 string "=",
adamc@120 243 space,
adamc@120 244 unurlify t,
adamc@120 245 string ";",
adamc@120 246 newline]) ts),
adamc@120 247 p_enamed env n,
adamc@120 248 string "(",
adamc@120 249 p_list_sep (box [string ",", space])
adamc@120 250 (fn x => x)
adamc@120 251 (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@120 252 string ");",
adamc@120 253 newline,
adamc@120 254 string "return;",
adamc@120 255 newline,
adamc@120 256 string "}",
adamc@120 257 newline,
adamc@120 258 string "}"]
adamc@120 259 ]
adamc@101 260
adamc@101 261 fun p_file env (ds, ps) =
adamc@29 262 let
adamc@101 263 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 264 (p_decl env d,
adamc@31 265 E.declBinds env d))
adamc@101 266 env ds
adamc@101 267 val pds' = map (p_page env) ps
adamc@29 268 in
adamc@101 269 box [string "#include \"lacweb.h\"",
adamc@101 270 newline,
adamc@101 271 newline,
adamc@101 272 p_list_sep newline (fn x => x) pds,
adamc@101 273 newline,
adamc@117 274 string "void lw_handle(lw_context ctx, char *request) {",
adamc@101 275 newline,
adamc@101 276 p_list_sep newline (fn x => x) pds',
adamc@101 277 newline,
adamc@101 278 string "}",
adamc@101 279 newline]
adamc@29 280 end
adamc@29 281
adamc@29 282 end