Mercurial > urweb

comparison src/cjr_print.sml @ 29:537db4ee89f4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Translation to Cjr
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 18:28:43 -0400
parents
children 1c91c5e6840f
comparison
equal deleted inserted replaced
28:104d43266b33 29:537db4ee89f4
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 (* Pretty-printing C jr. *)
29
30 structure CjrPrint :> CJR_PRINT = struct
31
32 open Print.PD
33 open Print
34
35 open Cjr
36
37 structure E = CjrEnv
38 structure EM = ErrorMsg
39
40 val debug = ref false
41
42 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
43
44 fun p_typ' par env (t, loc) =
45 case t of
46 TTop =>
47 (EM.errorAt loc "Undetermined type";
48 string "?")
49 | TFun =>
50 (EM.errorAt loc "Undetermined function type";
51 string "?->")
52 | TCode (t1, t2) => parenIf par (box [p_typ' true env t2,
53 space,
54 string "(*)",
55 space,
56 string "(",
57 p_typ env t1,
58 string ")"])
59 | TRecord i => box [string "struct",
60 space,
61 string "__lws_",
62 string (Int.toString i)]
63 | TNamed n =>
64 (string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n)
65 handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
66
67 and p_typ env = p_typ' false env
68
69 fun p_rel env n = string ("__lwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
70 handle CjrEnv.UnboundRel _ => string ("__lwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
71
72 fun p_exp' par env (e, _) =
73 case e of
74 EPrim p => Prim.p_t p
75 | ERel n => p_rel env n
76 | ENamed n =>
77 (string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
78 handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n))
79 | ECode n => string ("__lwc_" ^ Int.toString n)
80 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
81 string "(",
82 p_exp env e2,
83 string ")"])
84
85 | ERecord (i, xes) => box [string "({",
86 space,
87 string "struct",
88 space,
89 string ("__lws_" ^ Int.toString i),
90 space,
91 string "__lw_tmp",
92 space,
93 string "=",
94 space,
95 string "{",
96 p_list (fn (_, e) =>
97 p_exp env e) xes,
98 string "};",
99 space,
100 string "__lw_tmp;",
101 space,
102 string "})" ]
103 | EField (e, x) =>
104 box [p_exp' true env e,
105 string ".",
106 string x]
107
108 | ELet (xes, e) =>
109 let
110 val (env, pps) = foldl (fn ((x, t, e), (env, pps)) =>
111 let
112 val env' = E.pushERel env x t
113 in
114 (env',
115 List.revAppend ([p_typ env t,
116 space,
117 p_rel env' 0,
118 space,
119 string "=",
120 space,
121 p_exp env e,
122 string ";",
123 newline],
124 pps))
125 end)
126 (env, []) xes
127 in
128 box [string "({",
129 newline,
130 box (rev pps),
131 p_exp env e,
132 space,
133 string ";",
134 newline,
135 string "})"]
136 end
137
138 and p_exp env = p_exp' false env
139
140 fun p_decl env ((d, _) : decl) =
141 case d of
142 DStruct (n, xts) =>
143 box [string "struct",
144 space,
145 string ("__lws_" ^ Int.toString n),
146 space,
147 string "{",
148 newline,
149 p_list_sep (box []) (fn (x, t) => box [p_typ env t,
150 space,
151 string x,
152 string ";",
153 newline]) xts,
154 string "};"]
155
156 | DVal (x, n, t, e) =>
157 box [p_typ env t,
158 space,
159 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
160 space,
161 string "=",
162 space,
163 p_exp env e,
164 string ";"]
165 | DFun (n, x, dom, ran, e) =>
166 let
167 val env' = E.pushERel env x dom
168 in
169 box [p_typ env ran,
170 space,
171 string ("__lwc_" ^ Int.toString n),
172 string "(",
173 p_typ env dom,
174 space,
175 p_rel env' 0,
176 string ")",
177 space,
178 string "{",
179 newline,
180 box[string "return(",
181 p_exp env' e,
182 string ")"],
183 newline,
184 string "}"]
185 end
186
187 fun p_file env file =
188 let
189 val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
190 (E.declBinds env d,
191 p_decl env d))
192 env file
193 in
194 p_list_sep newline (fn x => x) pds
195 end
196
197 end