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/cm/tools/shell/tool.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/tools/shell/tool.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 756 - (view) (download)

1 : blume 756 (*
2 :     * A tool for running arbitrary shell commands from CM.
3 :     *
4 :     * (C) 2000 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     structure ShellTool = struct
9 :     local
10 :     open Tools
11 :    
12 :     val tool = "Shell-Command"
13 :     val class = "shell"
14 :     val kw_class = "class"
15 :     val kw_options = "options"
16 :     val kw_source = "source"
17 :     val kw_target = "target"
18 :     val kwl = [kw_class, kw_options, kw_source, kw_target]
19 :    
20 :     fun err msg = raise ToolError { tool = tool, msg = msg }
21 :     fun badspec kw = err (concat ["bad specification for keyword `",
22 :     kw, "'"])
23 :    
24 :     fun rule { spec, context, native2pathmaker, defaultClassOf } = let
25 :     val { name = str, mkpath, opts = too, derived, ... } : spec = spec
26 :     val specpath = srcpath (mkpath ())
27 :     val specname = nativeSpec specpath
28 :     val (sname, tname, tclass, topts, cmdline) =
29 :     case too of
30 :     NONE => err "missing options"
31 :     | SOME ol => let
32 :     val { matches, restoptions } =
33 :     parseOptions
34 :     { tool = tool, keywords = kwl, options = ol }
35 :     fun fmatch kw =
36 :     case matches kw of
37 :     NONE => NONE
38 :     | SOME [STRING { name, mkpath }] =>
39 :     SOME (nativeSpec (srcpath (mkpath ())))
40 :     | _ => badspec kw
41 :     val tclass =
42 :     case matches kw_class of
43 :     NONE => NONE
44 :     | SOME [STRING { name, ... }] => SOME name
45 :     | _ => badspec kw_class
46 :     val topts = matches kw_options
47 :     fun return (sname, tname) = let
48 :     fun subst "%s" = sname
49 :     | subst "%t" = tname
50 :     | subst "" = ""
51 :     | subst s = if String.sub (s, 0) <> #"%" then s
52 :     else String.extract (s, 1, NONE)
53 :     fun ad (x, l) = " " :: subst x :: l
54 :     val cmdline =
55 :     case restoptions of
56 :     [] => err "no command line specified"
57 :     | h :: t => concat (subst h :: foldr ad [] t)
58 :     in
59 :     (sname, tname, tclass, topts, cmdline)
60 :     end
61 :     in
62 :     case (fmatch kw_source, fmatch kw_target) of
63 :     (NONE, NONE) => err
64 :     "either `source=' or `target=' must be specified"
65 :     | (SOME src, NONE) => return (src, specname)
66 :     | (NONE, SOME tgt) => return (specname, tgt)
67 :     | (SOME _, SOME _) => err
68 :     "only one of `source=' and `target=' can be specified"
69 :     end
70 :     val spath = srcpath (native2pathmaker sname ())
71 :     val partial_expansion =
72 :     ({ smlfiles = [], cmfiles = [],
73 :     (* If str was the target, then "derived" does not really
74 :     * make much sense. I guess the best thing is to get
75 :     * rid of the "source:" option. FIXME!! *)
76 :     sources = [(spath, { class = class, derived = derived })] },
77 :     [{ name = tname, mkpath = native2pathmaker tname,
78 :     class = tclass, opts = topts, derived = true }])
79 :     fun runcmd () =
80 :     (vsay ["[", cmdline, "]\n"];
81 :     if OS.Process.system cmdline = OS.Process.success then ()
82 :     else err cmdline)
83 :     fun rulefn () =
84 :     (if outdated tool ([tname], sname) then runcmd ()
85 :     else ();
86 :     partial_expansion)
87 :     in
88 :     context rulefn
89 :     end
90 :     in
91 :     val _ = Tools.registerClass (class, rule)
92 :     end
93 :     end

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