Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* gen-mlb.sml *) |
2 | (* Modified from SML/NJ sources by Matthew Fluet (mfluet@acm.org) *) | |
3 | ||
4 | (* gen-sml.sml | |
5 | * | |
6 | * Generate SML source code for a given library. | |
7 | * | |
8 | * (C) 2001 Lucent Technologies, Bell Labs | |
9 | * | |
10 | * author: Matthias Blume (blume@research.bell-labs.com) | |
11 | *) | |
12 | ||
13 | local structure P = PortableGraph in | |
14 | structure GenMLB : sig | |
15 | type typ = string | |
16 | type varname = string | |
17 | ||
18 | exception TypeError of typ * varname | |
19 | exception Unbound of varname | |
20 | exception ImportMismatch | |
21 | ||
22 | val gen : { graph: P.graph, | |
23 | nativesrc: string -> string, | |
24 | importprefix: string -> string, | |
25 | outstream: TextIO.outstream, | |
26 | exportprefix: string } -> unit | |
27 | end = struct | |
28 | ||
29 | type typ = string | |
30 | type varname = string | |
31 | ||
32 | exception TypeError of typ * varname | |
33 | exception Unbound of varname | |
34 | exception ImportMismatch | |
35 | ||
36 | structure M = RedBlackMapFn (type ord_key = string | |
37 | val compare = String.compare) | |
38 | ||
39 | type namespace = string | |
40 | type name = string | |
41 | ||
42 | type symbol = namespace * name | |
43 | ||
44 | fun symbol_compare ((ns, n), (ns', n')) = | |
45 | case String.compare (n, n') of | |
46 | EQUAL => String.compare (ns, ns') | |
47 | | unequal => unequal | |
48 | ||
49 | structure SS = RedBlackSetFn (type ord_key = symbol | |
50 | val compare = symbol_compare) | |
51 | structure SM = RedBlackMapFn (type ord_key = symbol | |
52 | val compare = symbol_compare) | |
53 | ||
54 | datatype binding = | |
55 | SYM of symbol | |
56 | | SYMS of SS.set | |
57 | | ENV of symbol SM.map | |
58 | ||
59 | fun gen args = let | |
60 | val { graph = P.GRAPH { imports, defs, export }, | |
61 | nativesrc, | |
62 | importprefix, | |
63 | outstream = outs, | |
64 | exportprefix } = args | |
65 | ||
66 | val (xlocal, xin, xend) = | |
67 | ("local", "in", "end") | |
68 | ||
69 | local | |
70 | val indent = ref 0 | |
71 | in | |
72 | fun out l = (TextIO.output (outs, CharVector.tabulate(!indent, fn _ => #" ")); | |
73 | app (fn s => TextIO.output (outs, s)) l; | |
74 | TextIO.output (outs, "\n")) | |
75 | val (xlocal, xin, xend) = | |
76 | (fn () => (out [xlocal]; | |
77 | indent := !indent + 3), | |
78 | fn () => (indent := !indent - 3; | |
79 | out [xin]; | |
80 | indent := !indent + 3), | |
81 | fn () => (indent := !indent - 3; | |
82 | out [xend])) | |
83 | end | |
84 | ||
85 | val im = | |
86 | let fun add (v, m) = M.insert (m, v, importprefix v) | |
87 | val m = List.foldl add M.empty imports | |
88 | in | |
89 | fn v => M.find (m, v) | |
90 | end | |
91 | ||
92 | val gensym = | |
93 | let val next = ref 0 | |
94 | in | |
95 | fn () => let | |
96 | val i = !next | |
97 | in | |
98 | next := i + 1; | |
99 | "gs_" ^ Int.toString i | |
100 | end | |
101 | end | |
102 | ||
103 | fun genexport (ss, fmt) = let | |
104 | val sl = SS.listItems ss | |
105 | val sl' = map (fn (ns, n) => (ns, gensym ())) sl | |
106 | fun oneline (sy, sy', e) = (fmt (sy, sy'); SM.insert (e, sy, sy')) | |
107 | in | |
108 | ListPair.foldl oneline SM.empty (sl, sl') | |
109 | end | |
110 | ||
111 | fun import (lib, ss) = let | |
112 | val lstruct = | |
113 | case im lib of | |
114 | NONE => raise Unbound lib | |
115 | | SOME n => n | |
116 | fun fmt ((ns, n), (_, n')) = | |
117 | out [ns, " ", n', " = ", lstruct, n] | |
118 | in | |
119 | xlocal (); | |
120 | out ["open ", lib]; | |
121 | xin (); | |
122 | genexport (ss, fmt) | |
123 | before xend () | |
124 | end | |
125 | ||
126 | fun genimport ((ns, n), (_, n')) = | |
127 | out [ns, " ", n, " = ", n'] | |
128 | ||
129 | fun compile (src, native, e, oss) = let | |
130 | fun fmt ((ns, n), (_, n')) = | |
131 | out [ns, " ", n', " = ", n] | |
132 | in | |
133 | xlocal (); | |
134 | SM.appi genimport e; | |
135 | out [if native then src else nativesrc src]; | |
136 | xin (); | |
137 | genexport (oss, fmt) | |
138 | before xend () | |
139 | end | |
140 | ||
141 | fun filter (e, ss) = SM.filteri (fn (sy, _) => SS.member (ss, sy)) e | |
142 | ||
143 | fun get dm v = | |
144 | case M.find (dm, v) of | |
145 | NONE => raise Unbound v | |
146 | | SOME d => d | |
147 | ||
148 | fun getENV dm v = | |
149 | case get dm v of | |
150 | ENV m => m | |
151 | | _ => raise TypeError ("env", v) | |
152 | ||
153 | fun namespace P.SGN = "signature" | |
154 | | namespace P.STR = "structure" | |
155 | | namespace P.FCT = "functor" | |
156 | ||
157 | fun onedef (P.DEF { lhs, rhs }, dm) = let | |
158 | val get = get dm | |
159 | val getENV = getENV dm | |
160 | ||
161 | fun getSYM v = | |
162 | case get v of | |
163 | SYM s => s | |
164 | | _ => raise TypeError ("sym", v) | |
165 | fun getSYMS v = | |
166 | case get v of | |
167 | SYMS ss => ss | |
168 | | _ => raise TypeError ("syms", v) | |
169 | in | |
170 | M.insert (dm, lhs, | |
171 | case rhs of | |
172 | P.SYM (ns, n) => SYM (namespace ns, n) | |
173 | | P.SYMS vl => let | |
174 | fun one (v, ss) = SS.add (ss, getSYM v) | |
175 | in | |
176 | SYMS (foldl one SS.empty vl) | |
177 | end | |
178 | | P.IMPORT { lib, syms } => | |
179 | ENV (import (lib, getSYMS syms)) | |
180 | | P.COMPILE { src = (src, native), env, syms } => | |
181 | ENV (compile (src, native, getENV env, getSYMS syms)) | |
182 | | P.FILTER { env, syms } => | |
183 | ENV (filter (getENV env, getSYMS syms)) | |
184 | | P.MERGE el => let | |
185 | fun one (v, e) = SM.unionWith #2 (getENV v, e) | |
186 | in | |
187 | ENV (foldl one SM.empty el) | |
188 | end) | |
189 | end | |
190 | ||
191 | val _ = xlocal () | |
192 | val _ = out ["$(SML_LIB)/basis/pervasive.mlb"] | |
193 | ||
194 | val dm = foldl onedef M.empty defs | |
195 | ||
196 | val ee = getENV dm export | |
197 | ||
198 | fun libexport ((ns, n), (_, n')) = | |
199 | out [ns, " ", exportprefix, n, " = ", n'] | |
200 | ||
201 | in | |
202 | xin (); | |
203 | SM.appi libexport ee; | |
204 | xend () | |
205 | end | |
206 | end | |
207 | end |