Mercurial > urweb
comparison src/cjr_print.sml @ 29:537db4ee89f4
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 |