[hcoop/debian/mlton.git] / util / cm2mlb / cm2mlb.sml

(*
 * Author: Matthew Fluet (mfluet@acm.org) 
 *
 * This requires that you have SML/NJ installed.
 * It works with SML/NJ 110.47 and may require changes to work with other
 * versions, since it depends on the CM structure.
 *
 * cm2mlb takes a ".cm" file and prints on stdout a corresponding ".mlb".
 *
 * To use from the REPL, do the following:
 * CM2MLB.cm2mlb {defines = ["MLton"],
 *                binds = [],
 *                maps = [],
 *                sources = "sources.cm",
 *                out = TextIO.stdOut}
 *
 * Before using from the shell, you must do the following, where <smlnj> is
 * the root directory of the SML/NJ installation.  You may need to be root in
 * order to do these.
 * 1. From the SML/NJ REPL:
 *      CM.make "cm2mlb.cm";
 *      CM2MLB.export ();
 * 2. ln -s <smlnj>/bin/.run-sml <smlnj>/bin/cm2mlb
 * 3. mv cm2mlb.x86-linux <smlnj>/bin/.heap
 *
 * Once it is installed, the usage is as follows:
 *   cm2mlb [-Dsym ...] [-bind file] [-map file] sources.cm
 *
 * -Dsym can be used to define CM preprocessor symbols.
 * -bind file can be used to add cm anchor bindings.
 * -map file can be used to add cm2mlb mappings.
 *)

structure CM2MLB :
sig
   val cm2mlb : {defines: string list,
                 binds: string list,
                 maps: string list,
                 out: TextIO.outstream,
                 sources: string} -> unit
   val main: string * string list -> OS.Process.status
   val export : unit -> unit
