adamc@29: (* Copyright (c) 2008, Adam Chlipala
adamc@29:  * All rights reserved.
adamc@29:  *
adamc@29:  * Redistribution and use in source and binary forms, with or without
adamc@29:  * modification, are permitted provided that the following conditions are met:
adamc@29:  *
adamc@29:  * - Redistributions of source code must retain the above copyright notice,
adamc@29:  *   this list of conditions and the following disclaimer.
adamc@29:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29:  *   this list of conditions and the following disclaimer in the documentation
adamc@29:  *   and/or other materials provided with the distribution.
adamc@29:  * - The names of contributors may not be used to endorse or promote products
adamc@29:  *   derived from this software without specific prior written permission.
adamc@29:  *
adamc@29:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@29:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29:  * POSSIBILITY OF SUCH DAMAGE.
adamc@29:  *)
adamc@29: 
adamc@29: (* Pretty-printing C jr. *)
adamc@29: 
adamc@29: structure CjrPrint :> CJR_PRINT = struct
adamc@29: 
adamc@29: open Print.PD
adamc@29: open Print
adamc@29: 
adamc@29: open Cjr
adamc@29: 
adamc@29: structure E = CjrEnv
adamc@29: structure EM = ErrorMsg
adamc@29: 
adamc@29: val debug = ref false
adamc@29: 
adamc@29: val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
adamc@29: 
adamc@29: fun p_typ' par env (t, loc) =
adamc@29:     case t of
adamc@101:         TTop => string "void*"
adamc@109:       | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@109:                                            space,
adamc@109:                                            string "(*)",
adamc@109:                                            space,
adamc@109:                                            string "(",
adamc@109:                                            p_typ env t1,
adamc@109:                                            string ")"])
adamc@29:       | TRecord i => box [string "struct",
adamc@29:                           space,
adamc@29:                           string "__lws_",
adamc@29:                           string (Int.toString i)]
adamc@29:       | TNamed n =>
adamc@29:         (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
adamc@29:          handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
adamc@53:       | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@29: 
adamc@29: and p_typ env = p_typ' false env
adamc@29: 
adamc@29: fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
adamc@29:     handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
adamc@29: 
adamc@109: fun p_enamed env n =
adamc@109:     string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@109:     handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
adamc@109: 
adamc@29: fun p_exp' par env (e, _) =
adamc@29:     case e of
adamc@29:         EPrim p => Prim.p_t p
adamc@29:       | ERel n => p_rel env n
adamc@109:       | ENamed n => p_enamed env n
adamc@109: 
adamc@53:       | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
adamc@53:       | EFfiApp (m, x, es) => box [string "lw_",
adamc@53:                                    string m,
adamc@53:                                    string "_",
adamc@53:                                    string x,
adamc@117:                                    string "(ctx, ",
adamc@53:                                    p_list (p_exp env) es,
adamc@53:                                    string ")"]
adamc@29:       | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@29:                                            string "(",
adamc@29:                                            p_exp env e2,
adamc@29:                                            string ")"])
adamc@29: 
adamc@29:       | ERecord (i, xes) => box [string "({",
adamc@29:                                  space,
adamc@29:                                  string "struct",
adamc@29:                                  space,
adamc@29:                                  string ("__lws_" ^ Int.toString i),
adamc@29:                                  space,
adamc@29:                                  string "__lw_tmp",
adamc@29:                                  space,
adamc@29:                                  string "=",
adamc@29:                                  space,
adamc@29:                                  string "{",
adamc@29:                                  p_list (fn (_, e) =>
adamc@29:                                             p_exp env e) xes,
adamc@29:                                  string "};",
adamc@29:                                  space,
adamc@29:                                  string "__lw_tmp;",
adamc@29:                                  space,
adamc@29:                                  string "})" ]
adamc@29:       | EField (e, x) =>
adamc@29:         box [p_exp' true env e,
adamc@29:              string ".",
adamc@29:              string x]
adamc@29: 
adamc@117:       | EWrite e => box [string "(lw_write(ctx, ",
adamc@102:                          p_exp env e,
adamc@102:                          string "), lw_unit_v)"]
adamc@102: 
adamc@106:       | ESeq (e1, e2) => box [string "(",
adamc@106:                               p_exp env e1,
adamc@106:                               string ",",
adamc@106:                               space,
adamc@106:                               p_exp env e2,
adamc@106:                               string ")"]
adamc@106: 
adamc@29: and p_exp env = p_exp' false env
adamc@29: 
adamc@29: fun p_decl env ((d, _) : decl) =
adamc@29:     case d of
adamc@29:         DStruct (n, xts) =>
adamc@29:         box [string "struct",
adamc@29:              space,
adamc@29:              string ("__lws_" ^ Int.toString n),
adamc@29:              space,
adamc@29:              string "{",
adamc@29:              newline,
adamc@29:              p_list_sep (box []) (fn (x, t) => box [p_typ env t,
adamc@29:                                                     space,
adamc@29:                                                     string x,
adamc@29:                                                     string ";",
adamc@29:                                                     newline]) xts,
adamc@29:              string "};"]
adamc@29: 
adamc@29:       | DVal (x, n, t, e) =>
adamc@29:         box [p_typ env t,
adamc@29:              space,
adamc@29:              string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
adamc@29:              space,
adamc@29:              string "=",
adamc@29:              space,
adamc@29:              p_exp env e,
adamc@29:              string ";"]
adamc@109:       | DFun (fx, n, x, dom, ran, e) =>
adamc@29:         let
adamc@29:             val env' = E.pushERel env x dom
adamc@29:         in
adamc@106:             box [string "static",
adamc@106:                  space,
adamc@106:                  p_typ env ran,
adamc@29:                  space,
adamc@109:                  string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@117:                  string "(lw_context ctx, ",
adamc@29:                  p_typ env dom,
adamc@29:                  space,
adamc@29:                  p_rel env' 0,
adamc@29:                  string ")",
adamc@29:                  space,
adamc@29:                  string "{",
adamc@29:                  newline,
adamc@29:                  box[string "return(",
adamc@29:                      p_exp env' e,
adamc@101:                      string ");"],
adamc@29:                  newline,
adamc@29:                  string "}"]
adamc@29:         end
adamc@29: 
adamc@115: fun p_page env (s, n) =
adamc@116:     box [string "if (!strcmp(request, \"",
adamc@116:          string (String.toString s),
adamc@116:          string "\")) {",
adamc@116:          newline,
adamc@115:          p_enamed env n,
adamc@117:          string "(ctx, lw_unit_v);",
adamc@116:          newline,
adamc@119:          string "return;",
adamc@119:          newline,
adamc@116:          string "}",
adamc@116:          newline]
adamc@101: 
adamc@101: fun p_file env (ds, ps) =
adamc@29:     let
adamc@101:         val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
adamc@31:                                              (p_decl env d,
adamc@31:                                               E.declBinds env d))
adamc@101:                              env ds
adamc@101:         val pds' = map (p_page env) ps
adamc@29:     in
adamc@101:         box [string "#include \"lacweb.h\"",
adamc@101:              newline,
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds,
adamc@101:              newline,
adamc@117:              string "void lw_handle(lw_context ctx, char *request) {",
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds',
adamc@101:              newline,
adamc@101:              string "}",
adamc@101:              newline]
adamc@29:     end
adamc@29: 
adamc@29: end