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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1137 - (view) (download)

1 : blume 742 (*
2 :     * This is the implementation of the private interface to CM's tools
3 :     * mechanism. It lacks certain public features implemented by ToolsFn
4 :     * but provides other, non-public routines such as "expand".
5 :     *
6 :     * (C) 2000 Lucent Technologies, Bell Laboratories
7 :     *
8 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
9 :     *)
10 :     structure PrivateTools : PRIVATETOOLS = struct
11 :    
12 :     type class = string
13 :    
14 :     type srcpath = SrcPath.file
15 :     type presrcpath = SrcPath.prefile
16 :     type rebindings = SrcPath.rebindings
17 :    
18 :     val nativeSpec = SrcPath.osstring_relative
19 : blume 756 val nativePreSpec = SrcPath.osstring_prefile_relative
20 : blume 742
21 :     val srcpath = SrcPath.file
22 :    
23 : blume 756 val augment = SrcPath.extend
24 :    
25 : blume 742 exception ToolError of { tool: string, msg: string }
26 :    
27 : blume 756 type pathmaker = unit -> presrcpath
28 : blume 742
29 : blume 756 type fnspec = { name: string, mkpath: pathmaker }
30 :    
31 : blume 742 datatype toolopt =
32 : blume 756 STRING of fnspec
33 : blume 742 | SUBOPTS of { name: string, opts: toolopts }
34 :     withtype toolopts = toolopt list
35 :    
36 :     type tooloptcvt = toolopts option -> toolopts option
37 :    
38 :     type spec = { name: string,
39 :     mkpath: pathmaker,
40 :     class: class option,
41 :     opts: toolopts option,
42 :     derived: bool }
43 :    
44 :     type setup = string option * string option
45 :    
46 : blume 818 type splitting = int option option
47 :    
48 : blume 986 type smlparams =
49 :     { share: Sharing.request,
50 :     setup: setup,
51 :     split: splitting,
52 : blume 1137 noguid: bool,
53 : blume 986 locl: bool }
54 :    
55 :     type cmparams =
56 :     { version: Version.t option,
57 :     rebindings: rebindings }
58 :    
59 : blume 742 type expansion =
60 : blume 986 { smlfiles: (srcpath * smlparams) list,
61 :     cmfiles: (srcpath * cmparams) list,
62 : blume 742 sources: (srcpath * { class: string, derived: bool}) list }
63 :    
64 :     type partial_expansion = expansion * spec list
65 :    
66 :     type rulefn = unit -> partial_expansion
67 :     type rulecontext = rulefn -> partial_expansion
68 : blume 756 type rule = { spec: spec,
69 :     native2pathmaker: string -> pathmaker,
70 :     context: rulecontext,
71 : blume 873 defaultClassOf: fnspec -> class option,
72 :     sysinfo: { symval: string -> int option,
73 :     archos: string } } ->
74 : blume 756 partial_expansion
75 : blume 742
76 : blume 756 type gcarg = { name: string, mkfname: unit -> string }
77 :    
78 : blume 742 type registry = { classes : rule StringMap.map ref,
79 :     sfx_classifiers : (string -> class option) ref,
80 : blume 756 gen_classifiers : (gcarg -> class option) ref }
81 : blume 742
82 :     fun layer (look1, look2) s = case look1 s of NONE => look2 s | x => x
83 :    
84 :     fun newRegistry () = { classes = ref StringMap.empty,
85 :     sfx_classifiers = ref (fn _ => NONE),
86 :     gen_classifiers = ref (fn _ => NONE) } : registry
87 :    
88 :     (* Three registries:
89 :     * 1. global: where globally available tools are registered and found.
90 :     * 2. local: where locally available tools are found;
91 :     * the local registry is being set anew every time "expand"
92 :     * is being called; each instance of a local registry belongs
93 :     * to one description file that is being processed.
94 :     * 3. plugin registries: mapping from tool implementations (indexed
95 :     * by their respective description files) to that tool's
96 :     * registry; here is where local tools register themselves;
97 :     * the rule for the "tool" class causes the tool to register
98 :     * itself if it has not already done so and then merges
99 :     * the contents of the tool's registry into the current
100 :     * local registry.
101 :     * These complications exist because tools register themselves via
102 :     * side-effects. *)
103 :    
104 :     val global_registry = newRegistry ()
105 :    
106 :     val local_registry : registry ref = ref (newRegistry ())
107 :    
108 :     val plugin_registries : registry SrcPathMap.map ref = ref SrcPathMap.empty
109 :    
110 :     val current_plugin : SrcPath.file option ref = ref NONE
111 :    
112 :     local
113 :     fun registry sel cvt s = let
114 :     val get = cvt o ! o sel
115 :     in
116 :     layer (get (!local_registry), get global_registry) s
117 :     end
118 :     fun curry f x y = f (x, y)
119 :     in
120 :     val classes = registry #classes (curry StringMap.find)
121 :     val sfx_classifiers = registry #sfx_classifiers (fn x => x)
122 :     val gen_classifiers = registry #gen_classifiers (fn x => x)
123 :     end
124 :    
125 :     datatype classifier =
126 :     SFX_CLASSIFIER of string -> class option
127 : blume 756 | GEN_CLASSIFIER of gcarg -> class option
128 : blume 742
129 :     fun stdSfxClassifier { sfx, class } =
130 :     SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
131 :    
132 :     local
133 :     fun upd sel augment = let
134 :     val rf =
135 :     sel (case !current_plugin of
136 :     NONE => global_registry
137 :     | SOME p =>
138 :     (case SrcPathMap.find (!plugin_registries, p) of
139 :     SOME r => r
140 :     | NONE => let
141 :     val r = newRegistry ()
142 :     in
143 :     plugin_registries :=
144 :     SrcPathMap.insert (!plugin_registries, p, r);
145 :     r
146 :     end))
147 :     in
148 :     rf := augment (!rf)
149 :     end
150 :     in
151 :     fun registerClass (class, rule) =
152 :     upd #classes (fn m => StringMap.insert (m, class, rule))
153 :     fun registerClassifier (SFX_CLASSIFIER c) =
154 :     upd #sfx_classifiers (fn c' => layer (c, c'))
155 :     | registerClassifier (GEN_CLASSIFIER c) =
156 :     upd #gen_classifiers (fn c' => layer (c, c'))
157 :    
158 :     fun transfer_local p = let
159 :     val lr = !local_registry
160 :     in
161 :     case SrcPathMap.find (!plugin_registries, p) of
162 :     NONE => ()
163 :     | SOME pr => let
164 :     fun upd sel join = sel lr := join (! (sel pr), ! (sel lr))
165 :     in
166 :     upd #classes (StringMap.unionWith #1);
167 :     upd #sfx_classifiers layer;
168 :     upd #gen_classifiers layer
169 :     end
170 :     end
171 :    
172 :     fun withPlugin p thunk =
173 :     SafeIO.perform { openIt = fn () => !current_plugin before
174 :     current_plugin := SOME p,
175 :     closeIt = fn prev => (transfer_local p;
176 :     current_plugin := prev),
177 :     work = fn _ => thunk (),
178 :     cleanup = fn _ => () }
179 :     end
180 :    
181 :     datatype extensionStyle =
182 :     EXTEND of (string * class option * tooloptcvt) list
183 :     | REPLACE of string list * (string * class option * tooloptcvt) list
184 :    
185 :     fun extend (EXTEND l) (f, too) =
186 :     map (fn (s, co, toc) => (concat [f, ".", s], co, toc too)) l
187 :     | extend (REPLACE (ol, nl)) (f, too) = let
188 :     val { base, ext } = OS.Path.splitBaseExt f
189 :     fun join b (e, co, toc) =
190 :     (OS.Path.joinBaseExt { base = b, ext = SOME e }, co, toc too)
191 :     fun gen b = map (join b) nl
192 :     fun sameExt (e1: string) (e2: string) = e1 = e2
193 :     in
194 :     case ext of
195 :     NONE => gen base
196 :     | SOME e =>
197 :     if List.exists (sameExt e) ol then gen base else gen f
198 :     end
199 :    
200 :     local
201 :     fun timex f =
202 :     (OS.FileSys.modTime f, true)
203 :     handle _ => (Time.zeroTime, false)
204 :     val op < = Time.<
205 :     fun olderThan t f = OS.FileSys.modTime f < t
206 :     fun cannotAccess tool f =
207 :     raise ToolError { tool = tool, msg = "cannot access " ^ f }
208 :     in
209 :     fun outdated tool (l, f) = let
210 :     val (ftime, fexists) = timex f
211 :     in
212 :     (List.exists (olderThan ftime) l)
213 :     handle _ => if fexists then true else cannotAccess tool f
214 :     end
215 :    
216 :     fun outdated' tool { src, wtn, tgt } = let
217 :     val (st, se) = timex src
218 :     val (tt, te) = timex tgt
219 :     in
220 :     if not se then
221 :     if te then false else cannotAccess tool src
222 :     else if te then
223 :     let val (wt, we) = timex wtn
224 :     in
225 :     if we then wt < st else tt < st
226 :     end
227 :     else true
228 :     end
229 :     end
230 :    
231 :     val openTextOut = AutoDir.openTextOut
232 :     val makeDirs = AutoDir.makeDirs
233 :    
234 :     fun globally lp arg =
235 :     SafeIO.perform { openIt = fn () => !current_plugin before
236 :     current_plugin := NONE,
237 :     closeIt = fn prev => current_plugin := prev,
238 :     work = fn _ => lp arg,
239 :     cleanup = fn _ => () }
240 :    
241 :     (* query default class *)
242 : blume 756 fun defaultClassOf load_plugin (s: fnspec) = let
243 :     val p = #name s
244 :     val mkfname = SrcPath.osstring_prefile o #mkpath s
245 :     val gcarg = { name = p, mkfname = mkfname }
246 : blume 742 fun sfx_gen_check e =
247 :     case sfx_classifiers e of
248 :     SOME c => SOME c
249 : blume 756 | NONE => gen_classifiers gcarg
250 : blume 742 in
251 :     case OS.Path.ext p of
252 :     SOME e =>
253 :     (case sfx_gen_check e of
254 :     SOME c => SOME c
255 :     | NONE => let
256 :     val plugin = concat ["$/", e, "-ext.cm"]
257 :     in
258 :     if globally load_plugin plugin then sfx_gen_check e
259 :     else NONE
260 :     end)
261 : blume 756 | NONE => gen_classifiers gcarg
262 : blume 742 end
263 :    
264 :     fun parseOptions { tool, keywords, options } = let
265 :     fun err m = raise ToolError { tool = tool, msg = m }
266 :     fun isKW kw = List.exists (fn kw' => kw = kw') keywords
267 :     fun loop ([], m, ro) = { matches = fn kw => StringMap.find (m, kw),
268 :     restoptions = rev ro }
269 :     | loop (STRING { name, ... } :: t, m, ro) = loop (t, m, name :: ro)
270 :     | loop (SUBOPTS { name, opts } :: t, m, ro) =
271 :     if not (isKW name) then
272 :     raise err (concat ["keyword option `", name,
273 :     "' not recognized"])
274 :     else (case StringMap.find (m, name) of
275 :     SOME _ => err (concat ["keyword option `", name,
276 :     "' specified more than once"])
277 :     | NONE => loop (t, StringMap.insert (m, name, opts), ro))
278 :     in
279 :     loop (options, StringMap.empty, [])
280 :     end
281 :    
282 : blume 1126 fun smlrule { spec, context, native2pathmaker, defaultClassOf, sysinfo } =
283 :     let val { name, mkpath, opts = oto, derived, ... } : spec = spec
284 : blume 742 val tool = "sml"
285 :     fun err s = raise ToolError { tool = tool, msg = s }
286 :     val kw_setup = "setup"
287 : blume 818 val kw_lambdasplit = "lambdasplit"
288 : blume 1137 val kw_noguid = "noguid"
289 : blume 818 val UseDefault = NONE
290 :     val Suggest = SOME
291 : blume 1137 val (srq, setup, splitting, noguid, locl) =
292 : blume 742 case oto of
293 : blume 1137 NONE => (Sharing.DONTCARE, (NONE, NONE), UseDefault,
294 :     false, false)
295 : blume 742 | SOME to => let
296 :     val { matches, restoptions } =
297 :     parseOptions { tool = tool,
298 : blume 818 keywords = [kw_setup, kw_lambdasplit],
299 : blume 742 options = to }
300 : blume 986 fun is_shspec "shared" = true
301 :     | is_shspec "private" = true
302 :     | is_shspec _ = false
303 :     val (sh_options, restoptions) =
304 :     List.partition is_shspec restoptions
305 : blume 742 val srq =
306 : blume 986 case sh_options of
307 : blume 742 [] => Sharing.DONTCARE
308 :     | ["shared"] => Sharing.SHARED
309 :     | ["private"] => Sharing.PRIVATE
310 :     | _ => err "invalid option(s)"
311 : blume 1137 fun isKW kw s = String.compare (kw, s) = EQUAL
312 :     val (locls, restoptions) =
313 :     List.partition (isKW "local") restoptions
314 :     val (noguids, restoptions) =
315 :     List.partition (isKW "noguid") restoptions
316 :     val locl = not (List.null locls)
317 :     val noguid = not (List.null noguids)
318 :     val _ = if List.null restoptions then ()
319 :     else err (concat
320 :     ("invalid option(s): " ::
321 :     foldr (fn (x, l) => " " :: x :: l)
322 :     [] restoptions))
323 : blume 742 val setup =
324 :     case matches kw_setup of
325 :     NONE => (NONE, NONE)
326 :     | SOME [] => (NONE, NONE)
327 :     | SOME [STRING s] => (SOME (#name s), NONE)
328 :     | SOME [SUBOPTS { name = "pre",
329 :     opts = [STRING pre] }] =>
330 :     (SOME (#name pre), NONE)
331 :     | SOME [SUBOPTS { name = "post",
332 :     opts = [STRING post] }] =>
333 :     (NONE, SOME (#name post))
334 :     | (SOME [SUBOPTS { name = "pre",
335 :     opts = [STRING pre] },
336 :     SUBOPTS { name = "post",
337 :     opts = [STRING post] }] |
338 :     SOME [SUBOPTS { name = "post",
339 :     opts = [STRING post] },
340 :     SUBOPTS { name = "pre",
341 :     opts = [STRING pre] }]) =>
342 :     (SOME (#name pre), SOME (#name post))
343 :     | _ => err "invalid setup spec"
344 : blume 818 val splitting = let
345 :     fun invalid () = err "invalid lambdasplit spec"
346 :     fun spec (s: fnspec) =
347 :     case #name s of
348 :     "default" => UseDefault
349 :     | "on" => Suggest (SOME 0)
350 :     | "off" => Suggest NONE
351 :     | "infinity" => Suggest (SOME 100000000)
352 :     | n =>
353 :     (case Int.fromString n of
354 :     SOME i => Suggest (SOME i)
355 :     | NONE => invalid ())
356 :     in
357 :     case matches kw_lambdasplit of
358 :     NONE => UseDefault
359 :     | SOME [] => Suggest (SOME 0)(* == "on" *)
360 :     | SOME [STRING x] => spec x
361 :     | _ => err "invalid lambdasplit spec"
362 :     end
363 : blume 742 in
364 : blume 1137 (srq, setup, splitting, noguid, locl)
365 : blume 742 end
366 : blume 756 val p = srcpath (mkpath ())
367 : blume 986 val sparam = { share = srq, setup = setup, split = splitting,
368 : blume 1137 noguid = noguid,
369 :     locl = locl }
370 : blume 742 in
371 : blume 986 ({ smlfiles = [(p, sparam)],
372 : blume 742 sources = [(p, { class = "sml", derived = derived })],
373 :     cmfiles = [] },
374 :     [])
375 :     end
376 : blume 873 fun cmrule { spec, context, native2pathmaker, defaultClassOf, sysinfo } = let
377 : blume 742 val { name, mkpath, opts = oto, derived, ... } : spec = spec
378 :     fun err m = raise ToolError { tool = "cm", msg = m }
379 :     fun proc_opts (rb, vrq, []) = (rb, vrq)
380 :     | proc_opts (_, _, STRING _ :: _) = err "ill-formed option"
381 :     | proc_opts (rb, vrq, SUBOPTS { name = "version", opts } :: r) =
382 :     let fun ill () = err "ill-formed version specification"
383 :     in
384 :     case (vrq, opts) of
385 :     (SOME _, _) =>
386 :     err "version cannot be specified more than once"
387 :     | (NONE, [STRING { name, ... }]) =>
388 :     (case Version.fromString name of
389 :     NONE => ill ()
390 :     | SOME v => proc_opts (rb, SOME v, r))
391 :     | _ => ill ()
392 :     end
393 :     | proc_opts (rb, vrq, SUBOPTS { name = "bind", opts } :: r) =
394 :     (case opts of
395 :     [SUBOPTS { name = "anchor", opts = [STRING { name, ... }] },
396 :     SUBOPTS { name = "value", opts = [STRING v] }] =>
397 : blume 756 proc_opts ({ anchor = name, value = #mkpath v () }
398 : blume 742 :: rb,
399 :     vrq, r)
400 :     | _ => err "ill-formed bind specification")
401 :     | proc_opts (_, _, SUBOPTS { name, ... } :: _) =
402 :     err ("unknown option: " ^ name)
403 :     val (rb, vrq) = case oto of
404 :     NONE => ([], NONE)
405 :     | SOME l => proc_opts ([], NONE, l)
406 : blume 756 val p = srcpath (mkpath ())
407 : blume 986 val cparams = { version = vrq, rebindings = rev rb }
408 : blume 742 in
409 :     ({ smlfiles = [],
410 :     sources = [(p, { class = "cm", derived = derived })],
411 : blume 986 cmfiles = [(p, cparams)] },
412 : blume 742 [])
413 :     end
414 :    
415 : blume 873 fun expand { error, local_registry = lr, spec, context, load_plugin, sysinfo } = let
416 : blume 756 val dummy = ({ smlfiles = [], cmfiles = [], sources = [] }, [])
417 :     fun norule _ = dummy
418 :     fun native2pathmaker s () =
419 : blume 742 SrcPath.native { err = error } { context = context, spec = s }
420 :     fun class2rule class =
421 :     case classes class of
422 :     SOME rule => rule
423 :     | NONE => let
424 :     val base = concat ["$/", class, "-tool"]
425 :     val plugin = OS.Path.joinBaseExt { base = base,
426 :     ext = SOME "cm" }
427 :     fun complain () =
428 : blume 756 (error (concat ["unknown class: ", class]);
429 :     norule)
430 : blume 742 in
431 :     if globally (load_plugin context) plugin then
432 :     case classes class of
433 :     SOME rule => rule
434 :     | NONE => complain ()
435 :     else complain ()
436 :     end
437 :    
438 : blume 756 fun expand1 (spec as { name, mkpath, class = co, ... }) = let
439 :     val fns = { name = name, mkpath = mkpath }
440 : blume 742 val rule =
441 :     case co of
442 :     SOME c0 => class2rule (String.map Char.toLower c0)
443 :     | NONE =>
444 : blume 756 (case defaultClassOf (load_plugin context) fns of
445 : blume 742 SOME c => class2rule c
446 : blume 756 | NONE =>
447 :     (error (concat ["unable to classify: ", name]);
448 :     norule))
449 : blume 742 fun rcontext rf = let
450 :     val dir = SrcPath.osstring_dir context
451 :     val cwd = OS.FileSys.getDir ()
452 :     in
453 :     SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
454 :     closeIt = fn () => OS.FileSys.chDir cwd,
455 :     work = rf,
456 :     cleanup = fn _ => () }
457 :     end
458 :     in
459 :     rule { spec = spec, context = rcontext,
460 : blume 756 native2pathmaker = native2pathmaker,
461 : blume 873 defaultClassOf = defaultClassOf (load_plugin context),
462 :     sysinfo = sysinfo }
463 : blume 742 handle ToolError { tool, msg } =>
464 :     (error (concat ["tool \"", tool, "\" failed: ", msg]);
465 : blume 756 dummy)
466 : blume 742 end
467 :     fun loop (expansion, []) = expansion
468 :     | loop ({ smlfiles, cmfiles, sources }, item :: items) = let
469 :     val ({ smlfiles = sfl, cmfiles = cfl, sources = sl }, il) =
470 :     expand1 item
471 :     in
472 :     loop ({ smlfiles = smlfiles @ sfl,
473 :     cmfiles = cmfiles @ cfl,
474 :     sources = sources @ sl },
475 :     il @ items)
476 :     end
477 :     in
478 :     SafeIO.perform { openIt = fn () => !local_registry
479 :     before local_registry := lr,
480 :     closeIt = fn prev => local_registry := prev,
481 :     work = fn _ => loop ({ smlfiles = [], cmfiles = [],
482 :     sources = [] },
483 :     [spec]),
484 :     cleanup = fn _ => () }
485 :     end
486 :    
487 :     local
488 :     fun sfx (s, c) =
489 :     registerClassifier (stdSfxClassifier { sfx = s, class = c })
490 :     in
491 :     val _ = registerClass ("sml", smlrule)
492 :     val _ = registerClass ("cm", cmrule)
493 :    
494 :     val _ = sfx ("sml", "sml")
495 :     val _ = sfx ("sig", "sml")
496 :     val _ = sfx ("fun", "sml")
497 :     val _ = sfx ("cm", "cm")
498 :     end
499 :     end

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