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/main/tools-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/tools/main/tools-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 756 - (view) (download)

1 : blume 742 (*
2 :     * Functor implementing the public interface to CM's tools mechanism.
3 :     * (This functor must be instantiated after the rest of CM is
4 : blume 756 * already in place because it uses load_plugin.)
5 : blume 742 *
6 :     * (C) 2000 Lucent Technologies, Bell Laboratories
7 :     *
8 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
9 :     *)
10 : blume 756 functor ToolsFn (val load_plugin' : SrcPath.file -> bool
11 : blume 742 val penv: SrcPath.env) : TOOLS = struct
12 :    
13 :     open PrivateTools
14 :    
15 :     val say = Say.say
16 :     val vsay = Say.vsay
17 :    
18 :     fun mkCmdName cmdStdPath =
19 :     (* The result of this function should not be cached. Otherwise
20 :     * a later addition or change of an anchor will go unnoticed. *)
21 :     case SrcPath.get_anchor (penv, cmdStdPath) of
22 :     NONE => cmdStdPath
23 :     | SOME p => OS.Path.joinDirFile { dir = p, file = cmdStdPath }
24 :    
25 :     fun registerStdShellCmdTool args = let
26 :     val { tool, class, suffixes, cmdStdPath,
27 :     extensionStyle, template, dflopts } = args
28 :     val template = getOpt (template, "%c %s")
29 :     fun err m = raise ToolError { tool = tool, msg = m }
30 : blume 756 fun rule { spec, context, native2pathmaker, defaultClassOf } = let
31 : blume 742 val { name, mkpath, opts = oto, derived, ... } : spec = spec
32 :     val opts = getOpt (oto, dflopts)
33 :     val sol = let (* only use STRING options for %o *)
34 :     fun so (SUBOPTS _) = NONE
35 : blume 756 | so (STRING s) = SOME (nativeSpec (srcpath (#mkpath s ())))
36 : blume 742 in
37 :     List.mapPartial so opts
38 :     end
39 : blume 756 val p = srcpath (mkpath ())
40 : blume 742 val nativename = nativeSpec p
41 :     val tfiles = extend extensionStyle (nativename, oto)
42 :     val partial_expansion =
43 :     ({ smlfiles = [], cmfiles = [],
44 :     sources = [(p, { class = class, derived = derived })] },
45 :     map (fn (f, co, too) => { name = f,
46 : blume 756 mkpath = native2pathmaker f,
47 : blume 742 class = co,
48 :     opts = too,
49 :     derived = true })
50 :     tfiles)
51 :     fun runcmd () = let
52 :     val cmdname = mkCmdName cmdStdPath
53 :     fun fill ([], sl) = concat (rev sl)
54 :     | fill (#"%" :: #"%" :: t, sl) = fill (t, "%" :: sl)
55 :     | fill (#"%" :: #"c" :: t, sl) = fill (t, cmdname :: sl)
56 :     | fill (#"%" :: #"s" :: t, sl) = fill (t, nativename :: sl)
57 :     | fill (#"%" :: t, sl0) = let
58 :     val o0 = Char.ord #"0"
59 :     fun select (0, cl, sl, ol, sel) =
60 :     fill (cl, foldl (fn (x, l) => sel x :: " " :: l)
61 :     sl0 ol)
62 :     | select (n, cl, sl, ol, sel) =
63 :     (fill (cl, sel (List.nth (ol, n-1)) :: sl0)
64 :     handle General.Subscript => fill (cl, sl))
65 :     fun loop (n, [], sl) = fill ([], sl)
66 :     | loop (n, t as (c :: t'), sl) =
67 :     if c >= #"0" andalso c <= #"9" then
68 :     loop (n * 10 + Char.ord c - o0,
69 :     t', String.str c :: sl)
70 :     else let
71 :     val sl = String.str c :: sl
72 :     in
73 :     case c of
74 :     #"o" => select (n, t', sl, sol, fn x => x)
75 :     | #"t" => select (n, t', sl, tfiles, #1)
76 :     | _ => fill (t', sl)
77 :     end
78 :     in
79 :     loop (0, t, "%" :: sl0)
80 :     end
81 :     | fill (c :: t, sl) = fill (t, String.str c :: sl)
82 :     val cmd = fill (String.explode template, [])
83 :     in
84 :     Say.vsay ["[", cmd, "]\n"];
85 :     if OS.Process.system cmd = OS.Process.success then ()
86 :     else err cmd
87 :     end
88 :     fun rulefn () =
89 :     (if outdated tool (map #1 tfiles, nativename) then runcmd ()
90 :     else ();
91 :     partial_expansion)
92 :     in
93 :     context rulefn
94 :     end
95 :     fun sfx s =
96 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
97 :     in
98 :     registerClass (class, rule);
99 :     app sfx suffixes
100 :     end
101 :    
102 :     local
103 :     val toolclass = "tool"
104 :     val suffixclass = "suffix"
105 :     val empty_expansion =
106 :     ({ cmfiles = [], smlfiles = [], sources = [] }, [])
107 : blume 756 fun toolrule { spec, context, native2pathmaker, defaultClassOf } =
108 :     let val { name, mkpath, opts, ... } : spec = spec
109 :     fun err m = raise ToolError { tool = toolclass, msg = m }
110 :     val p = srcpath (mkpath ())
111 :     in
112 :     case opts of
113 :     NONE => if withPlugin p (fn () => load_plugin' p) then
114 :     empty_expansion
115 :     else err "tool registration failed"
116 :     | SOME _ => err "no tool options are recognized"
117 :     end
118 :     fun suffixrule { spec, context, native2pathmaker, defaultClassOf } =
119 :     let val { name = s, opts, ... } : spec = spec
120 :     fun err m = raise ToolError { tool = suffixclass, msg = m }
121 :     fun reg c =
122 :     (registerClassifier (stdSfxClassifier { sfx = s,
123 :     class = c });
124 :     empty_expansion)
125 :     in
126 :     case opts of
127 :     SOME [STRING c] => reg (#name c)
128 :     | SOME [SUBOPTS { name = "class", opts = [STRING c] }] =>
129 :     reg (#name c)
130 :     | _ => err "invalid options"
131 :     end
132 : blume 742 in
133 :     val _ = registerClass (toolclass, toolrule)
134 :     val _ = registerClass (suffixclass, suffixrule)
135 :     end
136 :     end

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