Mercurial > urweb

comparison src/flat_print.sml @ 26:4ab19c19665f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Closure conversion
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 15:56:33 -0400
parents
children 537db4ee89f4
comparison
equal deleted inserted replaced
25:0a762c73824d 26:4ab19c19665f
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 flat-code Laconic/Web *)
29
30 structure FlatPrint :> FLAT_PRINT = struct
31
32 open Print.PD
33 open Print
34
35 open Flat
36
37 structure E = FlatEnv
38
39 val debug = ref false
40
41 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
42
43 fun p_typ' par env (t, _) =
44 case t of
45 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
46 space,
47 string "->",
48 space,
49 p_typ env t2])
50 | TCode (t1, t2) => parenIf par (box [p_typ' true env t1,
51 space,
52 string "-->",
53 space,
54 p_typ env t2])
55 | TRecord xcs => box [string "{",
56 p_list (fn (x, t) =>
57 box [string x,
58 space,
59 string ":",
60 space,
61 p_typ env t]) xcs,
62 string "}"]
63 | TNamed n =>
64 if !debug then
65 string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
66 else
67 string (#1 (E.lookupTNamed env n))
68
69 and p_typ env = p_typ' false env
70
71 fun p_exp' par env (e, _) =
72 case e of
73 EPrim p => Prim.p_t p
74 | ERel n =>
75 ((if !debug then
76 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
77 else
78 string (#1 (E.lookupERel env n)))
79 handle E.UnboundRel _ => string ("UNBOUND" ^ Int.toString n))
80 | ENamed n =>
81 if !debug then
82 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
83 else
84 string (#1 (E.lookupENamed env n))
85 | ECode n => string ("code$" ^ Int.toString n)
86 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
87 space,
88 p_exp' true env e2])
89
90 | ERecord xes => box [string "{",
91 p_list (fn (x, e) =>
92 box [string x,
93 space,
94 string "=",
95 space,
96 p_exp env e]) xes,
97 string "}"]
98 | EField (e, x) =>
99 box [p_exp' true env e,
100 string ".",
101 string x]
102
103 | ELet (xes, e) =>
104 let
105 val (env, pps) = foldl (fn ((x, e), (env, pps)) =>
106 (E.pushERel env x dummyTyp,
107 List.revAppend ([space,
108 string "val",
109 space,
110 string x,
111 space,
112 string "=",
113 space,
114 p_exp env e],
115 pps)))
116 (env, []) xes
117 in
118 box [string "let",
119 space,
120 box (rev pps),
121 space,
122 string "in",
123 space,
124 p_exp env e,
125 space,
126 string "end"]
127 end
128
129 and p_exp env = p_exp' false env
130
131 fun p_decl env ((d, _) : decl) =
132 case d of
133 DVal (x, n, t, e) =>
134 let
135 val xp = if !debug then
136 box [string x,
137 string "__",
138 string (Int.toString n)]
139 else
140 string x
141 in
142 box [string "val",
143 space,
144 xp,
145 space,
146 string ":",
147 space,
148 p_typ env t,
149 space,
150 string "=",
151 space,
152 p_exp env e]
153
154 end
155 | DFun (n, x, dom, ran, e) =>
156 let
157 val xp = if !debug then
158 box [string x,
159 string "__",
160 string (Int.toString n)]
161 else
162 string x
163 in
164 box [string "fun",
165 space,
166 string "code$",
167 string (Int.toString n),
168 space,
169 string "(",
170 xp,
171 space,
172 string ":",
173 space,
174 p_typ env dom,
175 string ")",
176 space,
177 string ":",
178 space,
179 p_typ env ran,
180 space,
181 string "=",
182 space,
183 p_exp (E.pushERel env x dom) e]
184
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