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.60/gen-sml.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1011 - (view) (download)
Original Path: sml/trunk/src/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 :     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