/usr/share/doc/mlton/cm2mlb/gen-mlb.sml is in mlton-doc 20100608-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | (* gen-mlb.sml *)
(* Modified from SML/NJ sources by Matthew Fluet (mfluet@acm.org) *)
(* gen-sml.sml
*
* Generate SML source code for a given library.
*
* (C) 2001 Lucent Technologies, Bell Labs
*
* author: Matthias Blume (blume@research.bell-labs.com)
*)
local structure P = PortableGraph in
structure GenMLB : sig
type typ = string
type varname = string
exception TypeError of typ * varname
exception Unbound of varname
exception ImportMismatch
val gen : { graph: P.graph,
nativesrc: string -> string,
importprefix: string -> string,
outstream: TextIO.outstream,
exportprefix: string } -> unit
end = struct
type typ = string
type varname = string
exception TypeError of typ * varname
exception Unbound of varname
exception ImportMismatch
structure M = RedBlackMapFn (type ord_key = string
val compare = String.compare)
type namespace = string
type name = string
type symbol = namespace * name
fun symbol_compare ((ns, n), (ns', n')) =
case String.compare (n, n') of
EQUAL => String.compare (ns, ns')
| unequal => unequal
structure SS = RedBlackSetFn (type ord_key = symbol
val compare = symbol_compare)
structure SM = RedBlackMapFn (type ord_key = symbol
val compare = symbol_compare)
datatype binding =
SYM of symbol
| SYMS of SS.set
| ENV of symbol SM.map
fun gen args = let
val { graph = P.GRAPH { imports, defs, export },
nativesrc,
importprefix,
outstream = outs,
exportprefix } = args
val (xlocal, xin, xend) =
("local", "in", "end")
local
val indent = ref 0
in
fun out l = (TextIO.output (outs, CharVector.tabulate(!indent, fn _ => #" "));
app (fn s => TextIO.output (outs, s)) l;
TextIO.output (outs, "\n"))
val (xlocal, xin, xend) =
(fn () => (out [xlocal];
indent := !indent + 3),
fn () => (indent := !indent - 3;
out [xin];
indent := !indent + 3),
fn () => (indent := !indent - 3;
out [xend]))
end
val im =
let fun add (v, m) = M.insert (m, v, importprefix v)
val m = List.foldl add M.empty imports
in
fn v => M.find (m, v)
end
val gensym =
let val next = ref 0
in
fn () => let
val i = !next
in
next := i + 1;
"gs_" ^ Int.toString i
end
end
fun genexport (ss, fmt) = let
val sl = SS.listItems ss
val sl' = map (fn (ns, n) => (ns, gensym ())) sl
fun oneline (sy, sy', e) = (fmt (sy, sy'); SM.insert (e, sy, sy'))
in
ListPair.foldl oneline SM.empty (sl, sl')
end
fun import (lib, ss) = let
val lstruct =
case im lib of
NONE => raise Unbound lib
| SOME n => n
fun fmt ((ns, n), (_, n')) =
out [ns, " ", n', " = ", lstruct, n]
in
xlocal ();
out ["open ", lib];
xin ();
genexport (ss, fmt)
before xend ()
end
fun genimport ((ns, n), (_, n')) =
out [ns, " ", n, " = ", n']
fun compile (src, native, e, oss) = let
fun fmt ((ns, n), (_, n')) =
out [ns, " ", n', " = ", n]
in
xlocal ();
SM.appi genimport e;
out [if native then src else nativesrc src];
xin ();
genexport (oss, fmt)
before xend ()
end
fun filter (e, ss) = SM.filteri (fn (sy, _) => SS.member (ss, sy)) e
fun get dm v =
case M.find (dm, v) of
NONE => raise Unbound v
| SOME d => d
fun getENV dm v =
case get dm v of
ENV m => m
| _ => raise TypeError ("env", v)
fun namespace P.SGN = "signature"
| namespace P.STR = "structure"
| namespace P.FCT = "functor"
fun onedef (P.DEF { lhs, rhs }, dm) = let
val get = get dm
val getENV = getENV dm
fun getSYM v =
case get v of
SYM s => s
| _ => raise TypeError ("sym", v)
fun getSYMS v =
case get v of
SYMS ss => ss
| _ => raise TypeError ("syms", v)
in
M.insert (dm, lhs,
case rhs of
P.SYM (ns, n) => SYM (namespace ns, n)
| P.SYMS vl => let
fun one (v, ss) = SS.add (ss, getSYM v)
in
SYMS (foldl one SS.empty vl)
end
| P.IMPORT { lib, syms } =>
ENV (import (lib, getSYMS syms))
| P.COMPILE { src = (src, native), env, syms } =>
ENV (compile (src, native, getENV env, getSYMS syms))
| P.FILTER { env, syms } =>
ENV (filter (getENV env, getSYMS syms))
| P.MERGE el => let
fun one (v, e) = SM.unionWith #2 (getENV v, e)
in
ENV (foldl one SM.empty el)
end)
end
val _ = xlocal ()
val _ = out ["$(SML_LIB)/basis/pervasive.mlb"]
val dm = foldl onedef M.empty defs
val ee = getENV dm export
fun libexport ((ns, n), (_, n')) =
out [ns, " ", exportprefix, n, " = ", n']
in
xin ();
SM.appi libexport ee;
xend ()
end
end
end
|