Mercurial > urweb

annotate src/cjr_print.sml @ 103:8921f0344193

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Command-line compiler goes the whole nine yards
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 14:14:23 -0400
parents 5f04adf47f48
children d101cb1efe55
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@29 47 | TFun =>
adamc@29 48 (EM.errorAt loc "Undetermined function type";
adamc@29 49 string "?->")
adamc@29 50 | TCode (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@29 51 space,
adamc@29 52 string "(*)",
adamc@29 53 space,
adamc@29 54 string "(",
adamc@29 55 p_typ env t1,
adamc@29 56 string ")"])
adamc@29 57 | TRecord i => box [string "struct",
adamc@29 58 space,
adamc@29 59 string "__lws_",
adamc@29 60 string (Int.toString i)]
adamc@29 61 | TNamed n =>
adamc@29 62 (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
adamc@29 63 handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
adamc@53 64 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29 65
adamc@29 66 and p_typ env = p_typ' false env
adamc@29 67
adamc@29 68 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 69 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29 70
adamc@29 71 fun p_exp' par env (e, _) =
adamc@29 72 case e of
adamc@29 73 EPrim p => Prim.p_t p
adamc@29 74 | ERel n => p_rel env n
adamc@29 75 | ENamed n =>
adamc@29 76 (string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@29 77 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n))
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@53 83 string "(",
adamc@53 84 p_list (p_exp env) es,
adamc@53 85 string ")"]
adamc@29 86 | ECode n => string ("__lwc_" ^ Int.toString n)
adamc@29 87 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@29 88 string "(",
adamc@29 89 p_exp env e2,
adamc@29 90 string ")"])
adamc@29 91
adamc@29 92 | ERecord (i, xes) => box [string "({",
adamc@29 93 space,
adamc@29 94 string "struct",
adamc@29 95 space,
adamc@29 96 string ("__lws_" ^ Int.toString i),
adamc@29 97 space,
adamc@29 98 string "__lw_tmp",
adamc@29 99 space,
adamc@29 100 string "=",
adamc@29 101 space,
adamc@29 102 string "{",
adamc@29 103 p_list (fn (_, e) =>
adamc@29 104 p_exp env e) xes,
adamc@29 105 string "};",
adamc@29 106 space,
adamc@29 107 string "__lw_tmp;",
adamc@29 108 space,
adamc@29 109 string "})" ]
adamc@29 110 | EField (e, x) =>
adamc@29 111 box [p_exp' true env e,
adamc@29 112 string ".",
adamc@29 113 string x]
adamc@29 114
adamc@29 115 | ELet (xes, e) =>
adamc@29 116 let
adamc@29 117 val (env, pps) = foldl (fn ((x, t, e), (env, pps)) =>
adamc@29 118 let
adamc@29 119 val env' = E.pushERel env x t
adamc@29 120 in
adamc@29 121 (env',
adamc@29 122 List.revAppend ([p_typ env t,
adamc@29 123 space,
adamc@29 124 p_rel env' 0,
adamc@29 125 space,
adamc@29 126 string "=",
adamc@29 127 space,
adamc@29 128 p_exp env e,
adamc@29 129 string ";",
adamc@29 130 newline],
adamc@29 131 pps))
adamc@29 132 end)
adamc@29 133 (env, []) xes
adamc@29 134 in
adamc@29 135 box [string "({",
adamc@29 136 newline,
adamc@29 137 box (rev pps),
adamc@29 138 p_exp env e,
adamc@29 139 space,
adamc@29 140 string ";",
adamc@29 141 newline,
adamc@29 142 string "})"]
adamc@29 143 end
adamc@29 144
adamc@102 145 | EWrite e => box [string "(lw_write(",
adamc@102 146 p_exp env e,
adamc@102 147 string "), lw_unit_v)"]
adamc@102 148
adamc@29 149 and p_exp env = p_exp' false env
adamc@29 150
adamc@29 151 fun p_decl env ((d, _) : decl) =
adamc@29 152 case d of
adamc@29 153 DStruct (n, xts) =>
adamc@29 154 box [string "struct",
adamc@29 155 space,
adamc@29 156 string ("__lws_" ^ Int.toString n),
adamc@29 157 space,
adamc@29 158 string "{",
adamc@29 159 newline,
adamc@29 160 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 161 space,
adamc@29 162 string x,
adamc@29 163 string ";",
adamc@29 164 newline]) xts,
adamc@29 165 string "};"]
adamc@29 166
adamc@29 167 | DVal (x, n, t, e) =>
adamc@29 168 box [p_typ env t,
adamc@29 169 space,
adamc@29 170 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 171 space,
adamc@29 172 string "=",
adamc@29 173 space,
adamc@29 174 p_exp env e,
adamc@29 175 string ";"]
adamc@29 176 | DFun (n, x, dom, ran, e) =>
adamc@29 177 let
adamc@29 178 val env' = E.pushERel env x dom
adamc@29 179 in
adamc@29 180 box [p_typ env ran,
adamc@29 181 space,
adamc@29 182 string ("__lwc_" ^ Int.toString n),
adamc@29 183 string "(",
adamc@29 184 p_typ env dom,
adamc@29 185 space,
adamc@29 186 p_rel env' 0,
adamc@29 187 string ")",
adamc@29 188 space,
adamc@29 189 string "{",
adamc@29 190 newline,
adamc@29 191 box[string "return(",
adamc@29 192 p_exp env' e,
adamc@101 193 string ");"],
adamc@29 194 newline,
adamc@29 195 string "}"]
adamc@29 196 end
adamc@29 197
adamc@101 198 fun p_page env (xts, (e, loc)) =
adamc@101 199 case e of
adamc@101 200 ERecord (_, xes) =>
adamc@101 201 let
adamc@101 202 fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes
adamc@101 203 in
adamc@101 204 case (read "code", read "env") of
adamc@101 205 (SOME code, SOME envx) =>
adamc@101 206 (case #1 code of
adamc@101 207 ECode i =>
adamc@101 208 let
adamc@101 209 val (_, (dom, _), _) = E.lookupF env i
adamc@101 210 in
adamc@101 211 case dom of
adamc@101 212 TRecord ri =>
adamc@101 213 let
adamc@101 214 val axts = E.lookupStruct env ri
adamc@101 215 fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts
adamc@101 216 in
adamc@101 217 case read "arg" of
adamc@101 218 NONE => string "Page handler is too complicated! [5]"
adamc@101 219 | SOME (at, _) =>
adamc@101 220 case at of
adamc@101 221 TRecord ari =>
adamc@101 222 let
adamc@101 223 val r = (ERecord (ri, [("env", envx),
adamc@101 224 ("arg", (ERecord (ari, []), loc))]), loc)
adamc@101 225 in
adamc@102 226 box [p_exp env (EApp (code, r), loc),
adamc@101 227 string ";"]
adamc@101 228 end
adamc@101 229 | _ => string "Page handler is too complicated! [6]"
adamc@101 230 end
adamc@101 231 | _ => string "Page handler is too complicated! [4]"
adamc@101 232 end
adamc@101 233 | _ => string "Page handler is too complicated! [3]")
adamc@101 234
adamc@101 235 | _ => string "Page handler is too complicated! [1]"
adamc@101 236 end
adamc@101 237 | _ => string "Page handler is too complicated! [2]"
adamc@101 238
adamc@101 239 fun p_file env (ds, ps) =
adamc@29 240 let
adamc@101 241 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 242 (p_decl env d,
adamc@31 243 E.declBinds env d))
adamc@101 244 env ds
adamc@101 245 val pds' = map (p_page env) ps
adamc@29 246 in
adamc@101 247 box [string "#include \"lacweb.h\"",
adamc@101 248 newline,
adamc@101 249 newline,
adamc@101 250 p_list_sep newline (fn x => x) pds,
adamc@101 251 newline,
adamc@102 252 string "void lw_handle(void) {",
adamc@101 253 newline,
adamc@101 254 p_list_sep newline (fn x => x) pds',
adamc@101 255 newline,
adamc@101 256 string "}",
adamc@101 257 newline]
adamc@29 258 end
adamc@29 259
adamc@29 260 end