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@144: structure SK = struct
adamc@144: type ord_key = string
adamc@144: val compare = String.compare
adamc@144: end
adamc@144: 
adamc@144: structure SS = BinarySetFn(SK)
adamc@144: structure SM = BinaryMapFn(SK)
adamc@144: structure IS = IntBinarySet
adamc@144: 
adamc@144: structure CM = BinaryMapFn(struct
adamc@144:                            type ord_key = char
adamc@144:                            val compare = Char.compare
adamc@144:                            end)
adamc@144: 
adamc@29: val debug = ref false
adamc@29: 
adamc@168: val dummyTyp = (TDatatype (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@168:       | TDatatype (n, _) =>
adamc@165:         (box [string "struct",
adamc@165:               space,
adamc@166:               string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
adamc@166:          handle CjrEnv.UnboundNamed _ => string ("__lwd_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@182: fun p_con_named env n =
adamc@182:     string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
adamc@182:     handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n)
adamc@182: 
adamc@182: fun p_pat_preamble env (p, _) =
adamc@182:     case p of
adamc@182:         PWild => (box [],
adamc@182:                   env)
adamc@182:       | PVar (x, t) => (box [p_typ env t,
adamc@182:                              space,
adamc@182:                              string "__lwr_",
adamc@182:                              string x,
adamc@182:                              string "_",
adamc@182:                              string (Int.toString (E.countERels env)),
adamc@182:                              string ";",
adamc@182:                              newline],
adamc@182:                         env)
adamc@182:       | PPrim _ => (box [], env)
adamc@182:       | PCon (_, NONE) => (box [], env)
adamc@182:       | PCon (_, SOME p) => p_pat_preamble env p
adamc@182:       | PRecord xps =>
adamc@182:         foldl (fn ((_, p, _), (pp, env)) =>
adamc@182:                   let
adamc@182:                       val (pp', env) = p_pat_preamble env p
adamc@182:                   in
adamc@182:                       (box [pp', pp], env)
adamc@182:                   end) (box [], env) xps
adamc@182: 
adamc@182: fun p_patCon env pc =
adamc@182:     case pc of
adamc@182:         PConVar n => p_con_named env n
adamc@182:       | PConFfi _ => raise Fail "CjrPrint PConFfi"
adamc@182: 
adamc@182: fun p_pat (env, exit, depth) (p, _) =
adamc@182:     case p of
adamc@182:         PWild =>
adamc@182:         (box [], env)
adamc@182:       | PVar (x, t) =>
adamc@182:         (box [string "__lwr_",
adamc@182:               string x,
adamc@182:               string "_",
adamc@182:               string (Int.toString (E.countERels env)),
adamc@182:               space,
adamc@182:               string "=",
adamc@182:               space,
adamc@182:               string "disc",
adamc@182:               string (Int.toString depth),
adamc@182:               string ";"],
adamc@182:          E.pushERel env x t)
adamc@182:       | PPrim (Prim.Int n) =>
adamc@182:         (box [string "if",
adamc@182:               space,
adamc@182:               string "(disc",
adamc@182:               string (Int.toString depth),
adamc@182:               space,
adamc@182:               string "!=",
adamc@182:               space,
adamc@182:               Prim.p_t (Prim.Int n),
adamc@182:               string ")",
adamc@182:               space,
adamc@182:               exit],
adamc@182:          env)
adamc@182:       | PPrim (Prim.String s) =>
adamc@182:         (box [string "if",
adamc@182:               space,
adamc@182:               string "(strcmp(disc",
adamc@182:               string (Int.toString depth),
adamc@182:               string ",",
adamc@182:               space,
adamc@182:               Prim.p_t (Prim.String s),
adamc@182:               string "))",
adamc@182:               space,
adamc@182:               exit],
adamc@182:          env)
adamc@182:       | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
adamc@182: 
adamc@182:       | PCon (pc, po) =>
adamc@182:         let
adamc@182:             val (p, env) =
adamc@182:                 case po of
adamc@182:                     NONE => (box [], env)
adamc@182:                   | SOME p =>
adamc@182:                     let
adamc@182:                         val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182: 
adamc@182:                         val (x, to) = case pc of
adamc@182:                                           PConVar n =>
adamc@182:                                           let
adamc@182:                                               val (x, to, _) = E.lookupConstructor env n
adamc@182:                                           in
adamc@182:                                               (x, to)
adamc@182:                                           end
adamc@182:                                         | PConFfi _ => raise Fail "PConFfi"
adamc@182: 
adamc@182:                         val t = case to of
adamc@182:                                     NONE => raise Fail "CjrPrint: Constructor mismatch"
adamc@182:                                   | SOME t => t
adamc@182:                     in
adamc@182:                         (box [string "{",
adamc@182:                               newline,
adamc@182:                               p_typ env t,
adamc@182:                               space,
adamc@182:                               string "disc",
adamc@182:                               string (Int.toString (depth + 1)),
adamc@182:                               space,
adamc@182:                               string "=",
adamc@182:                               space,
adamc@182:                               string "disc",
adamc@182:                               string (Int.toString depth),
adamc@182:                               string "->data.__lwc_",
adamc@182:                               string x,
adamc@182:                               string ";",
adamc@182:                               newline,
adamc@182:                               p,
adamc@182:                               newline,
adamc@182:                               string "}"],
adamc@182:                          env)
adamc@182:                     end
adamc@182:         in
adamc@182:             (box [string "if",
adamc@182:                   space,
adamc@182:                   string "(disc",
adamc@182:                   string (Int.toString depth),
adamc@182:                   string "->tag",
adamc@182:                   space,
adamc@182:                   string "!=",
adamc@182:                   space,
adamc@182:                   p_patCon env pc,
adamc@182:                   string ")",
adamc@182:                   space,
adamc@182:                   exit,
adamc@182:                   newline,
adamc@182:                   p],
adamc@182:              env)
adamc@182:         end
adamc@182: 
adamc@182:       | PRecord xps =>
adamc@182:         let
adamc@182:             val (xps, env) =
adamc@182:                 ListUtil.foldlMap (fn ((x, p, t), env) =>
adamc@182:                                       let
adamc@182:                                           val (p, env) = p_pat (env, exit, depth + 1) p
adamc@182: 
adamc@182:                                           val p = box [string "{",
adamc@182:                                                        newline,
adamc@182:                                                        p_typ env t,
adamc@182:                                                        space,
adamc@182:                                                        string "disc",
adamc@182:                                                        string (Int.toString (depth + 1)),
adamc@182:                                                        space,
adamc@182:                                                        string "=",
adamc@182:                                                        space,
adamc@182:                                                        string "disc",
adamc@182:                                                        string (Int.toString depth),
adamc@182:                                                        string ".",
adamc@182:                                                        string x,
adamc@182:                                                        string ";",
adamc@182:                                                        newline,
adamc@182:                                                        p,
adamc@182:                                                        newline,
adamc@182:                                                        string "}"]
adamc@182:                                       in
adamc@182:                                           (p, env)
adamc@182:                                       end) env xps
adamc@182:         in
adamc@182:             (p_list_sep newline (fn x => x) xps,
adamc@182:              env)
adamc@182:         end
adamc@182: 
adamc@182: local
adamc@182:     val count = ref 0
adamc@182: in
adamc@182: fun newGoto () =
adamc@182:     let
adamc@182:         val r = !count
adamc@182:     in
adamc@182:         count := r + 1;
adamc@182:         string ("L" ^ Int.toString r)
adamc@182:     end
adamc@182: end
adamc@182: 
adamc@182: fun p_exp' par env (e, loc) =
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@181:       | ECon (n, eo) =>
adamc@181:         let
adamc@181:             val (x, _, dn) = E.lookupConstructor env n
adamc@181:             val (dx, _) = E.lookupDatatype env dn
adamc@181:         in
adamc@182:             box [string "({",
adamc@181:                  newline,
adamc@181:                  string "struct",
adamc@181:                  space,
adamc@181:                  string "__lwd_",
adamc@181:                  string dx,
adamc@181:                  string "_",
adamc@181:                  string (Int.toString dn),
adamc@181:                  space,
adamc@181:                  string "*tmp",
adamc@181:                  space,
adamc@181:                  string "=",
adamc@181:                  space,
adamc@181:                  string "lw_malloc(ctx, sizeof(struct __lwd_",
adamc@181:                  string dx,
adamc@181:                  string "_",
adamc@181:                  string (Int.toString dn),
adamc@181:                  string "));",
adamc@181:                  newline,
adamc@181:                  string "tmp->tag",
adamc@181:                  space,
adamc@181:                  string "=",
adamc@181:                  space,
adamc@181:                  string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
adamc@181:                  string ";",
adamc@181:                  newline,
adamc@181:                  case eo of
adamc@181:                      NONE => box []
adamc@182:                    | SOME e => box [string "tmp->data.__lwc_",
adamc@181:                                     string x,
adamc@181:                                     space,
adamc@181:                                     string "=",
adamc@181:                                     space,
adamc@181:                                     p_exp env e,
adamc@181:                                     string ";",
adamc@181:                                     newline],
adamc@181:                  string "tmp;",
adamc@181:                  newline,
adamc@181:                  string "})"]          
adamc@181:         end
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@129:       | EApp (e1, e2) =>
adamc@129:         let
adamc@129:             fun unravel (f, acc) =
adamc@129:                 case #1 f of
adamc@129:                     EApp (f', arg) => unravel (f', arg :: acc)
adamc@129:                   | _ => (f, acc)
adamc@129: 
adamc@129:             val (f, args) = unravel (e1, [e2])
adamc@129:         in
adamc@129:             parenIf par (box [p_exp' true env e1,
adamc@129:                               string "(ctx,",
adamc@129:                               space,
adamc@129:                               p_list_sep (box [string ",", space]) (p_exp env) args,
adamc@129:                               string ")"])
adamc@129:         end
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@181:                                  string "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@181:                                  string "tmp;",
adamc@29:                                  space,
adamc@29:                                  string "})" ]
adamc@29:       | EField (e, x) =>
adamc@29:         box [p_exp' true env e,
adamc@182:              string ".__lwf_",
adamc@29:              string x]
adamc@29: 
adamc@182:       | ECase (e, pes, {disc, result}) =>
adamc@182:         let
adamc@182:             val final = newGoto ()
adamc@182: 
adamc@182:             val body = foldl (fn ((p, e), body) =>
adamc@182:                                let
adamc@182:                                    val exit = newGoto ()
adamc@182:                                    val (pr, _) = p_pat_preamble env p
adamc@182:                                    val (p, env) = p_pat (env,
adamc@182:                                                          box [string "goto",
adamc@182:                                                               space,
adamc@182:                                                               exit,
adamc@182:                                                               string ";"],
adamc@182:                                                          0) p
adamc@182:                                in
adamc@182:                                    box [body,
adamc@182:                                         box [string "{",
adamc@182:                                              newline,
adamc@182:                                              pr,
adamc@182:                                              newline,
adamc@182:                                              p,
adamc@182:                                              newline,
adamc@182:                                              string "result",
adamc@182:                                              space,
adamc@182:                                              string "=",
adamc@182:                                              space,
adamc@182:                                              p_exp env e,
adamc@182:                                              string ";",
adamc@182:                                              newline,
adamc@182:                                              string "goto",
adamc@182:                                              space,
adamc@182:                                              final,
adamc@182:                                              string ";",
adamc@182:                                              newline,
adamc@182:                                              string "}"],
adamc@182:                                         newline,
adamc@182:                                         exit,
adamc@182:                                         string ":",
adamc@182:                                         newline]
adamc@182:                                end) (box []) pes
adamc@182:         in
adamc@182:             box [string "({",
adamc@182:                  newline,
adamc@182:                  p_typ env disc,
adamc@182:                  space,
adamc@182:                  string "disc0",
adamc@182:                  space,
adamc@182:                  string "=",
adamc@182:                  space,
adamc@182:                  p_exp env e,
adamc@182:                  string ";",
adamc@182:                  newline,
adamc@182:                  p_typ env result,
adamc@182:                  space,
adamc@182:                  string "result;",
adamc@182:                  newline,
adamc@182:                  body,
adamc@182:                  string "lw_error(ctx, FATAL, \"",
adamc@182:                  string (ErrorMsg.spanToString loc),
adamc@182:                  string ": pattern match failure\");",
adamc@182:                  newline,
adamc@182:                  final,
adamc@182:                  string ":",
adamc@182:                  space,
adamc@182:                  string "result;",
adamc@182:                  newline,
adamc@182:                  string "})"]
adamc@182:         end
adamc@181: 
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@129: fun p_fun env (fx, n, args, ran, e) =
adamc@129:     let
adamc@129:         val nargs = length args
adamc@129:         val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args
adamc@129:     in
adamc@129:         box [string "static",
adamc@129:              space,
adamc@129:              p_typ env ran,
adamc@129:              space,
adamc@129:              string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129:              string "(",
adamc@129:              p_list_sep (box [string ",", space]) (fn x => x)
adamc@129:                         (string "lw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
adamc@129:                                                                       box [p_typ env dom,
adamc@129:                                                                            space,
adamc@129:                                                                            p_rel env' (nargs - i - 1)]) args),
adamc@129:              string ")",
adamc@129:              space,
adamc@129:              string "{",
adamc@129:              newline,
adamc@129:              box[string "return(",
adamc@129:                  p_exp env' e,
adamc@129:                  string ");"],
adamc@129:              newline,
adamc@129:              string "}"]
adamc@129:     end
adamc@129: 
adamc@129: fun p_decl env (dAll as (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@182:                                                     string "__lwf_",
adamc@29:                                                     string x,
adamc@29:                                                     string ";",
adamc@29:                                                     newline]) xts,
adamc@29:              string "};"]
adamc@165:       | DDatatype (x, n, xncs) =>
adamc@165:         let
adamc@165:             val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
adamc@165:                                              | (x, n, SOME t) => SOME (x, n, t)) xncs
adamc@165:         in
adamc@165:             box [string "enum",
adamc@165:                  space,
adamc@165:                  string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165:                  space,
adamc@165:                  string "{",
adamc@165:                  space,
adamc@165:                  p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
adamc@165:                  space,
adamc@165:                  string "};",
adamc@165:                  newline,
adamc@165:                  newline,
adamc@165:                  string "struct",
adamc@165:                  space,
adamc@167:                  string ("__lwd_" ^ x ^ "_" ^ Int.toString n),
adamc@165:                  space,
adamc@165:                  string "{",
adamc@165:                  newline,
adamc@165:                  string "enum",
adamc@165:                  space,
adamc@165:                  string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
adamc@165:                  space,
adamc@165:                  string "tag;",
adamc@165:                  newline,
adamc@165:                  box (case xncsArgs of
adamc@165:                           [] => []
adamc@165:                         | _ => [string "union",
adamc@165:                                 space,
adamc@165:                                 string "{",
adamc@165:                                 newline,
adamc@165:                                 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
adamc@165:                                                                          space,
adamc@165:                                                                          string ("__lwc_" ^ x),
adamc@165:                                                                          string ";"]) xncsArgs,
adamc@165:                                 newline,
adamc@165:                                 string "}",
adamc@165:                                 space,
adamc@165:                                 string "data;",
adamc@165:                                 newline]),
adamc@165:                  string "};"]
adamc@165:         end                 
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@129:       | DFun vi => p_fun env vi
adamc@129:       | DFunRec vis =>
adamc@29:         let
adamc@129:             val env = E.declBinds env dAll
adamc@29:         in
adamc@129:             box [p_list_sep newline (fn (fx, n, args, ran, _) =>
adamc@129:                                         box [string "static",
adamc@129:                                              space,
adamc@129:                                              p_typ env ran,
adamc@129:                                              space,
adamc@129:                                              string ("__lwn_" ^ fx ^ "_" ^ Int.toString n),
adamc@129:                                              string "(lw_context,",
adamc@129:                                              space,
adamc@129:                                              p_list_sep (box [string ",", space])
adamc@129:                                                         (fn (_, dom) => p_typ env dom) args,
adamc@129:                                              string ");"]) vis,
adamc@29:                  newline,
adamc@129:                  p_list_sep newline (p_fun env) vis,
adamc@129:                  newline]
adamc@29:         end
adamc@29: 
adamc@144: datatype 'a search =
adamc@144:          Found of 'a
adamc@144:        | NotFound
adamc@144:        | Error
adamc@120: 
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@144: 
adamc@144:         val fields = foldl (fn ((ek, _, _, ts), fields) =>
adamc@144:                                case ek of
adamc@144:                                    Core.Link => fields
adamc@144:                                  | Core.Action =>
adamc@144:                                    case List.last ts of
adamc@144:                                        (TRecord i, _) =>
adamc@144:                                        let
adamc@144:                                            val xts = E.lookupStruct env i
adamc@144:                                            val xtsSet = SS.addList (SS.empty, map #1 xts)
adamc@144:                                        in
adamc@144:                                            foldl (fn ((x, _), fields) =>
adamc@144:                                                      let
adamc@144:                                                          val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
adamc@144:                                                      in
adamc@144:                                                          SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
adamc@144:                                                                                          xtsSet'))
adamc@144:                                                      end) fields xts
adamc@144:                                        end
adamc@144:                                      | _ => raise Fail "CjrPrint: Last argument of action isn't record")
adamc@144:                      SM.empty ps
adamc@144: 
adamc@144:         val fnums = SM.foldli (fn (x, xs, fnums) =>
adamc@144:                                   let
adamc@144:                                       val unusable = SS.foldl (fn (x', unusable) =>
adamc@144:                                                                   case SM.find (fnums, x') of
adamc@144:                                                                       NONE => unusable
adamc@144:                                                                     | SOME n => IS.add (unusable, n))
adamc@144:                                                      IS.empty xs
adamc@144: 
adamc@144:                                       fun findAvailable n =
adamc@144:                                           if IS.member (unusable, n) then
adamc@144:                                               findAvailable (n + 1)
adamc@144:                                           else
adamc@144:                                               n
adamc@144:                                   in
adamc@144:                                       SM.insert (fnums, x, findAvailable 0)
adamc@144:                                   end)
adamc@144:                     SM.empty fields
adamc@144: 
adamc@144:         fun makeSwitch (fnums, i) =
adamc@144:             case SM.foldl (fn (n, NotFound) => Found n
adamc@144:                             | (n, Error) => Error
adamc@144:                             | (n, Found n') => if n = n' then
adamc@144:                                                   Found n'
adamc@144:                                                else
adamc@144:                                                    Error) NotFound fnums of
adamc@144:                 NotFound => box [string "return",
adamc@144:                                  space,
adamc@144:                                  string "-1;"]
adamc@144:               | Found n => box [string "return",
adamc@144:                                 space,
adamc@144:                                 string (Int.toString n),
adamc@144:                                 string ";"]
adamc@144:               | Error =>
adamc@144:                 let
adamc@144:                     val cmap = SM.foldli (fn (x, n, cmap) =>
adamc@144:                                              let
adamc@144:                                                  val ch = if i < size x then
adamc@144:                                                               String.sub (x, i)
adamc@144:                                                           else
adamc@144:                                                               chr 0
adamc@144: 
adamc@144:                                                  val fnums = case CM.find (cmap, ch) of
adamc@144:                                                                  NONE => SM.empty
adamc@144:                                                                | SOME fnums => fnums
adamc@144:                                                  val fnums = SM.insert (fnums, x, n)
adamc@144:                                              in
adamc@144:                                                  CM.insert (cmap, ch, fnums)
adamc@144:                                              end)
adamc@144:                                CM.empty fnums
adamc@144: 
adamc@144:                     val cmap = CM.listItemsi cmap
adamc@144:                 in
adamc@144:                     case cmap of
adamc@144:                         [(_, fnums)] =>
adamc@144:                         box [string "if",
adamc@144:                              space,
adamc@144:                              string "(name[",
adamc@144:                              string (Int.toString i),
adamc@144:                              string "]",
adamc@144:                              space,
adamc@144:                              string "==",
adamc@144:                              space,
adamc@144:                              string "0)",
adamc@144:                              space,
adamc@144:                              string "return",
adamc@144:                              space,
adamc@144:                              string "-1;",
adamc@144:                              newline,
adamc@144:                              makeSwitch (fnums, i+1)]
adamc@144:                       | _ =>
adamc@144:                         box [string "switch",
adamc@144:                              space,
adamc@144:                              string "(name[",
adamc@144:                              string (Int.toString i),
adamc@144:                              string "])",
adamc@144:                              space,
adamc@144:                              string "{",
adamc@144:                              newline,
adamc@144:                              box (map (fn (ch, fnums) =>
adamc@144:                                           box [string "case",
adamc@144:                                                space,
adamc@144:                                                if ch = chr 0 then
adamc@144:                                                    string "0:"
adamc@144:                                                else
adamc@144:                                                    box [string "'",
adamc@144:                                                         string (Char.toString ch),
adamc@144:                                                         string "':"],
adamc@144:                                                newline,
adamc@144:                                                makeSwitch (fnums, i+1),
adamc@144:                                                newline]) cmap),
adamc@144:                              string "default:",
adamc@144:                              newline,
adamc@144:                              string "return",
adamc@144:                              space,
adamc@144:                              string "-1;",
adamc@144:                              newline,
adamc@144:                              string "}"]
adamc@144:                 end
adamc@144: 
adamc@144:         fun unurlify (t, loc) =
adamc@144:             case t of
adamc@144:                 TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
adamc@144:               | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
adamc@144:               | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
adamc@144: 
adamc@144:               | TRecord 0 => string "lw_unit_v"
adamc@144:               | TRecord i =>
adamc@144:                 let
adamc@144:                     val xts = E.lookupStruct env i
adamc@144:                 in
adamc@144:                     box [string "({",
adamc@144:                          newline,
adamc@144:                          box (map (fn (x, t) =>
adamc@144:                                       box [p_typ env t,
adamc@144:                                            space,
adamc@144:                                            string x,
adamc@144:                                            space,
adamc@144:                                            string "=",
adamc@144:                                            space,
adamc@144:                                            unurlify t,
adamc@144:                                            string ";",
adamc@144:                                            newline]) xts),
adamc@144:                          string "struct",
adamc@144:                          space,
adamc@144:                          string "__lws_",
adamc@144:                          string (Int.toString i),
adamc@144:                          space,
adamc@181:                          string "tmp",
adamc@144:                          space,
adamc@144:                          string "=",
adamc@144:                          space,
adamc@144:                          string "{",
adamc@144:                          space,
adamc@144:                          p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
adamc@144:                          space,
adamc@144:                          string "};",
adamc@144:                          newline,
adamc@181:                          string "tmp;",
adamc@144:                          newline,
adamc@144:                          string "})"]
adamc@144:                 end
adamc@144: 
adamc@168:               | TDatatype (i, _) =>
adamc@166:                 let
adamc@166:                     val (x, xncs) = E.lookupDatatype env i
adamc@166: 
adamc@166:                     fun doEm xncs =
adamc@166:                         case xncs of
adamc@167:                             [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
adamc@167:                           | (x', n, to) :: rest =>
adamc@167:                             box [string "((!strncmp(request, \"",
adamc@167:                                  string x',
adamc@167:                                  string "\", ",
adamc@167:                                  string (Int.toString (size x')),
adamc@167:                                  string ") && (request[",
adamc@167:                                  string (Int.toString (size x')),
adamc@167:                                  string "] == 0 || request[",
adamc@167:                                  string (Int.toString (size x')),
adamc@167:                                  string "] == '/')) ? ({",
adamc@166:                                  newline,
adamc@167:                                  string "struct",
adamc@167:                                  space,
adamc@166:                                  string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
adamc@166:                                  space,
adamc@181:                                  string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
adamc@167:                                  string x,
adamc@167:                                  string "_",
adamc@167:                                  string (Int.toString i),
adamc@167:                                  string "));",
adamc@166:                                  newline,
adamc@181:                                  string "tmp->tag",
adamc@166:                                  space,
adamc@166:                                  string "=",
adamc@166:                                  space,
adamc@167:                                  string ("__lwc_" ^ x' ^ "_" ^ Int.toString n),
adamc@166:                                  string ";",
adamc@166:                                  newline,
adamc@166:                                  string "request",
adamc@166:                                  space,
adamc@166:                                  string "+=",
adamc@166:                                  space,
adamc@167:                                  string (Int.toString (size x')),
adamc@166:                                  string ";",
adamc@166:                                  newline,
adamc@167:                                  string "if (request[0] == '/') ++request;",
adamc@167:                                  newline,
adamc@166:                                  case to of
adamc@166:                                      NONE => box []
adamc@182:                                    | SOME t => box [string "tmp->data.__lwc_",
adamc@167:                                                     string x',
adamc@166:                                                     space,
adamc@166:                                                     string "=",
adamc@166:                                                     space,
adamc@166:                                                     unurlify t,
adamc@166:                                                     string ";",
adamc@166:                                                     newline],
adamc@181:                                  string "tmp;",
adamc@166:                                  newline,
adamc@166:                                  string "})",
adamc@166:                                  space,
adamc@166:                                  string ":",
adamc@166:                                  space,
adamc@166:                                  doEm rest,
adamc@166:                                  string ")"]
adamc@166:                 in
adamc@166:                     doEm xncs
adamc@166:                 end
adamc@166: 
adamc@144:               | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
adamc@144:                       space)
adamc@144: 
adamc@144: 
adamc@144:         fun p_page (ek, s, n, ts) =
adamc@144:             let
adamc@144:                 val (ts, defInputs, inputsVar) =
adamc@144:                     case ek of
adamc@144:                         Core.Link => (ts, string "", string "")
adamc@144:                       | Core.Action =>
adamc@144:                         case List.last ts of
adamc@144:                             (TRecord i, _) =>
adamc@144:                             let
adamc@144:                                 val xts = E.lookupStruct env i
adamc@144:                             in
adamc@144:                                 (List.drop (ts, 1),
adamc@144:                                  box [box (map (fn (x, t) => box [p_typ env t,
adamc@144:                                                                   space,
adamc@144:                                                                   string "lw_input_",
adamc@144:                                                                   string x,
adamc@144:                                                                   string ";",
adamc@144:                                                                   newline]) xts),
adamc@144:                                       newline,
adamc@144:                                       box (map (fn (x, t) =>
adamc@144:                                                    let
adamc@144:                                                        val n = case SM.find (fnums, x) of
adamc@144:                                                                    NONE => raise Fail "CjrPrint: Can't find in fnums"
adamc@144:                                                                  | SOME n => n
adamc@144:                                                    in
adamc@144:                                                        box [string "request = lw_get_input(ctx, ",
adamc@144:                                                             string (Int.toString n),
adamc@144:                                                             string ");",
adamc@144:                                                             newline,
adamc@144:                                                             string "if (request == NULL) {",
adamc@144:                                                             newline,
adamc@144:                                                             box [string "printf(\"Missing input ",
adamc@144:                                                                  string x,
adamc@144:                                                                  string "\\n\");",
adamc@144:                                                                  newline,
adamc@144:                                                                  string "exit(1);"],
adamc@144:                                                             newline,
adamc@144:                                                             string "}",
adamc@144:                                                             newline,
adamc@144:                                                             string "lw_input_",
adamc@144:                                                             string x,
adamc@144:                                                             space,
adamc@144:                                                             string "=",
adamc@144:                                                             space,
adamc@144:                                                             unurlify t,
adamc@144:                                                             string ";",
adamc@144:                                                             newline]
adamc@144:                                                    end) xts),
adamc@144:                                       string "struct __lws_",
adamc@144:                                       string (Int.toString i),
adamc@144:                                       space,
adamc@144:                                       string "lw_inputs",
adamc@144:                                       space,
adamc@144:                                       string "= {",
adamc@144:                                       newline,
adamc@144:                                       box (map (fn (x, _) => box [string "lw_input_",
adamc@144:                                                                   string x,
adamc@144:                                                                   string ",",
adamc@144:                                                                   newline]) xts),
adamc@144:                                       string "};",
adamc@144:                                       newline],
adamc@144:                                  box [string ",",
adamc@144:                                       space,
adamc@144:                                       string "lw_inputs"])
adamc@144:                             end
adamc@144: 
adamc@144:                           | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
adamc@144:             in
adamc@144:                 box [string "if (!strncmp(request, \"",
adamc@144:                      string (String.toString s),
adamc@144:                      string "\", ",
adamc@144:                      string (Int.toString (size s)),
adamc@144:                      string ")) {",
adamc@144:                      newline,
adamc@144:                      string "request += ",
adamc@144:                      string (Int.toString (size s)),
adamc@144:                      string ";",
adamc@144:                      newline,
adamc@144:                      string "if (*request == '/') ++request;",
adamc@144:                      newline,
adamc@144:                      box [string "{",
adamc@144:                           newline,
adamc@144:                           box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
adamc@144:                                                                 space,
adamc@144:                                                                 string "arg",
adamc@144:                                                                 string (Int.toString i),
adamc@144:                                                                 space,
adamc@144:                                                                 string "=",
adamc@144:                                                                 space,
adamc@144:                                                                 unurlify t,
adamc@144:                                                                 string ";",
adamc@144:                                                                 newline]) ts),
adamc@144:                           defInputs,
adamc@144:                           p_enamed env n,
adamc@144:                           string "(",
adamc@144:                           p_list_sep (box [string ",", space])
adamc@144:                                      (fn x => x)
adamc@144:                                      (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
adamc@144:                           inputsVar,
adamc@144:                           string ");",
adamc@144:                           newline,
adamc@144:                           string "return;",
adamc@144:                           newline,
adamc@144:                           string "}",
adamc@144:                           newline,
adamc@144:                           string "}"]
adamc@144:                     ]
adamc@144:             end
adamc@144: 
adamc@144:         val pds' = map p_page ps
adamc@29:     in
adamc@144:         box [string "#include <stdio.h>",
adamc@144:              newline,
adamc@144:              string "#include <stdlib.h>",
adamc@144:              newline,
adamc@144:              newline,
adamc@144:              string "#include \"lacweb.h\"",
adamc@101:              newline,
adamc@101:              newline,
adamc@101:              p_list_sep newline (fn x => x) pds,
adamc@101:              newline,
adamc@144:              string "int lw_inputs_len = ",
adamc@144:              string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
adamc@144:              string ";",
adamc@144:              newline,
adamc@144:              newline,
adamc@144:              string "int lw_input_num(char *name) {",
adamc@144:              newline,
adamc@144:              string "if",
adamc@144:              space,
adamc@144:              string "(name[0]",
adamc@144:              space,
adamc@144:              string "==",
adamc@144:              space,
adamc@144:              string "0)",
adamc@144:              space,
adamc@144:              string "return",
adamc@144:              space,
adamc@144:              string "-1;",
adamc@144:              newline,
adamc@144:              makeSwitch (fnums, 0),
adamc@144:              string "}",
adamc@144:              newline,
adamc@144:              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