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