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

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