Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-nlffigen/pp.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffigen/pp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1011 - (view) (download)

1 : blume 828 (*
2 :     * pp.sml - Some simple pretty-printing infrastructure for the ml-ffigen
3 :     * program.
4 :     *
5 :     * (C) 2001, Lucent Technologies, Bell Labs
6 :     *
7 :     * author: Matthias Blume (blume@research.bell-labs.com)
8 :     *)
9 :     structure PrettyPrint = struct
10 :    
11 :     structure PP = PPStreamFn (structure Token = StringToken
12 :     structure Device = SimpleTextIODev)
13 :    
14 :     datatype mltype =
15 :     ARROW of mltype * mltype
16 :     | TUPLE of mltype list
17 :     | CON of string * mltype list
18 : blume 975 | RECORD of (string * mltype) list
19 : blume 828
20 :     val Unit = TUPLE []
21 :     fun Type t = CON (t, [])
22 : blume 1011 fun St tag = Type (concat ["ST_", tag, ".tag"])
23 :     fun Un tag = Type (concat ["UT_", tag, ".tag"])
24 : blume 828
25 :     datatype tcontext = C_STAR | C_ARROW | C_COMMA | C_CON
26 :    
27 :     fun simplify (CON ("unit", [])) = Unit
28 :     | simplify (TUPLE [t]) = simplify t
29 :     | simplify (CON (obj as ("obj" | "obj'"),
30 :     [CON (k as ("schar" | "uchar" | "sint" | "uint" |
31 :     "sshort" | "ushort" | "slong" | "ulong" |
32 :     "float" | "double" | "voidptr"), []),
33 : blume 837 c])) =
34 : blume 828 CON (concat [k, "_", obj], [simplify c])
35 :     | simplify (CON (obj as ("obj" | "obj'"),
36 : blume 837 [CON ("fptr", [f]), c])) =
37 : blume 828 CON ("fptr_" ^ obj, [simplify f, simplify c])
38 :     | simplify (CON (obj as ("obj" | "obj'"),
39 : blume 837 [CON ("su", [s]), c])) =
40 : blume 828 CON ("su_" ^ obj, [simplify s, simplify c])
41 :     | simplify (CON ("Dim.dim", [n, CON (("Dim.nonzero" | "nonzero"), [])])) =
42 :     CON ("dim", [simplify n])
43 :     | simplify (CON ("Dim.dec", [])) = CON ("dec", [])
44 :     | simplify (CON (k as ("Dim.dg0" | "Dim.dg1" | "Dim.dg2" | "Dim.dg3" |
45 :     "Dim.dg4" | "Dim.dg5" | "Dim.dg6" | "Dim.dg7" |
46 :     "Dim.dg8" | "Dim.dg9"), [n])) =
47 :     CON (String.extract (k, 4, NONE), [simplify n])
48 :     | simplify (ARROW (t1, t2)) = ARROW (simplify t1, simplify t2)
49 :     | simplify (TUPLE tl) = TUPLE (map simplify tl)
50 : blume 975 | simplify (RECORD ml) = RECORD (map (fn (n, t) => (n, simplify t)) ml)
51 : blume 828 | simplify (CON (k, tl)) = CON (k, map simplify tl)
52 :    
53 :     fun ppType0 s (t as ARROW _, c) =
54 :     let fun loop (ARROW (x, y)) =
55 :     (ppType0 s (x, C_ARROW); PP.string s " ->"; PP.space s 1;
56 :     loop y)
57 :     | loop t = ppType0 s (t, C_ARROW)
58 :     val paren = not (c = C_COMMA)
59 :     val indent = if paren then 5 else 4
60 :     in
61 :     PP.openHOVBox s (PP.Rel indent);
62 :     if paren then PP.string s "(" else ();
63 :     loop t;
64 :     if paren then PP.string s ")" else ();
65 :     PP.closeBox s
66 :     end
67 :     | ppType0 s (TUPLE [], _) = PP.string s "unit"
68 :     | ppType0 s (TUPLE [t], c) = ppType0 s (t, c)
69 :     | ppType0 s (TUPLE tl, c) = let
70 :     fun loop [] = () (* cannot happen *)
71 :     | loop [t] = ppType0 s (t, C_STAR)
72 :     | loop (h :: tl) = (ppType0 s (h, C_STAR);
73 :     PP.string s " *";
74 :     PP.space s 1;
75 :     loop tl)
76 :     val paren =
77 :     case c of (C_STAR | C_CON) => true
78 :     | (C_ARROW | C_COMMA) => false
79 :     val indent = if paren then 1 else 0
80 :     in
81 :     PP.openHVBox s (PP.Rel indent);
82 :     if paren then PP.string s "(" else ();
83 :     loop tl;
84 :     if paren then PP.string s ")" else ();
85 :     PP.closeBox s
86 :     end
87 : blume 975 | ppType0 s (RECORD [], _) = PP.string s "{}"
88 :     | ppType0 s (RECORD tl, _) = let
89 :     fun loop [] = () (* cannot happen *)
90 :     | loop [(n, t)] = (PP.string s (n ^ " : ");
91 :     ppType0 s (t, C_COMMA))
92 :     | loop ((n, t) :: tl) = (PP.string s (n ^ " : ");
93 :     ppType0 s (t, C_COMMA);
94 :     PP.string s ",";
95 :     PP.space s 1;
96 :     loop tl)
97 :     in
98 :     PP.openHVBox s (PP.Rel 2);
99 :     PP.string s "{ ";
100 :     loop tl;
101 :     PP.string s " }";
102 :     PP.closeBox s
103 :     end
104 : blume 828 | ppType0 s (CON (k, []), _) = PP.string s k
105 :     | ppType0 s (CON (k, [t]), _) =
106 :     (PP.openHBox s;
107 :     ppType0 s (t, C_CON);
108 :     PP.space s 1;
109 :     PP.string s k;
110 :     PP.closeBox s)
111 :     | ppType0 s (CON (k, tl), _) = let
112 :     fun loop [] = () (* cannot happen *)
113 :     | loop [t] = ppType0 s (t, C_COMMA)
114 :     | loop (h :: tl) =
115 :     (ppType0 s (h, C_COMMA); PP.string s ","; PP.space s 1; loop tl)
116 :     in
117 :     PP.openHBox s;
118 :     PP.openHVBox s (PP.Rel 1);
119 :     PP.string s "(";
120 :     loop tl;
121 :     PP.string s ")";
122 :     PP.closeBox s;
123 :     PP.space s 1;
124 :     PP.string s k;
125 :     PP.closeBox s
126 :     end
127 :    
128 :     (* start with comma context *)
129 :     fun ppType s t = ppType0 s (simplify t, C_COMMA)
130 :     fun ppType' s (t, c) = ppType0 s (simplify t, c)
131 :    
132 :     datatype mlexp =
133 :     ETUPLE of mlexp list
134 : blume 975 | ERECORD of (string * mlexp) list
135 : blume 828 | EVAR of string
136 :     | EAPP of mlexp * mlexp
137 :     | ECONSTR of mlexp * mltype
138 :     | ESEQ of mlexp * mlexp
139 :    
140 :     datatype econtext = EC_APP | EC_COMMA
141 :    
142 :     fun ppExp0 s (ETUPLE [], _) = PP.string s "()"
143 :     | ppExp0 s (ETUPLE [x], c) = ppExp0 s (x, c)
144 :     | ppExp0 s (ETUPLE xl, _) = let
145 :     fun loop [] = ()
146 :     | loop [x] = ppExp0 s (x, EC_COMMA)
147 :     | loop (x :: xl) =
148 : blume 975 (ppExp0 s (x, EC_COMMA); PP.string s ","; PP.space s 1;
149 :     loop xl)
150 : blume 828 in
151 :     PP.openHVBox s (PP.Rel 1);
152 :     PP.string s "(";
153 :     loop xl;
154 :     PP.string s ")";
155 :     PP.closeBox s
156 :     end
157 : blume 975 | ppExp0 s (ERECORD [], _) = PP.string s "{}"
158 :     | ppExp0 s (ERECORD xl, _) = let
159 :     fun loop [] = ()
160 :     | loop [(n, x)] = (PP.string s (n ^ " =");
161 :     PP.space s 1;
162 :     ppExp0 s (x, EC_COMMA))
163 :     | loop ((n, x) :: xl) = (PP.string s (n ^ " =");
164 :     PP.space s 1;
165 :     ppExp0 s (x, EC_COMMA);
166 :     PP.string s ",";
167 :     PP.space s 1;
168 :     loop xl)
169 :     in
170 :     PP.openHVBox s (PP.Rel 2);
171 :     PP.string s "{ ";
172 :     loop xl;
173 :     PP.string s " }";
174 :     PP.closeBox s
175 :     end
176 : blume 828 | ppExp0 s (EVAR v, _) = PP.string s v
177 :     | ppExp0 s (EAPP (x, y), c) = let
178 :     fun loop (EAPP (x, y)) =
179 :     (loop x; ppExp0 s (y, EC_APP); PP.space s 1)
180 :     | loop x = (ppExp0 s (x, EC_APP);
181 :     PP.space s 1;
182 :     PP.openHOVBox s (PP.Rel 0))
183 :     val paren = c = EC_APP
184 :     in
185 :     PP.openHOVBox s (PP.Abs 4);
186 :     if paren then PP.string s "(" else ();
187 :     loop x;
188 :     ppExp0 s (y, EC_APP);
189 :     if paren then PP.string s ")" else ();
190 :     PP.closeBox s;
191 :     PP.closeBox s
192 :     end
193 :     | ppExp0 s (ECONSTR (x, t), c) = let
194 :     val paren = c = EC_APP
195 :     val indent = if paren then 5 else 4
196 :     val tc = if paren then C_CON else C_COMMA
197 :     in
198 :     PP.openHOVBox s (PP.Rel indent);
199 :     if paren then PP.string s "(" else ();
200 :     ppExp0 s (x, c);
201 :     PP.nbSpace s 1;
202 :     PP.string s ":";
203 :     PP.space s 1;
204 :     ppType' s (t, tc);
205 :     if paren then PP.string s ")" else ();
206 :     PP.closeBox s
207 :     end
208 :     | ppExp0 s (ESEQ (x, y), c) = let
209 :     in
210 :     PP.string s "(";
211 :     PP.openHVBox s (PP.Rel 0);
212 :     ppExp0 s (x, EC_COMMA);
213 :     PP.string s ";";
214 :     PP.space s 1;
215 :     ppExp0 s (y, EC_COMMA);
216 :     PP.string s ")";
217 :     PP.closeBox s
218 :     end
219 :    
220 :     fun ppExp s x = ppExp0 s (x, EC_COMMA)
221 :     fun ppExp' s x = ppExp0 s (x, EC_APP)
222 :    
223 :     fun ppFun s (name, args, body) =
224 :     (PP.openHOVBox s (PP.Rel 4);
225 :     PP.string s ("fun " ^ name);
226 :     PP.nbSpace s 1;
227 :     app (fn a => (ppExp' s a; PP.space s 1)) args;
228 :     PP.string s "=";
229 :     PP.nbSpace s 1;
230 :     PP.openBox s (PP.Rel 0);
231 :     ppExp s body;
232 :     PP.closeBox s;
233 :     PP.closeBox s)
234 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0