| 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
|
Parent Directory
| 
Revision Log
