2 (* Modified from SML
/NJ sources by Matthew
Fluet (mfluet@acm
.org
) *)
6 * Generate SML source code for a given library
.
8 * (C
) 2001 Lucent Technologies
, Bell Labs
10 * author
: Matthias
Blume (blume@research
.bell
-labs
.com
)
13 local structure P
= PortableGraph
in
14 structure GenMLB
: sig
18 exception TypeError
of typ
* varname
19 exception Unbound
of varname
20 exception ImportMismatch
22 val gen
: { graph
: P
.graph
,
23 nativesrc
: string -> string,
24 importprefix
: string -> string,
25 outstream
: TextIO.outstream
,
26 exportprefix
: string } -> unit
32 exception TypeError
of typ
* varname
33 exception Unbound
of varname
34 exception ImportMismatch
36 structure M
= RedBlackMapFn (type ord_key
= string
37 val compare
= String.compare
)
39 type namespace
= string
42 type symbol
= namespace
* name
44 fun symbol_compare ((ns
, n
), (ns
', n
')) =
45 case String.compare (n
, n
') of
46 EQUAL
=> String.compare (ns
, ns
')
49 structure SS
= RedBlackSetFn (type ord_key
= symbol
50 val compare
= symbol_compare
)
51 structure SM
= RedBlackMapFn (type ord_key
= symbol
52 val compare
= symbol_compare
)
57 | ENV
of symbol SM
.map
60 val { graph
= P
.GRAPH
{ imports
, defs
, export
},
66 val (xlocal
, xin
, xend
) =
67 ("local", "in", "end")
72 fun out l
= (TextIO.output (outs
, CharVector
.tabulate(!indent
, fn _
=> #
" "));
73 app (fn s
=> TextIO.output (outs
, s
)) l
;
74 TextIO.output (outs
, "\n"))
75 val (xlocal
, xin
, xend
) =
76 (fn () => (out
[xlocal
];
77 indent
:= !indent
+ 3),
78 fn () => (indent
:= !indent
- 3;
80 indent
:= !indent
+ 3),
81 fn () => (indent
:= !indent
- 3;
86 let fun add (v
, m
) = M
.insert (m
, v
, importprefix v
)
87 val m
= List.foldl add M
.empty imports
99 "gs_" ^
Int.toString i
103 fun genexport (ss
, fmt
) = let
104 val sl
= SS
.listItems ss
105 val sl
' = map (fn (ns
, n
) => (ns
, gensym ())) sl
106 fun oneline (sy
, sy
', e
) = (fmt (sy
, sy
'); SM
.insert (e
, sy
, sy
'))
108 ListPair.foldl oneline SM
.empty (sl
, sl
')
111 fun import (lib
, ss
) = let
114 NONE
=> raise Unbound lib
116 fun fmt ((ns
, n
), (_
, n
')) =
117 out
[ns
, " ", n
', " = ", lstruct
, n
]
126 fun genimport ((ns
, n
), (_
, n
')) =
127 out
[ns
, " ", n
, " = ", n
']
129 fun compile (src
, native
, e
, oss
) = let
130 fun fmt ((ns
, n
), (_
, n
')) =
131 out
[ns
, " ", n
', " = ", n
]
135 out
[if native
then src
else nativesrc src
];
141 fun filter (e
, ss
) = SM
.filteri (fn (sy
, _
) => SS
.member (ss
, sy
)) e
144 case M
.find (dm
, v
) of
145 NONE
=> raise Unbound v
151 | _
=> raise TypeError ("env", v
)
153 fun namespace P
.SGN
= "signature"
154 | namespace P
.STR
= "structure"
155 | namespace P
.FCT
= "functor"
157 fun onedef (P
.DEF
{ lhs
, rhs
}, dm
) = let
159 val getENV
= getENV dm
164 | _
=> raise TypeError ("sym", v
)
168 | _
=> raise TypeError ("syms", v
)
172 P
.SYM (ns
, n
) => SYM (namespace ns
, n
)
174 fun one (v
, ss
) = SS
.add (ss
, getSYM v
)
176 SYMS (foldl one SS
.empty vl
)
178 | P
.IMPORT
{ lib
, syms
} =>
179 ENV (import (lib
, getSYMS syms
))
180 | P
.COMPILE
{ src
= (src
, native
), env
, syms
} =>
181 ENV (compile (src
, native
, getENV env
, getSYMS syms
))
182 | P
.FILTER
{ env
, syms
} =>
183 ENV (filter (getENV env
, getSYMS syms
))
185 fun one (v
, e
) = SM
.unionWith #
2 (getENV v
, e
)
187 ENV (foldl one SM
.empty el
)
192 val _
= out
["$(SML_LIB)/basis/pervasive.mlb"]
194 val dm
= foldl onedef M
.empty defs
196 val ee
= getENV dm export
198 fun libexport ((ns
, n
), (_
, n
')) =
199 out
[ns
, " ", exportprefix
, n
, " = ", n
']
203 SM
.appi libexport ee
;