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@29:       | TFun =>
adamc@29:         (EM.errorAt loc "Undetermined function type";
adamc@29:          string "?->")
adamc@29:       | TCode (t1, t2) => parenIf par (box [p_typ' true env t2,
adamc@29:                                             space,
adamc@29:                                             string "(*)",
adamc@29:                                             space,
adamc@29:                                             string "(",
adamc@29:                                             p_typ env t1,
adamc@29:                                             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@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@29:       | ENamed n =>
adamc@29:         (string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
adamc@29:          handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n))
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@53:                                    string "(",
adamc@53:                                    p_list (p_exp env) es,
adamc@53:                                    string ")"]
adamc@29:       | ECode n => string ("__lwc_" ^ Int.toString n)
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@29:       | ELet (xes, e) =>
adamc@29:         let
adamc@29:             val (env, pps) = foldl (fn ((x, t, e), (env, pps)) =>
adamc@29:                                        let
adamc@29:                                            val env' = E.pushERel env x t
adamc@29:                                        in
adamc@29:                                            (env',
adamc@29:                                             List.revAppend ([p_typ env t,
adamc@29:                                                              space,
adamc@29:                                                              p_rel env' 0,
adamc@29:                                                              space,
adamc@29:                                                              string "=",
adamc@29:                                                              space,
adamc@29:                                                              p_exp env e,
adamc@29:                                                              string ";",
adamc@29:                                                              newline],
adamc@29:                                                             pps))
adamc@29:                                        end)
adamc@29:                                    (env, []) xes
adamc@29:         in
adamc@29:             box [string "({",
adamc@29:                  newline,
adamc@29:                  box (rev pps),
adamc@29:                  p_exp env e,
adamc@29:                  space,
adamc@29:                  string ";",
adamc@29:                  newline,
adamc@29:                  string "})"]
adamc@29:         end
adamc@29: 
adamc@102:       | EWrite e => box [string "(lw_write(",
adamc@102:                          p_exp env e,
adamc@102:                          string "), lw_unit_v)"]
adamc@102: 
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@29:       | DFun (n, x, dom, ran, e) =>
adamc@29:         let
adamc@29:             val env' = E.pushERel env x dom
adamc@29:         in
adamc@29:             box [p_typ env ran,
adamc@29:                  space,
adamc@29:                  string ("__lwc_" ^ Int.toString n),
adamc@29:                  string "(",
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@101: fun p_page env (xts, (e, loc)) =
adamc@101:     case e of
adamc@101:         ERecord (_, xes) =>
adamc@101:         let
adamc@101:             fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes
adamc@101:         in
adamc@101:             case (read "code", read "env") of
adamc@101:                 (SOME code, SOME envx) =>
adamc@101:                 (case #1 code of
adamc@101:                      ECode i =>
adamc@101:                      let
adamc@101:                          val (_, (dom, _), _) = E.lookupF env i
adamc@101:                      in
adamc@101:                          case dom of
adamc@101:                              TRecord ri =>
adamc@101:                              let
adamc@101:                                  val axts = E.lookupStruct env ri
adamc@101:                                  fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts
adamc@101:                              in
adamc@101:                                  case read "arg" of
adamc@101:                                      NONE => string "Page handler is too complicated! [5]"
adamc@101:                                    | SOME (at, _) =>
adamc@101:                                      case at of
adamc@101:                                          TRecord ari =>
adamc@101:                                          let
adamc@101:                                              val r = (ERecord (ri, [("env", envx),
adamc@101:                                                                     ("arg", (ERecord (ari, []), loc))]), loc)
adamc@101:                                          in
adamc@102:                                              box [p_exp env (EApp (code, r), loc),
adamc@101:                                                   string ";"]
adamc@101:                                          end
adamc@101:                                        | _ => string "Page handler is too complicated! [6]"
adamc@101:                              end
adamc@101:                            | _ => string "Page handler is too complicated! [4]"
adamc@101:                      end
adamc@101:                    | _ => string "Page handler is too complicated! [3]")
adamc@101: 
adamc@101:               | _ => string "Page handler is too complicated! [1]"
adamc@101:         end
adamc@101:       | _ => string "Page handler is too complicated! [2]"
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@102:              string "void lw_handle(void) {",
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