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/releases/release-110.36/src/ml-nlffigen/pp.sml
ViewVC logotype

Annotation of /sml/releases/release-110.36/src/ml-nlffigen/pp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 828 - (view) (download)
Original Path: sml/trunk/src/ml-nlffigen/pp.sml

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

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