util/cm2mlb/gen-mlb.sml

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