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 /pgraph/releases/release-110.66/gen-sml.sml
ViewVC logotype

Annotation of /pgraph/releases/release-110.66/gen-sml.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2162 - (view) (download)
Original Path: sml/trunk/cm/pgraph/gen-sml.sml

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 : blume 1059 exportprefix: string,
23 :     use_toplocal: bool } -> unit
24 : blume 975 end = struct
25 :    
26 :     type typ = string
27 :     type varname = string
28 :    
29 :     exception TypeError of typ * varname
30 :     exception Unbound of varname
31 :     exception ImportMismatch
32 :    
33 :     structure M = RedBlackMapFn (type ord_key = string
34 :     val compare = String.compare)
35 :    
36 :     type namespace = string
37 :     type name = string
38 :    
39 :     type symbol = namespace * name
40 :    
41 :     fun symbol_compare ((ns, n), (ns', n')) =
42 :     case String.compare (n, n') of
43 :     EQUAL => String.compare (ns, ns')
44 :     | unequal => unequal
45 :    
46 :     structure SS = RedBlackSetFn (type ord_key = symbol
47 :     val compare = symbol_compare)
48 :     structure SM = RedBlackMapFn (type ord_key = symbol
49 :     val compare = symbol_compare)
50 :    
51 :     datatype binding =
52 :     SYM of symbol
53 :     | SYMS of SS.set
54 :     | ENV of symbol SM.map
55 :    
56 :     fun gen args = let
57 :     val { graph = P.GRAPH { imports, defs, export },
58 : blume 977 nativesrc,
59 : blume 975 importstructs,
60 :     outstream = outs,
61 : blume 1059 exportprefix,
62 :     use_toplocal } = args
63 : blume 975
64 : blume 1059 val (xlocal, xin, xend) =
65 :     if use_toplocal then ("local", "in", "end")
66 :     else ("(* local *)", "(* in *)", "(* end *)")
67 :    
68 : blume 975 fun out l = app (fn s => TextIO.output (outs, s)) l
69 :    
70 :     val im =
71 :     if length imports = length importstructs then
72 :     let fun add (v, str, m) = M.insert (m, v, str)
73 :     val m = ListPair.foldl add M.empty (imports, importstructs)
74 :     in
75 :     fn v => M.find (m, v)
76 :     end
77 :     else raise ImportMismatch
78 :    
79 :     val gensym =
80 :     let val next = ref 0
81 :     in
82 :     fn () => let
83 :     val i = !next
84 :     in
85 :     next := i + 1;
86 :     "gs_" ^ Int.toString i
87 :     end
88 :     end
89 :    
90 :     fun genexport (ss, fmt) = let
91 :     val sl = SS.listItems ss
92 :     val sl' = map (fn (ns, n) => (ns, gensym ())) sl
93 :     fun oneline (sy, sy', e) = (fmt (sy, sy'); SM.insert (e, sy, sy'))
94 :     in
95 :     ListPair.foldl oneline SM.empty (sl, sl')
96 :     end
97 :    
98 :     fun import (lib, ss) = let
99 :     val lstruct =
100 :     case im lib of
101 :     NONE => raise Unbound lib
102 :     | SOME n => n
103 :     fun fmt ((ns, n), (_, n')) =
104 : blume 977 out [ns, " ", n', " = ", lstruct, n, "\n"]
105 : blume 975 in
106 :     genexport (ss, fmt)
107 :     end
108 :    
109 :     fun genimport ((ns, n), (_, n')) =
110 :     out [" ", ns, " ", n, " = ", n', "\n"]
111 :    
112 : blume 977 fun compile (src, native, e, oss) = let
113 : blume 975 fun fmt ((ns, n), (_, n')) =
114 :     out [ns, " ", n', " = ", n, "\n"]
115 :     fun copyfile src = let
116 : blume 977 val ins = TextIO.openIn (if native then src else nativesrc src)
117 : blume 975 fun copy () =
118 :     case TextIO.input ins of
119 :     "" => TextIO.closeIn ins
120 :     | s => (out [s]; copy ())
121 :     in
122 :     copy ()
123 :     end
124 :     in
125 : blume 1059 out [xlocal, "\n"];
126 : blume 975 SM.appi genimport e;
127 : blume 1059 out [xin, "\n"];
128 : blume 975 copyfile src;
129 :     genexport (oss, fmt)
130 : blume 1059 before out [xend, "\n"]
131 : blume 975 end
132 :    
133 :     fun filter (e, ss) = SM.filteri (fn (sy, _) => SS.member (ss, sy)) e
134 :    
135 :     fun get dm v =
136 :     case M.find (dm, v) of
137 :     NONE => raise Unbound v
138 :     | SOME d => d
139 :    
140 :     fun getENV dm v =
141 :     case get dm v of
142 :     ENV m => m
143 :     | _ => raise TypeError ("env", v)
144 :    
145 : blume 1011 fun namespace P.SGN = "signature"
146 :     | namespace P.STR = "structure"
147 :     | namespace P.FCT = "functor"
148 : blume 975
149 :     fun onedef (P.DEF { lhs, rhs }, dm) = let
150 :     val get = get dm
151 :     val getENV = getENV dm
152 :    
153 :     fun getSYM v =
154 :     case get v of
155 :     SYM s => s
156 :     | _ => raise TypeError ("sym", v)
157 :     fun getSYMS v =
158 :     case get v of
159 :     SYMS ss => ss
160 :     | _ => raise TypeError ("syms", v)
161 :     in
162 :     M.insert (dm, lhs,
163 :     case rhs of
164 :     P.SYM (ns, n) => SYM (namespace ns, n)
165 :     | P.SYMS vl => let
166 :     fun one (v, ss) = SS.add (ss, getSYM v)
167 :     in
168 :     SYMS (foldl one SS.empty vl)
169 :     end
170 :     | P.IMPORT { lib, syms } =>
171 :     ENV (import (lib, getSYMS syms))
172 : blume 977 | P.COMPILE { src = (src, native), env, syms } =>
173 :     ENV (compile (src, native, getENV env, getSYMS syms))
174 : blume 975 | P.FILTER { env, syms } =>
175 :     ENV (filter (getENV env, getSYMS syms))
176 :     | P.MERGE el => let
177 :     fun one (v, e) = SM.unionWith #2 (getENV v, e)
178 :     in
179 :     ENV (foldl one SM.empty el)
180 :     end)
181 :     end
182 :    
183 :     val _ = out ["local\n"]
184 :    
185 :     val dm = foldl onedef M.empty defs
186 :    
187 :     val ee = getENV dm export
188 :    
189 :     fun libexport ((ns, n), (_, n')) =
190 : blume 977 out [ns, " ", exportprefix, n, " = ", n', "\n"]
191 : blume 975
192 :     in
193 :     out ["in\n"];
194 :     SM.appi libexport ee;
195 :     out ["end\n"]
196 :     end
197 :     end
198 :     end

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