Mercurial > urweb

annotate src/cjr_print.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents d101cb1efe55
children ff13d390ec60
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@53 83 string "(",
adamc@53 84 p_list (p_exp env) es,
adamc@53 85 string ")"]
adamc@29 86 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@29 87 string "(",
adamc@29 88 p_exp env e2,
adamc@29 89 string ")"])
adamc@29 90
adamc@29 91 | ERecord (i, xes) => box [string "({",
adamc@29 92 space,
adamc@29 93 string "struct",
adamc@29 94 space,
adamc@29 95 string ("__lws_" ^ Int.toString i),
adamc@29 96 space,
adamc@29 97 string "__lw_tmp",
adamc@29 98 space,
adamc@29 99 string "=",
adamc@29 100 space,
adamc@29 101 string "{",
adamc@29 102 p_list (fn (_, e) =>
adamc@29 103 p_exp env e) xes,
adamc@29 104 string "};",
adamc@29 105 space,
adamc@29 106 string "__lw_tmp;",
adamc@29 107 space,
adamc@29 108 string "})" ]
adamc@29 109 | EField (e, x) =>
adamc@29 110 box [p_exp' true env e,
adamc@29 111 string ".",
adamc@29 112 string x]
adamc@29 113
adamc@102 114 | EWrite e => box [string "(lw_write(",
adamc@102 115 p_exp env e,
adamc@102 116 string "), lw_unit_v)"]
adamc@102 117
adamc@106 118 | ESeq (e1, e2) => box [string "(",
adamc@106 119 p_exp env e1,
adamc@106 120 string ",",
adamc@106 121 space,
adamc@106 122 p_exp env e2,
adamc@106 123 string ")"]
adamc@106 124
adamc@29 125 and p_exp env = p_exp' false env
adamc@29 126
adamc@29 127 fun p_decl env ((d, _) : decl) =
adamc@29 128 case d of
adamc@29 129 DStruct (n, xts) =>
adamc@29 130 box [string "struct",
adamc@29 131 space,
adamc@29 132 string ("__lws_" ^ Int.toString n),
adamc@29 133 space,
adamc@29 134 string "{",
adamc@29 135 newline,
adamc@29 136 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29 137 space,
adamc@29 138 string x,
adamc@29 139 string ";",
adamc@29 140 newline]) xts,
adamc@29 141 string "};"]
adamc@29 142
adamc@29 143 | DVal (x, n, t, e) =>
adamc@29 144 box [p_typ env t,
adamc@29 145 space,
adamc@29 146 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29 147 space,
adamc@29 148 string "=",
adamc@29 149 space,
adamc@29 150 p_exp env e,
adamc@29 151 string ";"]
adamc@109 152 | DFun (fx, n, x, dom, ran, e) =>
adamc@29 153 let
adamc@29 154 val env' = E.pushERel env x dom
adamc@29 155 in
adamc@106 156 box [string "static",
adamc@106 157 space,
adamc@106 158 p_typ env ran,
adamc@29 159 space,
adamc@109 160 string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@29 161 string "(",
adamc@29 162 p_typ env dom,
adamc@29 163 space,
adamc@29 164 p_rel env' 0,
adamc@29 165 string ")",
adamc@29 166 space,
adamc@29 167 string "{",
adamc@29 168 newline,
adamc@29 169 box[string "return(",
adamc@29 170 p_exp env' e,
adamc@101 171 string ");"],
adamc@29 172 newline,
adamc@29 173 string "}"]
adamc@29 174 end
adamc@29 175
adamc@109 176 fun p_page env n = box [p_enamed env n,
adamc@109 177 string "(lw_unit_v);"]
adamc@101 178
adamc@101 179 fun p_file env (ds, ps) =
adamc@29 180 let
adamc@101 181 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 182 (p_decl env d,
adamc@31 183 E.declBinds env d))
adamc@101 184 env ds
adamc@101 185 val pds' = map (p_page env) ps
adamc@29 186 in
adamc@101 187 box [string "#include \"lacweb.h\"",
adamc@101 188 newline,
adamc@101 189 newline,
adamc@101 190 p_list_sep newline (fn x => x) pds,
adamc@101 191 newline,
adamc@102 192 string "void lw_handle(void) {",
adamc@101 193 newline,
adamc@101 194 p_list_sep newline (fn x => x) pds',
adamc@101 195 newline,
adamc@101 196 string "}",
adamc@101 197 newline]
adamc@29 198 end
adamc@29 199
adamc@29 200 end