| 1 | (* |
| 2 | * Author: Matthew Fluet (mfluet@acm.org) |
| 3 | * |
| 4 | * This requires that you have SML/NJ installed. |
| 5 | * It works with SML/NJ 110.47 and may require changes to work with other |
| 6 | * versions, since it depends on the CM structure. |
| 7 | * |
| 8 | * cm2mlb takes a ".cm" file and prints on stdout a corresponding ".mlb". |
| 9 | * |
| 10 | * To use from the REPL, do the following: |
| 11 | * CM2MLB.cm2mlb {defines = ["MLton"], |
| 12 | * binds = [], |
| 13 | * maps = [], |
| 14 | * sources = "sources.cm", |
| 15 | * out = TextIO.stdOut} |
| 16 | * |
| 17 | * Before using from the shell, you must do the following, where <smlnj> is |
| 18 | * the root directory of the SML/NJ installation. You may need to be root in |
| 19 | * order to do these. |
| 20 | * 1. From the SML/NJ REPL: |
| 21 | * CM.make "cm2mlb.cm"; |
| 22 | * CM2MLB.export (); |
| 23 | * 2. ln -s <smlnj>/bin/.run-sml <smlnj>/bin/cm2mlb |
| 24 | * 3. mv cm2mlb.x86-linux <smlnj>/bin/.heap |
| 25 | * |
| 26 | * Once it is installed, the usage is as follows: |
| 27 | * cm2mlb [-Dsym ...] [-bind file] [-map file] sources.cm |
| 28 | * |
| 29 | * -Dsym can be used to define CM preprocessor symbols. |
| 30 | * -bind file can be used to add cm anchor bindings. |
| 31 | * -map file can be used to add cm2mlb mappings. |
| 32 | *) |
| 33 | |
| 34 | structure CM2MLB : |
| 35 | sig |
| 36 | val cm2mlb : {defines: string list, |
| 37 | binds: string list, |
| 38 | maps: string list, |
| 39 | out: TextIO.outstream, |
| 40 | sources: string} -> unit |
| 41 | val main: string * string list -> OS.Process.status |
| 42 | val export : unit -> unit |
| 43 | end = |
| 44 | struct |
| 45 | structure PG = PortableGraph |
| 46 | |
| 47 | fun message s = TextIO.output (TextIO.stdErr, s ^ "\n") |
| 48 | fun die msg = |
| 49 | (message ("Error: " ^ msg) |
| 50 | ; OS.Process.exit OS.Process.failure) |
| 51 | |
| 52 | structure CM = |
| 53 | struct |
| 54 | open CM |
| 55 | |
| 56 | structure Graph = |
| 57 | struct |
| 58 | val graph = fn src => |
| 59 | (Graph.graph src) |
| 60 | handle _ => NONE |
| 61 | end |
| 62 | end |
| 63 | |
| 64 | structure AnchorBind = |
| 65 | struct |
| 66 | |
| 67 | fun make (file : string) = |
| 68 | if OS.FileSys.access (file, [OS.FileSys.A_READ]) |
| 69 | then |
| 70 | let |
| 71 | val lines = |
| 72 | let |
| 73 | val f = TextIO.openIn file |
| 74 | in |
| 75 | let |
| 76 | fun loop lines = |
| 77 | case TextIO.inputLine f of |
| 78 | NONE => List.rev lines |
| 79 | | SOME l => loop (l::lines) |
| 80 | in |
| 81 | loop [] |
| 82 | before TextIO.closeIn f |
| 83 | end handle e => (TextIO.closeIn f; raise e) |
| 84 | end handle _ => [] |
| 85 | in |
| 86 | List.mapPartial |
| 87 | (fn line => |
| 88 | if CharVector.all Char.isSpace line |
| 89 | orelse CharVector.sub (line, 0) = #"#" |
| 90 | then NONE |
| 91 | else |
| 92 | case String.tokens Char.isSpace line of |
| 93 | [anchor, value] => |
| 94 | SOME {anchor = anchor, value = value} |
| 95 | | _ => die (concat ["strange anchor->value mapping: ", |
| 96 | file, ":: ", line])) |
| 97 | lines |
| 98 | end |
| 99 | else [] |
| 100 | end |
| 101 | |
| 102 | structure AnchorMap = |
| 103 | struct |
| 104 | |
| 105 | fun make (file : string) = |
| 106 | if OS.FileSys.access (file, [OS.FileSys.A_READ]) |
| 107 | then |
| 108 | let |
| 109 | val lines = |
| 110 | let |
| 111 | val f = TextIO.openIn file |
| 112 | in |
| 113 | let |
| 114 | fun loop lines = |
| 115 | case TextIO.inputLine f of |
| 116 | NONE => List.rev lines |
| 117 | | SOME l => loop (l::lines) |
| 118 | in |
| 119 | loop [] |
| 120 | before TextIO.closeIn f |
| 121 | end handle e => (TextIO.closeIn f; raise e) |
| 122 | end handle _ => [] |
| 123 | in |
| 124 | List.mapPartial |
| 125 | (fn line => |
| 126 | if CharVector.all Char.isSpace line |
| 127 | orelse CharVector.sub (line, 0) = #"#" |
| 128 | then NONE |
| 129 | else |
| 130 | case String.tokens Char.isSpace line of |
| 131 | [cmAnchor, mlbPath] => |
| 132 | SOME {cmAnchor = cmAnchor, mlbPath = mlbPath} |
| 133 | | _ => die (concat ["strange cm->mlb mapping: ", |
| 134 | file, ":: ", line])) |
| 135 | lines |
| 136 | end |
| 137 | else [] |
| 138 | |
| 139 | val default = make "cm2mlb-map" |
| 140 | end |
| 141 | |
| 142 | fun cm2mlb {defines, binds, maps, out, sources} = |
| 143 | let |
| 144 | (* Define preprocessor symbols *) |
| 145 | val _ = |
| 146 | List.app |
| 147 | (fn sym => (#set (CM.symval sym)) (SOME 1)) |
| 148 | defines |
| 149 | val _ = (#set CM.Control.verbose) false |
| 150 | val _ = (#set CM.Control.warn_obsolete) false |
| 151 | val _ = Control.printWarnings := false |
| 152 | |
| 153 | val _ = |
| 154 | List.app |
| 155 | (fn {anchor, value} => |
| 156 | #set (CM.Anchor.anchor anchor) (SOME value)) |
| 157 | (List.concat (List.map AnchorBind.make binds)) |
| 158 | |
| 159 | local |
| 160 | val anchorMap = |
| 161 | List.concat |
| 162 | ((List.map AnchorMap.make maps) @ |
| 163 | [AnchorMap.default]) |
| 164 | |
| 165 | fun peekAnchorMap cmAnchor' = |
| 166 | case List.find (fn {cmAnchor, ...} => cmAnchor = cmAnchor') anchorMap of |
| 167 | NONE => NONE |
| 168 | | SOME {mlbPath, ...} => SOME mlbPath |
| 169 | in |
| 170 | val peekAnchorMap = peekAnchorMap |
| 171 | end |
| 172 | |
| 173 | val _ = |
| 174 | if OS.FileSys.access (sources, [OS.FileSys.A_READ]) |
| 175 | then () |
| 176 | else die (concat ["file not found: ", sources]) |
| 177 | val {dir, file = sources} = OS.Path.splitDirFile sources |
| 178 | val () = if dir <> "" then OS.FileSys.chDir dir else () |
| 179 | in |
| 180 | case CM.Graph.graph sources of |
| 181 | SOME {graph as PG.GRAPH {imports, ...}, imports = importLibs, nativesrc} => |
| 182 | let |
| 183 | val imports = |
| 184 | ListPair.map |
| 185 | (fn (bid, cmLib) => |
| 186 | let |
| 187 | val cmLibDescr = CM.Library.descr cmLib |
| 188 | val cmLibOSString = CM.Library.osstring cmLib |
| 189 | |
| 190 | fun mlbLibDef () = |
| 191 | let |
| 192 | val {base, ext} = OS.Path.splitBaseExt cmLibOSString |
| 193 | val mlbLib = OS.Path.joinBaseExt {base = base, ext = SOME "mlb"} |
| 194 | in |
| 195 | mlbLib |
| 196 | end |
| 197 | |
| 198 | fun doitAnchoredPath arcs = |
| 199 | let |
| 200 | fun loop (prefix, suffix) = |
| 201 | if List.null prefix |
| 202 | then concat ["(* ", cmLibDescr, " =??=> *) ", mlbLibDef ()] |
| 203 | else case peekAnchorMap (String.concatWith "/" (List.rev prefix)) of |
| 204 | SOME mlbPath => |
| 205 | concat ["(* ", cmLibDescr, " ====> *) ", mlbPath ^ suffix] |
| 206 | | NONE => |
| 207 | let |
| 208 | val suffix = |
| 209 | if suffix = "" |
| 210 | then OS.Path.joinBaseExt |
| 211 | {base = #base (OS.Path.splitBaseExt (List.hd prefix)), |
| 212 | ext = SOME "mlb"} |
| 213 | else (List.hd prefix) ^ suffix |
| 214 | in |
| 215 | loop (List.tl prefix, "/" ^ suffix) |
| 216 | end |
| 217 | in |
| 218 | loop (List.rev arcs, "") |
| 219 | end |
| 220 | |
| 221 | val mlbLib = |
| 222 | if String.sub (cmLibDescr, 0) = #"$" |
| 223 | then case String.fields (fn #"/" => true | _ => false) cmLibDescr of |
| 224 | "$" :: (arcs as (arc0 :: _)) => |
| 225 | doitAnchoredPath (("$" ^ arc0) :: arcs) |
| 226 | | arc0 :: arcs => |
| 227 | let |
| 228 | val arc0 = |
| 229 | case CharVector.findi (fn (_, #"(") => true | _ => false) arc0 of |
| 230 | SOME (i, _) => |
| 231 | String.extract (arc0, i + 2, SOME (String.size arc0 - i - 3)) |
| 232 | | NONE => arc0 |
| 233 | in |
| 234 | doitAnchoredPath (arc0 :: arcs) |
| 235 | end |
| 236 | | arcs => doitAnchoredPath arcs |
| 237 | else concat ["(* ", cmLibOSString, " ===> *) ", mlbLibDef ()] |
| 238 | in |
| 239 | concat |
| 240 | [" basis ", bid, " =\n", |
| 241 | " bas\n", |
| 242 | " ", mlbLib, "\n", |
| 243 | " end\n"] |
| 244 | end) |
| 245 | (imports, importLibs) |
| 246 | in |
| 247 | TextIO.output (out, "local\n"); |
| 248 | List.app (fn s => TextIO.output (out, s)) imports; |
| 249 | TextIO.output (out, "in\n"); |
| 250 | GenMLB.gen {graph = graph, |
| 251 | nativesrc = nativesrc, |
| 252 | importprefix = fn _ => "", |
| 253 | exportprefix = "", |
| 254 | outstream = out}; |
| 255 | TextIO.output (out, "end\n") |
| 256 | end |
| 257 | | NONE => die ("CM.Graph.graph " ^ sources ^ " failed") |
| 258 | end |
| 259 | |
| 260 | fun usage msg = |
| 261 | (message "Usage: cm2mlb [-Dsym ...] [-bind file] [-map file] sources.cm" |
| 262 | ; die msg) |
| 263 | |
| 264 | fun main (_, args) = |
| 265 | let |
| 266 | val defines = ref ["MLton"] |
| 267 | val binds = ref [] |
| 268 | val maps = ref [] |
| 269 | fun loop args = |
| 270 | case args of |
| 271 | [file] => |
| 272 | cm2mlb {defines = !defines, |
| 273 | binds = !binds, |
| 274 | maps = !maps, |
| 275 | out = TextIO.stdOut, |
| 276 | sources = file} |
| 277 | | flag :: args => |
| 278 | if String.isPrefix "-D" flag |
| 279 | then |
| 280 | (defines := String.extract (flag, 2, NONE) :: !defines |
| 281 | ; loop args) |
| 282 | else if "-bind" = flag |
| 283 | then case args of |
| 284 | file :: args => (binds := file :: !binds |
| 285 | ; loop args) |
| 286 | | _ => usage "missing map file" |
| 287 | else if "-map" = flag |
| 288 | then case args of |
| 289 | file :: args => (maps := file :: !maps |
| 290 | ; loop args) |
| 291 | | _ => usage "missing map file" |
| 292 | else usage (String.concat ["invalid flag ", flag]) |
| 293 | | _ => usage "wrong number of arguments" |
| 294 | in |
| 295 | loop args handle e => die (concat ["cm2mlb failed: ", General.exnMessage e]) |
| 296 | ; OS.Process.success |
| 297 | end |
| 298 | |
| 299 | fun export () = |
| 300 | SMLofNJ.exportFn |
| 301 | ("cm2mlb", main) |
| 302 | end |