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