Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-nlffigen/main.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffigen/main.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 828 - (view) (download)

1 : blume 828 (*
2 :     * main.sml - Driver routine ("main") for ml-ffigen.
3 :     *
4 :     * (C) 2001, Lucent Technologies, Bell Labs
5 :     *
6 :     * author: Matthias Blume (blume@research.bell-labs.com)
7 :     *)
8 :     structure Main = struct
9 :     local
10 :     fun main0 (arg0, args) = let
11 :     fun substitute (tmpl, s, t) = let
12 :     fun loop ([], a) = String.implode (rev a)
13 :     | loop (#"%" :: #"s" :: l, a) = loop (l, push (s, a))
14 :     | loop (#"%" :: #"t" :: l, a) = loop (l, push (t, a))
15 :     | loop (c :: l, a) = loop (l, c :: a)
16 :     and push (x, a) = List.revAppend (String.explode x, a)
17 :     in
18 :     loop (String.explode tmpl, [])
19 :     end
20 :     fun mangle f = let
21 :     fun dot #"." = true
22 :     | dot _ = false
23 :     fun sep #"_" = true
24 :     | sep #"-" = true
25 :     | sep _ = false
26 :     fun finish l = let
27 :     val fields = List.concat (map (String.fields sep) l)
28 :     fun allUp x = String.map Char.toUpper x
29 :     fun firstUp x =
30 :     case String.explode x of
31 :     h :: t => String.implode
32 :     (Char.toUpper h :: map Char.toLower t)
33 :     | [] => ""
34 :     val sigfields = map allUp fields
35 :     val strfields = map firstUp fields
36 :     val sgn =
37 :     case sigfields of
38 :     [] => raise Fail ("file name without significant \
39 :     \characters: " ^ f)
40 :     | h :: t => String.concat (h ::
41 :     foldr (fn (x, l) =>
42 :     "_" :: x :: l)
43 :     [] t)
44 :     val stn = String.concat strfields
45 :     in
46 :     (sgn, stn)
47 :     end
48 :     in
49 :     case rev (String.fields dot f) of
50 :     ("c" | "h") :: (l as (_ :: _)) => finish (rev l)
51 :     | l => finish (rev l)
52 :     end
53 :     fun proc ([hfile],
54 :     sgf, stf, cmf, sgn, stn, asu, wid, lsp) =
55 :     let val ifile = OS.FileSys.tmpName ()
56 :     val cpp_tmpl = getOpt (OS.Process.getEnv "FFIGEN_CPP",
57 :     "gcc -E -U__GNUC__ %s > %t")
58 :     val cpp = substitute (cpp_tmpl, hfile, ifile)
59 :     val sgf = getOpt (sgf, hfile ^ ".sig")
60 :     val stf = getOpt (stf, hfile ^ ".sml")
61 :     val cmf = getOpt (cmf, hfile ^ ".cm")
62 :     val (g_sgn, g_stn) = mangle hfile
63 :     val sgn = getOpt (sgn, g_sgn)
64 :     val stn = getOpt (stn, g_stn)
65 :     val _ = if OS.Process.system cpp <> OS.Process.success then
66 :     raise Fail ("C-preprocessor failed: " ^ cpp)
67 :     else ()
68 :     in
69 :     Gen.gen { idlfile = hfile,
70 :     idlsource = ifile,
71 :     sigfile = sgf,
72 :     strfile = stf,
73 :     cmfile = cmf,
74 :     signame = sgn,
75 :     strname = stn,
76 :     allSU = asu,
77 :     lambdasplit = lsp,
78 :     wid = getOpt (wid, 75) }
79 :     handle e => (OS.FileSys.remove ifile handle _ => (); raise e);
80 :     OS.FileSys.remove ifile handle _ => ();
81 :     OS.Process.success
82 :     end
83 :     | proc ("-sigfile" :: f :: l, _, stf, cmf, sgn, stn, asu, wid, lsp) =
84 :     proc (l, SOME f, stf, cmf, sgn, stn, asu, wid, lsp)
85 :     | proc ("-strfile" :: f :: l, sgf, _, cmf, sgn, stn, asu, wid, lsp) =
86 :     proc (l, sgf, SOME f, cmf, sgn, stn, asu, wid, lsp)
87 :     | proc ("-cmfile" :: f :: l, sgf, stf, _, sgn, stn, asu, wid, lsp) =
88 :     proc (l, sgf, stf, SOME f, sgn, stn, asu, wid, lsp)
89 :     | proc ("-signame" :: n :: l, sgf, stf, cmf, _, stn, asu, wid, lsp) =
90 :     proc (l, sgf, stf, cmf, SOME n, stn, asu, wid, lsp)
91 :     | proc ("-strname" :: n :: l, sgf, stf, cmf, sgn, _, asu, wid, lsp) =
92 :     proc (l, sgf, stf, cmf, sgn, SOME n, asu, wid, lsp)
93 :     | proc ("-allSU" :: l, sgf, stf, cmf, sgn, stn, _, wid, lsp) =
94 :     proc (l, sgf, stf, cmf, sgn, stn, true, wid, lsp)
95 :     | proc ("-width" :: i :: l, sgf, stf, cmf, sgn, stn, asu, _, lsp) =
96 :     proc (l, sgf, stf, cmf, sgn, stn, asu, Int.fromString i, lsp)
97 :     | proc ("-lambdasplit" :: s :: l,
98 :     sgf, stf, cmf, sgn, stn, asu, wid, _) =
99 :     proc (l, sgf, stf, cmf, sgn, stn, asu, wid, SOME s)
100 :     | proc _ =
101 :     raise Fail
102 :     (concat ["usage: ", arg0,
103 :     " \\\n\t[-sigfile sigfile] [-strfile strfile] [-cmfile cmfile] \
104 :     \ \\\n\t[-signame signame] [-strname strname] [-allSU] \
105 :     \ \\\n\t[-width linewidth] [-lambdasplit spec] \
106 :     \ \\\n idlfile"])
107 :     in
108 :     proc (args, NONE, NONE, NONE, NONE, NONE, false, NONE, NONE)
109 :     end
110 :     in
111 :     fun main args = main0 args
112 :     handle exn => (TextIO.output (TextIO.stdErr, General.exnMessage exn);
113 :     TextIO.output (TextIO.stdErr, "\n");
114 :     OS.Process.failure)
115 :     end
116 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0