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

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