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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 975, Wed Oct 31 20:22:44 2001 UTC revision 1036, Fri Jan 25 22:05:44 2002 UTC
# Line 8  Line 8 
8  structure Main = struct  structure Main = struct
9    local    local
10    
11        structure RE =
12            RegExpFn (structure P = AwkSyntax
13                      structure E = DfaEngine)
14    
15      fun tgt (n, sz, sh, cc) =      fun tgt (n, sz, sh, cc) =
16          { name  = n, sizes = sz, shift = sh, stdcall = cc }          { name  = n, sizes = sz, shift = sh, stdcall = cc }
17    
# Line 31  Line 35 
35            | NONE => raise Fail (concat ["unknown target: " ^ tg])            | NONE => raise Fail (concat ["unknown target: " ^ tg])
36    
37      fun main0 (arg0, args) = let      fun main0 (arg0, args) = let
38          fun substitute (tmpl, s, t) = let          fun substitute (tmpl, opts, s, t) = let
39              fun loop ([], a) = String.implode (rev a)              fun loop ([], a) = String.implode (rev a)
40                | loop (#"%" :: #"s" :: l, a) = loop (l, push (s, a))                | loop (#"%" :: #"s" :: l, a) = loop (l, push (s, a))
41                | loop (#"%" :: #"t" :: l, a) = loop (l, push (t, a))                | loop (#"%" :: #"t" :: l, a) = loop (l, push (t, a))
42                  | loop (#"%" :: #"o" :: l, a) = loop (l, push (opts, a))
43                | loop (c :: l, a) = loop (l, c :: a)                | loop (c :: l, a) = loop (l, c :: a)
44              and push (x, a) = List.revAppend (String.explode x, a)              and push (x, a) = List.revAppend (String.explode x, a)
45          in          in
46              loop (String.explode tmpl, [])              loop (String.explode tmpl, [])
47          end          end
         fun mangle f = let  
             fun dot #"." = true  
               | dot _ = false  
             fun sep #"_" = true  
               | sep #"-" = true  
               | sep _ = false  
             fun finish l = let  
                 val fields = List.concat (map (String.fields sep) l)  
                 fun allUp x = String.map Char.toUpper x  
                 fun firstUp x =  
                     case String.explode x of  
                         h :: t => String.implode  
                                       (Char.toUpper h :: map Char.toLower t)  
                       | [] => ""  
                 val sigfields = map allUp fields  
                 val strfields = map firstUp fields  
                 val sgn =  
                     case sigfields of  
                         [] => raise Fail ("file name without significant \  
                                           \characters: " ^ f)  
                       | h :: t => String.concat (h ::  
                                                  foldr (fn (x, l) =>  
                                                            "_" :: x :: l)  
                                                        [] t)  
                 val stn = String.concat strfields  
             in  
                 (sgn, stn)  
             end  
         in  
             case rev (String.fields dot f) of  
                 ("c" | "h") :: (l as (_ :: _)) => finish (rev l)  
               | l => finish (rev l)  
         end  
48    
49          val sgf = ref NONE          val dir = ref "NLFFI-Generated"
50          val stf = ref NONE          val cmf = ref "nlffi-generated.cm"
51          val cmf = ref NONE          val prefix = ref ""
52          val sgn = ref NONE          val ems = ref []
53          val stn = ref NONE          val libh = ref "Library.libh"
54            val cmpl = ref true
55          val asu = ref false          val asu = ref false
56          val wid = ref NONE          val wid = ref NONE
57          val lsp = ref NONE          val lsp = ref NONE
58          val target = ref default_target          val target = ref default_target
59          val wrq = ref NONE          val wrq = ref NONE
60            val namedargs = ref false
61          fun proc [hfile] =          val cppopts = ref ""
62              let val ifile = OS.FileSys.tmpName ()          val regexp = ref NONE
63    
64            fun finish cfiles = let
65                fun mkidlsource cfile = let
66                    val ifile = OS.FileSys.tmpName ()
67                  val cpp_tmpl = getOpt (OS.Process.getEnv "FFIGEN_CPP",                  val cpp_tmpl = getOpt (OS.Process.getEnv "FFIGEN_CPP",
68                                         "gcc -E -U__GNUC__ %s > %t")                                         "gcc -E -U__GNUC__ %o %s > %t")
69                  val cpp = substitute (cpp_tmpl, hfile, ifile)                  val cpp = substitute (cpp_tmpl, !cppopts, cfile, ifile)
70                  val hfile_file = OS.Path.file hfile              in
71                  val sgf = getOpt (!sgf, hfile_file ^ ".sig")                  if OS.Process.system cpp <> OS.Process.success then
                 val stf = getOpt (!stf, hfile_file ^ ".sml")  
                 val cmf = getOpt (!cmf, hfile_file ^ ".cm")  
                 val (g_sgn, g_stn) = mangle hfile_file  
                 val sgn = getOpt (!sgn, g_sgn)  
                 val stn = getOpt (!stn, g_stn)  
                 val _ = if OS.Process.system cpp <> OS.Process.success then  
72                              raise Fail ("C-preprocessor failed: " ^ cpp)                              raise Fail ("C-preprocessor failed: " ^ cpp)
73                          else ()                  else ();
74                    ifile
75                end
76    
77                val match =
78                    case !regexp of
79                        NONE => (fn _ => false)
80                      | SOME re =>
81                        (fn s => let fun creader p =
82                                         if p >= size s then NONE
83                                         else SOME (String.sub (s, p), p + 1)
84              in              in
85                  Gen.gen { idlfile = hfile,                                   isSome (StringCvt.scanString (RE.prefix re) s)
86                            idlsource = ifile,                               end)
87                            sigfile = sgf,          in
88                            strfile = stf,              Gen.gen { cfiles = cfiles,
89                            cmfile = cmf,                        match = match,
90                            signame = sgn,                        mkidlsource = mkidlsource,
91                            strname = stn,                        dirname = !dir,
92                          cmfile = !cmf,
93                          prefix = !prefix,
94                          extramembers = !ems,
95                          libraryhandle = !libh,
96                          complete = !cmpl,
97                            allSU = !asu,                            allSU = !asu,
98                            lambdasplit = !lsp,                            lambdasplit = !lsp,
99                            weightreq = !wrq,                            weightreq = !wrq,
100                            wid = getOpt (!wid, 75),                            wid = getOpt (!wid, 75),
101                            target = !target }                        namedargs = !namedargs,
102                  handle e => (OS.FileSys.remove ifile handle _ => (); raise e);                        target = !target };
                 OS.FileSys.remove ifile handle _ => ();  
103                  OS.Process.success                  OS.Process.success
104              end              end
105            | proc ("-sigfile" :: f :: l) = (sgf := SOME f; proc l)  
106            | proc ("-strfile" :: f :: l) = (stf := SOME f; proc l)          fun iscppopt opt =
107            | proc ("-cmfile" :: f :: l) = (cmf := SOME f; proc l)              size opt < 2 andalso
108            | proc ("-signame" :: n :: l) = (sgn := SOME n; proc l)              String.sub (opt, 0) = #"-" andalso
109            | proc ("-strname" :: n :: l) = (stn := SOME n; proc l)              Char.contains "IDU" (String.sub (opt, 1))
110            | proc ("-allSU" :: l) = (asu := true; proc l)  
111            fun addcppopt opt =
112                cppopts := (case !cppopts of
113                                "" => opt
114                              | opts => concat [opts, " ", opt])
115    
116            fun proc ("-allSU" :: l) = (asu := true; proc l)
117            | proc ("-width" :: i :: l) = (wid := Int.fromString i; proc l)            | proc ("-width" :: i :: l) = (wid := Int.fromString i; proc l)
118            | proc ("-lambdasplit" :: s :: l) = (lsp := SOME s; proc l)            | proc ("-lambdasplit" :: s :: l) = (lsp := SOME s; proc l)
119            | proc ("-target" :: tg :: l) = (target := find_target tg; proc l)            | proc ("-target" :: tg :: l) = (target := find_target tg; proc l)
120            | proc ("-light" :: l) = (wrq := SOME false; proc l)            | proc ("-light" :: l) = (wrq := SOME false; proc l)
121            | proc ("-heavy" :: l) = (wrq := SOME true; proc l)            | proc ("-heavy" :: l) = (wrq := SOME true; proc l)
122            | proc _ =            | proc ("-namedargs" :: l) = (namedargs := true; proc l)
123              raise Fail            | proc ("-incomplete" :: l) = (cmpl := false; proc l)
124               (concat ["usage: ", arg0,            | proc ("-libhandle" :: lh :: l) = (libh := lh; proc l)
125              " \\\n\t[-sigfile sigfile] [-strfile strfile] [-cmfile cmfile] \            | proc ("-include" :: es :: l) = (ems := es :: !ems; proc l)
126              \ \\\n\t[-signame signame] [-strname strname] [-allSU] \            | proc ("-prefix" :: p :: l) = (prefix := p; proc l)
127              \ \\\n\t[-width linewidth] [-lambdasplit spec] [-target arch-os] \            | proc ("-dir" :: d :: l) = (dir := d; proc l)
128              \ \\\n    idlfile"])            | proc ("-cmfile" :: f :: l) = (cmf := f; proc l)
129              | proc ("-cppopt" :: opt :: l) = (addcppopt opt; proc l)
130              | proc ("-version" :: _) =
131                (TextIO.output (TextIO.stdOut, Gen.version ^ "\n");
132                 OS.Process.exit OS.Process.success)
133              | proc ("-match" :: re :: l) =
134                (regexp := SOME (RE.compileString re); proc l)
135              | proc ("--" :: cfiles) = finish cfiles
136              | proc (l0 as (opt :: l)) =
137                if iscppopt opt then (addcppopt opt; proc l) else finish l0
138              | proc cfiles = finish cfiles
139      in      in
140          proc args          proc args
141      end      end

Legend:
Removed from v.975  
changed lines
  Added in v.1036

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