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 /sml/trunk/src/cm/pgraph/gen-sml.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/pgraph/gen-sml.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 975 - (view) (download)

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

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