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 977, Wed Nov 14 16:53:16 2001 UTC revision 1011, Thu Jan 10 20:22:04 2002 UTC
# Line 40  Line 40 
40          in          in
41              loop (String.explode tmpl, [])              loop (String.explode tmpl, [])
42          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  
43    
44          val sgf = ref NONE          val dir = ref "NLFFI-Generated"
45          val stf = ref NONE          val cmf = ref "nlffi-generated.cm"
46          val cmf = ref NONE          val prefix = ref ""
47          val sgn = ref NONE          val ems = ref []
48          val stn = ref NONE          val libh = ref "Library.libh"
49            val cmpl = ref true
50          val asu = ref false          val asu = ref false
51          val wid = ref NONE          val wid = ref NONE
52          val lsp = ref NONE          val lsp = ref NONE
# Line 86  Line 54 
54          val wrq = ref NONE          val wrq = ref NONE
55          val namedargs = ref false          val namedargs = ref false
56    
57          fun proc [hfile] =          fun finish cfiles = let
58              let val ifile = OS.FileSys.tmpName ()              fun mkidlsource cfile = let
59                    val ifile = OS.FileSys.tmpName ()
60                  val cpp_tmpl = getOpt (OS.Process.getEnv "FFIGEN_CPP",                  val cpp_tmpl = getOpt (OS.Process.getEnv "FFIGEN_CPP",
61                                         "gcc -E -U__GNUC__ %s > %t")                                         "gcc -E -U__GNUC__ %s > %t")
62                  val cpp = substitute (cpp_tmpl, hfile, ifile)                  val cpp = substitute (cpp_tmpl, cfile, ifile)
63                  val hfile_file = OS.Path.file hfile              in
64                  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  
65                              raise Fail ("C-preprocessor failed: " ^ cpp)                              raise Fail ("C-preprocessor failed: " ^ cpp)
66                          else ()                  else ();
67                    ifile
68                end
69              in              in
70                  Gen.gen { idlfile = hfile,              Gen.gen { cfiles = cfiles,
71                            idlsource = ifile,                        mkidlsource = mkidlsource,
72                            sigfile = sgf,                        dirname = !dir,
73                            strfile = stf,                        cmfile = !cmf,
74                            cmfile = cmf,                        prefix = !prefix,
75                            signame = sgn,                        extramembers = !ems,
76                            strname = stn,                        libraryhandle = !libh,
77                          complete = !cmpl,
78                            allSU = !asu,                            allSU = !asu,
79                            lambdasplit = !lsp,                            lambdasplit = !lsp,
80                            weightreq = !wrq,                            weightreq = !wrq,
81                            wid = getOpt (!wid, 75),                            wid = getOpt (!wid, 75),
82                            namedargs = !namedargs,                            namedargs = !namedargs,
83                            target = !target }                        target = !target };
                 handle e => (OS.FileSys.remove ifile handle _ => (); raise e);  
                 OS.FileSys.remove ifile handle _ => ();  
84                  OS.Process.success                  OS.Process.success
85              end              end
86            | proc ("-sigfile" :: f :: l) = (sgf := SOME f; proc l)  
87            | proc ("-strfile" :: f :: l) = (stf := SOME f; proc l)          fun proc ("-allSU" :: l) = (asu := true; proc l)
           | proc ("-cmfile" :: f :: l) = (cmf := SOME f; proc l)  
           | proc ("-signame" :: n :: l) = (sgn := SOME n; proc l)  
           | proc ("-strname" :: n :: l) = (stn := SOME n; proc l)  
           | proc ("-allSU" :: l) = (asu := true; proc l)  
88            | proc ("-width" :: i :: l) = (wid := Int.fromString i; proc l)            | proc ("-width" :: i :: l) = (wid := Int.fromString i; proc l)
89            | proc ("-lambdasplit" :: s :: l) = (lsp := SOME s; proc l)            | proc ("-lambdasplit" :: s :: l) = (lsp := SOME s; proc l)
90            | proc ("-target" :: tg :: l) = (target := find_target tg; proc l)            | proc ("-target" :: tg :: l) = (target := find_target tg; proc l)
91            | proc ("-light" :: l) = (wrq := SOME false; proc l)            | proc ("-light" :: l) = (wrq := SOME false; proc l)
92            | proc ("-heavy" :: l) = (wrq := SOME true; proc l)            | proc ("-heavy" :: l) = (wrq := SOME true; proc l)
93            | proc ("-namedargs" :: l) = (namedargs := true; proc l)            | proc ("-namedargs" :: l) = (namedargs := true; proc l)
94            | proc _ =            | proc ("-incomplete" :: l) = (cmpl := false; proc l)
95              raise Fail            | proc ("-libhandle" :: lh :: l) = (libh := lh; proc l)
96               (concat ["usage: ", arg0,            | proc ("-include" :: es :: l) = (ems := es :: !ems; proc l)
97              " \\\n\t[-sigfile sigfile] [-strfile strfile] [-cmfile cmfile] \            | proc ("-prefix" :: p :: l) = (prefix := p; proc l)
98              \ \\\n\t[-signame signame] [-strname strname] [-allSU] \            | proc ("-dir" :: d :: l) = (dir := d; proc l)
99              \ \\\n\t[-width linewidth] [-lambdasplit spec] [-target arch-os] \            | proc ("-cmfile" :: f :: l) = (cmf := f; proc l)
100              \ \\\n    idlfile"])            | proc ("--" :: cfiles) = finish cfiles
101              | proc cfiles = finish cfiles
102      in      in
103          proc args          proc args
104      end      end

Legend:
Removed from v.977  
changed lines
  Added in v.1011

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