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 873 - (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 873 fun rule { spec, context, native2pathmaker, defaultClassOf, sysinfo } = 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 : blume 873 val cmd =
54 :     Subst.substitute
55 :     [{ prefix = "%",
56 :     substitutions = [Subst.subfor "%c" cmdname,
57 :     Subst.subfor "%s" nativename,
58 :     Subst.subfor "%%" "%",
59 :     Subst.subnsel (1, #"o", fn x => x, " ") sol,
60 :     Subst.subnsel (1, #"t", #1, " ") tfiles] }]
61 :     template
62 : blume 742 in
63 :     Say.vsay ["[", cmd, "]\n"];
64 :     if OS.Process.system cmd = OS.Process.success then ()
65 :     else err cmd
66 :     end
67 :     fun rulefn () =
68 :     (if outdated tool (map #1 tfiles, nativename) then runcmd ()
69 :     else ();
70 :     partial_expansion)
71 :     in
72 :     context rulefn
73 :     end
74 :     fun sfx s =
75 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
76 :     in
77 :     registerClass (class, rule);
78 :     app sfx suffixes
79 :     end
80 :    
81 :     local
82 :     val toolclass = "tool"
83 :     val suffixclass = "suffix"
84 :     val empty_expansion =
85 :     ({ cmfiles = [], smlfiles = [], sources = [] }, [])
86 : blume 873 fun toolrule { spec, context, native2pathmaker, defaultClassOf, sysinfo } =
87 : blume 756 let val { name, mkpath, opts, ... } : spec = spec
88 :     fun err m = raise ToolError { tool = toolclass, msg = m }
89 :     val p = srcpath (mkpath ())
90 :     in
91 :     case opts of
92 :     NONE => if withPlugin p (fn () => load_plugin' p) then
93 :     empty_expansion
94 :     else err "tool registration failed"
95 :     | SOME _ => err "no tool options are recognized"
96 :     end
97 : blume 873 fun suffixrule { spec, context, native2pathmaker, defaultClassOf, sysinfo } =
98 : blume 756 let val { name = s, opts, ... } : spec = spec
99 :     fun err m = raise ToolError { tool = suffixclass, msg = m }
100 :     fun reg c =
101 :     (registerClassifier (stdSfxClassifier { sfx = s,
102 :     class = c });
103 :     empty_expansion)
104 :     in
105 :     case opts of
106 :     SOME [STRING c] => reg (#name c)
107 :     | SOME [SUBOPTS { name = "class", opts = [STRING c] }] =>
108 :     reg (#name c)
109 :     | _ => err "invalid options"
110 :     end
111 : blume 742 in
112 :     val _ = registerClass (toolclass, toolrule)
113 :     val _ = registerClass (suffixclass, suffixrule)
114 :     end
115 :     end

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