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@196: val dummyTyp = (TDatatype (Enum, 0, ref []), 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@188: | TDatatype (Enum, n, _) => adamc@188: (box [string "enum", adamc@188: space, adamc@188: string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] adamc@188: handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) adamc@198: | TDatatype (Option, n, xncs) => adamc@198: (case ListUtil.search #3 (!xncs) of adamc@198: NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument" adamc@198: | SOME t => adamc@198: case #1 t of adamc@198: TDatatype _ => p_typ' par env t adamc@199: | TFfi ("Basis", "string") => p_typ' par env t adamc@198: | _ => box [p_typ' par env t, adamc@198: string "*"]) adamc@188: | TDatatype (Default, 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@196: E.pushERel env x t) adamc@182: | PPrim _ => (box [], env) adamc@188: | PCon (_, _, NONE) => (box [], env) adamc@188: | 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@186: | PConFfi {mod = m, con, ...} => string ("lw_" ^ m ^ "_" ^ con) 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@188: | PCon (dk, 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@196: ("lw_" ^ x, to) adamc@182: end adamc@188: | PConFfi {mod = m, con, arg, ...} => adamc@188: ("lw_" ^ m ^ "_" ^ con, arg) 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@198: case dk of adamc@198: Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" adamc@198: | Default => box [string "disc", adamc@198: string (Int.toString depth), adamc@198: string "->data.", adamc@198: string x] adamc@198: | Option => adamc@198: case #1 t of adamc@198: TDatatype _ => box [string "disc", adamc@198: string (Int.toString depth)] adamc@199: | TFfi ("Basis", "string") => box [string "disc", adamc@199: string (Int.toString depth)] adamc@198: | _ => box [string "*disc", adamc@198: string (Int.toString depth)], 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@198: case (dk, po) of adamc@198: (Enum, _) => box [space, adamc@198: string "!=", adamc@198: space, adamc@198: p_patCon env pc] adamc@198: | (Default, _) => box [string "->tag", adamc@198: space, adamc@198: string "!=", adamc@198: space, adamc@198: p_patCon env pc] adamc@198: | (Option, NONE) => box [space, adamc@198: string "!=", adamc@198: space, adamc@198: string "NULL"] adamc@198: | (Option, SOME _) => box [space, adamc@198: string "==", adamc@198: space, adamc@198: string "NULL"], 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@196: string ".__lwf_", 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@185: fun patConInfo env pc = adamc@185: case pc of adamc@185: PConVar n => adamc@185: let adamc@185: val (x, _, dn) = E.lookupConstructor env n adamc@185: val (dx, _) = E.lookupDatatype env dn adamc@185: in adamc@185: ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, adamc@196: "__lwc_" ^ x ^ "_" ^ Int.toString n, adamc@196: "lw_" ^ x) adamc@185: end adamc@186: | PConFfi {mod = m, datatyp, con, ...} => adamc@185: ("lw_" ^ m ^ "_" ^ datatyp, adamc@196: "lw_" ^ m ^ "_" ^ con, adamc@196: "lw_" ^ con) adamc@185: 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@188: | ECon (Enum, pc, _) => p_patCon env pc adamc@198: | ECon (Option, pc, NONE) => string "NULL" adamc@198: | ECon (Option, pc, SOME e) => adamc@198: let adamc@198: val to = case pc of adamc@198: PConVar n => #2 (E.lookupConstructor env n) adamc@198: | PConFfi {arg, ...} => arg adamc@198: adamc@198: val t = case to of adamc@198: NONE => raise Fail "CjrPrint: ECon argument status mismatch" adamc@198: | SOME t => t adamc@198: in adamc@198: case #1 t of adamc@198: TDatatype _ => p_exp' par env e adamc@199: | TFfi ("Basis", "string") => p_exp' par env e adamc@198: | _ => box [string "({", adamc@198: newline, adamc@198: p_typ env t, adamc@198: space, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: string "lw_malloc(ctx, sizeof(", adamc@198: p_typ env t, adamc@198: string "));", adamc@198: newline, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: p_exp' par env e, adamc@198: string ";", adamc@198: newline, adamc@198: string "tmp;", adamc@198: newline, adamc@198: string "})"] adamc@198: end adamc@188: | ECon (Default, pc, eo) => adamc@181: let adamc@196: val (xd, xc, xn) = patConInfo env pc adamc@181: in adamc@182: box [string "({", adamc@181: newline, adamc@181: string "struct", adamc@181: space, adamc@185: string xd, adamc@181: space, adamc@181: string "*tmp", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@185: string "lw_malloc(ctx, sizeof(struct ", adamc@185: string xd, adamc@181: string "));", adamc@181: newline, adamc@181: string "tmp->tag", adamc@181: space, adamc@181: string "=", adamc@181: space, adamc@185: string xc, adamc@181: string ";", adamc@181: newline, adamc@181: case eo of adamc@181: NONE => box [] adamc@185: | SOME e => box [string "tmp->data.", adamc@196: string xn, 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@196: let adamc@196: val env = E.declBinds env dAll adamc@196: in adamc@196: box [string "struct", adamc@196: space, adamc@196: string ("__lws_" ^ Int.toString n), adamc@196: space, adamc@196: string "{", adamc@196: newline, adamc@196: p_list_sep (box []) (fn (x, t) => box [p_typ env t, adamc@196: space, adamc@196: string "__lwf_", adamc@196: string x, adamc@196: string ";", adamc@196: newline]) xts, adamc@196: string "};"] adamc@196: end adamc@188: | DDatatype (Enum, x, n, xncs) => adamc@188: box [string "enum", adamc@188: space, adamc@188: string ("__lwe_" ^ x ^ "_" ^ Int.toString n), adamc@188: space, adamc@188: string "{", adamc@188: space, adamc@188: p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs, adamc@188: space, adamc@188: string "};"] adamc@198: | DDatatype (Option, _, _, _) => box [] adamc@188: | DDatatype (Default, 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@196: string ("lw_" ^ 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@188: end adamc@29: adamc@196: | DDatatypeForward _ => box [] adamc@196: 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@186: fun capitalize s = adamc@186: if s = "" then adamc@186: "" adamc@186: else adamc@186: str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) adamc@186: adamc@144: fun unurlify (t, loc) = adamc@144: case t of adamc@186: TFfi (m, t) => string ("lw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(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@188: | TDatatype (Enum, i, _) => adamc@188: let adamc@188: val (x, xncs) = E.lookupDatatype env i adamc@188: adamc@188: fun doEm xncs = adamc@188: case xncs of adamc@188: [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_" adamc@188: ^ x ^ "_" ^ Int.toString i ^ ")0)") adamc@188: | (x', n, to) :: rest => adamc@188: box [string "((!strncmp(request, \"", adamc@188: string x', adamc@188: string "\", ", adamc@188: string (Int.toString (size x')), adamc@188: string ") && (request[", adamc@188: string (Int.toString (size x')), adamc@188: string "] == 0 || request[", adamc@188: string (Int.toString (size x')), adamc@188: string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n), adamc@188: space, adamc@188: string ":", adamc@188: space, adamc@188: doEm rest, adamc@188: string ")"] adamc@188: in adamc@188: doEm xncs adamc@188: end adamc@188: adamc@198: | TDatatype (Option, i, xncs) => adamc@198: let adamc@198: val (x, _) = E.lookupDatatype env i adamc@198: adamc@198: val (no_arg, has_arg, t) = adamc@198: case !xncs of adamc@198: [(no_arg, _, NONE), (has_arg, _, SOME t)] => adamc@198: (no_arg, has_arg, t) adamc@198: | [(has_arg, _, SOME t), (no_arg, _, NONE)] => adamc@198: (no_arg, has_arg, t) adamc@198: | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" adamc@198: in adamc@198: box [string "(request[0] == '/' ? ++request : request,", adamc@198: newline, adamc@198: string "((!strncmp(request, \"", adamc@198: string no_arg, adamc@198: string "\", ", adamc@198: string (Int.toString (size no_arg)), adamc@198: string ") && (request[", adamc@198: string (Int.toString (size no_arg)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size no_arg)), adamc@198: string "] == '/')) ? (request", adamc@198: space, adamc@198: string "+=", adamc@198: space, adamc@198: string (Int.toString (size no_arg)), adamc@198: string ", NULL) : ((!strncmp(request, \"", adamc@198: string has_arg, adamc@198: string "\", ", adamc@198: string (Int.toString (size has_arg)), adamc@198: string ") && (request[", adamc@198: string (Int.toString (size has_arg)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size has_arg)), adamc@198: string "] == '/')) ? (request", adamc@198: space, adamc@198: string "+=", adamc@198: space, adamc@198: string (Int.toString (size has_arg)), adamc@200: string ", (request[0] == '/' ? ++request : NULL), ", adamc@200: newline, adamc@198: adamc@198: case #1 t of adamc@198: TDatatype _ => unurlify t adamc@199: | TFfi ("Basis", "string") => unurlify t adamc@198: | _ => box [string "({", adamc@198: newline, adamc@198: p_typ env t, adamc@198: space, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: string "lw_malloc(ctx, sizeof(", adamc@198: p_typ env t, adamc@198: string "));", adamc@198: newline, adamc@198: string "*tmp", adamc@198: space, adamc@198: string "=", adamc@198: space, adamc@198: unurlify t, adamc@198: string ";", adamc@198: newline, adamc@198: string "tmp;", adamc@198: newline, adamc@198: string "})"], adamc@198: string ")", adamc@198: newline, adamc@198: string ":", adamc@198: space, adamc@198: string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")] adamc@198: end adamc@198: adamc@188: | TDatatype (Default, 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@200: string "if (request[0] == '/') ++request;", adamc@200: newline, adamc@166: case to of adamc@166: NONE => box [] adamc@197: | SOME t => box [string "tmp->data.lw_", 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@190: adamc@190: val f = case t of adamc@190: (TFfi ("Basis", "bool"), _) => "optional_" adamc@190: | _ => "" adamc@144: in adamc@190: box [string "request = lw_get_", adamc@190: string f, adamc@190: string "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@198: string ") && (request[", adamc@198: string (Int.toString (size s)), adamc@198: string "] == 0 || request[", adamc@198: string (Int.toString (size s)), adamc@198: 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 ", adamc@144: newline, adamc@144: string "#include ", 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: 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