end =
struct
   structure PG = PortableGraph

   fun message s = TextIO.output (TextIO.stdErr, s ^ "\n")
   fun die msg =
      (message ("Error: " ^ msg)
       ; OS.Process.exit OS.Process.failure)

   structure CM =
      struct
         open CM

         structure Graph =
            struct
               val graph = fn src =>
                  (Graph.graph src)
                  handle _ => NONE
            end
      end

   structure AnchorBind =
      struct

         fun make (file : string) =
            if OS.FileSys.access (file, [OS.FileSys.A_READ])
               then
                  let
                     val lines =
                        let
                           val f = TextIO.openIn file
                        in
                           let
                              fun loop lines =
                                 case TextIO.inputLine f of
                                    NONE => List.rev lines
                                  | SOME l => loop (l::lines)
                           in
                              loop []
                              before TextIO.closeIn f
                           end handle e => (TextIO.closeIn f; raise e)
                        end handle _ => []
                  in
                     List.mapPartial
                     (fn line =>
                      if CharVector.all Char.isSpace line
                         orelse CharVector.sub (line, 0) = #"#"
                         then NONE
                         else
                            case String.tokens Char.isSpace line of
                               [anchor, value] =>
                                  SOME {anchor = anchor, value = value}
                             | _ =>  die (concat ["strange anchor->value mapping: ",
                                                  file, ":: ", line]))
                     lines
                  end
               else []
      end

   structure AnchorMap =
      struct

         fun make (file : string) =
            if OS.FileSys.access (file, [OS.FileSys.A_READ])
               then 
                  let
                     val lines =
                        let
                           val f = TextIO.openIn file
                        in
                           let
                              fun loop lines =
                                 case TextIO.inputLine f of
                                    NONE => List.rev lines
                                  | SOME l => loop (l::lines)
                           in
                              loop []
                              before TextIO.closeIn f
                           end handle e => (TextIO.closeIn f; raise e)
                        end handle _ => []
                  in
                     List.mapPartial
                     (fn line =>
                      if CharVector.all Char.isSpace line
                         orelse CharVector.sub (line, 0) = #"#"
                         then NONE
                         else 
                            case String.tokens Char.isSpace line of
                               [cmAnchor, mlbPath] => 
                                  SOME {cmAnchor = cmAnchor, mlbPath = mlbPath}
                             | _ =>  die (concat ["strange cm->mlb mapping: ", 
                                                  file, ":: ", line]))
                     lines
                  end
               else []

         val default = make "cm2mlb-map"
      end

   fun cm2mlb {defines, binds, maps, out, sources} =
      let
         (* Define preprocessor symbols *)
         val _ = 
            List.app 
            (fn sym => (#set (CM.symval sym)) (SOME 1))
            defines
         val _ = (#set CM.Control.verbose) false
         val _ = (#set CM.Control.warn_obsolete) false
         val _ = Control.printWarnings := false

         val _ =
            List.app
            (fn {anchor, value} =>
             #set (CM.Anchor.anchor anchor) (SOME value))
            (List.concat (List.map AnchorBind.make binds))

         local
            val anchorMap =
               List.concat
               ((List.map AnchorMap.make maps) @
                [AnchorMap.default])

            fun peekAnchorMap cmAnchor' =
               case List.find (fn {cmAnchor, ...} => cmAnchor = cmAnchor') anchorMap of
                  NONE => NONE
                | SOME {mlbPath, ...} => SOME mlbPath
         in
            val peekAnchorMap = peekAnchorMap
         end

         val _ =
            if OS.FileSys.access (sources, [OS.FileSys.A_READ])
               then ()
               else die (concat ["file not found: ", sources])
         val {dir, file = sources} = OS.Path.splitDirFile sources
         val () = if dir <> "" then OS.FileSys.chDir dir else ()
      in
         case CM.Graph.graph sources of
            SOME {graph as PG.GRAPH {imports, ...}, imports = importLibs, nativesrc} =>
               let
                  val imports =
                     ListPair.map
                     (fn (bid, cmLib) =>
                      let
                         val cmLibDescr = CM.Library.descr cmLib
                         val cmLibOSString = CM.Library.osstring cmLib

                         fun mlbLibDef () =
                            let
                               val {base, ext} = OS.Path.splitBaseExt cmLibOSString
                               val mlbLib = OS.Path.joinBaseExt {base = base, ext = SOME "mlb"}
                            in
                               mlbLib
                            end

                         fun doitAnchoredPath arcs =
                            let
                               fun loop (prefix, suffix) =
                                  if List.null prefix 
                                     then concat ["(* ", cmLibDescr, " =??=> *) ", mlbLibDef ()]
                                     else case peekAnchorMap (String.concatWith "/" (List.rev prefix)) of
                                             SOME mlbPath =>
                                                concat ["(* ", cmLibDescr, " ====> *) ", mlbPath ^ suffix]
                                           | NONE =>
                                                let
                                                   val suffix =
                                                      if suffix = ""
                                                         then OS.Path.joinBaseExt
                                                              {base = #base (OS.Path.splitBaseExt (List.hd prefix)),
                                                               ext = SOME "mlb"}
                                                         else (List.hd prefix) ^ suffix
                                                in
                                                   loop (List.tl prefix, "/" ^ suffix)
                                                end
                            in
                               loop (List.rev arcs, "")
                            end

                         val mlbLib =
                            if String.sub (cmLibDescr, 0) = #"$"
                               then case String.fields (fn #"/" => true | _ => false) cmLibDescr of
                                       "$" :: (arcs as (arc0 :: _)) => 
                                          doitAnchoredPath (("$" ^ arc0) :: arcs)
                                     | arc0 :: arcs =>
                                          let
                                             val arc0 =
                                                case CharVector.findi (fn (_, #"(") => true | _ => false) arc0 of
                                                   SOME (i, _) => 
                                                      String.extract (arc0, i + 2, SOME (String.size arc0 - i - 3))
                                                 | NONE => arc0
                                          in 
                                             doitAnchoredPath (arc0 :: arcs)
                                          end
                                     | arcs => doitAnchoredPath arcs
                               else concat ["(* ", cmLibOSString, " ===> *) ", mlbLibDef ()]
                      in
                         concat 
                         ["  basis ", bid, " =\n",
                          "    bas\n",
                          "      ", mlbLib, "\n",
                          "    end\n"]
                      end)
                     (imports, importLibs)
               in
                  TextIO.output (out, "local\n");
                  List.app (fn s => TextIO.output (out, s)) imports;
                  TextIO.output (out, "in\n");
                  GenMLB.gen {graph = graph,
                              nativesrc = nativesrc,
                              importprefix = fn _ => "",
                              exportprefix = "",
                              outstream = out};
                  TextIO.output (out, "end\n")
               end
          | NONE => die ("CM.Graph.graph " ^ sources ^ " failed") 
      end

   fun usage msg =
      (message "Usage: cm2mlb [-Dsym ...] [-bind file] [-map file] sources.cm"
       ; die msg)

   fun main (_, args) =
      let
         val defines = ref ["MLton"]
         val binds = ref []
         val maps = ref []
         fun loop args = 
            case args of
               [file] =>
                  cm2mlb {defines = !defines,
                          binds = !binds,
                          maps = !maps,
                          out = TextIO.stdOut,
                          sources = file}
             | flag :: args =>
                  if String.isPrefix "-D" flag
                     then
                        (defines := String.extract (flag, 2, NONE) :: !defines
                         ; loop args)
                  else if "-bind" = flag
                     then case args of
                            file :: args => (binds := file :: !binds
                                             ; loop args)
                          | _ => usage "missing map file"
                  else if "-map" = flag
                     then case args of
                            file :: args => (maps := file :: !maps
                                             ; loop args)
                          | _ => usage "missing map file"
                  else usage (String.concat ["invalid flag ", flag])
             | _ => usage "wrong number of arguments"
      in
         loop args handle e => die (concat ["cm2mlb failed: ", General.exnMessage e])
         ; OS.Process.success
      end

   fun export () =
      SMLofNJ.exportFn
      ("cm2mlb", main)
end
Commit	Line	Data
7f918cf1 CE	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