Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/main/cm-boot.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/main/cm-boot.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 716 - (view) (download)

1 : blume 375 (*
2 :     * This is the module that actually puts together the contents of the
3 : blume 587 * structure CM that people find in smlnj/cm/full.cm. A "minimal" structure
4 : blume 375 * CM is defined in CmHook, but it needs to be initialized at bootstrap
5 : blume 495 * time.
6 : blume 375 *
7 :     * Copyright (c) 1999 by Lucent Bell Laboratories
8 :     *
9 :     * author: Matthias Blume (blume@cs.princeton.edu)
10 :     *)
11 :     functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
12 :    
13 :     datatype envrequest = AUTOLOAD | BARE
14 :    
15 :     local
16 :     structure E = GenericVC.Environment
17 : blume 569 structure DE = DynamicEnv
18 : blume 375 structure SE = GenericVC.StaticEnv
19 :     structure ER = GenericVC.EnvRef
20 :     structure S = GenericVC.Symbol
21 :     structure EM = GenericVC.ErrorMsg
22 :     structure BF = HostMachDepVC.Binfile
23 : blume 380 structure P = OS.Path
24 :     structure F = OS.FileSys
25 : blume 451 structure DG = DependencyGraph
26 : blume 587 structure GG = GroupGraph
27 : blume 375
28 :     val os = SMLofNJ.SysInfo.getOSKind ()
29 : blume 464 val my_archos =
30 :     concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
31 : blume 375
32 :     structure SSV =
33 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
34 :     val os = os)
35 :    
36 :     val emptydyn = E.dynamicPart E.emptyEnv
37 : blume 569 val system_values = ref (SrcPathMap.empty: E.dynenv SrcPathMap.map)
38 : blume 375
39 : blume 588 structure StabModmap = StabModmapFn ()
40 :    
41 : blume 400 structure Compile =
42 : blume 448 CompileFn (structure MachDepVC = HostMachDepVC
43 : blume 588 structure StabModmap = StabModmap
44 : blume 677 val useStream = HostMachDepVC.Interact.useStream
45 : blume 464 val compile_there = Servers.compile o SrcPath.descr)
46 : blume 400
47 : blume 537 structure BFC =
48 :     BfcFn (structure MachDepVC = HostMachDepVC)
49 :    
50 : blume 399 structure Link =
51 :     LinkFn (structure MachDepVC = HostMachDepVC
52 : blume 537 structure BFC = BFC
53 : blume 399 val system_values = system_values)
54 : blume 375
55 :     structure AutoLoad = AutoLoadFn
56 : blume 399 (structure C = Compile
57 : blume 403 structure L = Link
58 :     structure BFC = BFC)
59 : blume 375
60 : blume 537 val mkBootList = #l o MkBootList.group (fn p => p)
61 :    
62 : blume 587 fun init_servers (GG.GROUP { grouppath, ... }) =
63 : blume 464 Servers.cm { archos = my_archos, project = SrcPath.descr grouppath }
64 : blume 587 | init_servers GG.ERRORGROUP = ()
65 : blume 456
66 : blume 399 fun recomp_runner gp g = let
67 : blume 456 val _ = init_servers g
68 : blume 403 fun store _ = ()
69 :     val { group, ... } = Compile.newTraversal (Link.evict, store, g)
70 : blume 399 in
71 : blume 450 isSome (Servers.withServers (fn () => group gp))
72 :     before Link.cleanup gp
73 : blume 399 end
74 : blume 375
75 :     (* This function combines the actions of "recompile" and "exec".
76 :     * When successful, it combines the results (thus forming a full
77 :     * environment) and adds it to the toplevel environment. *)
78 : blume 587 fun make_runner _ _ GG.ERRORGROUP = false
79 :     | make_runner add_bindings gp (g as GG.GROUP grec) = let
80 :     val { required = rq, ... } = grec
81 :     val { store, get } = BFC.new ()
82 :     val _ = init_servers g
83 :     val { group = c_group, ... } =
84 :     Compile.newTraversal (Link.evict, store, g)
85 :     val { group = l_group, ... } = Link.newTraversal (g, get)
86 :     in
87 :     case Servers.withServers (fn () => c_group gp) of
88 :     NONE => false
89 :     | SOME { stat, sym} =>
90 : blume 537 (* Before executing the code, we announce the privileges
91 : blume 399 * that are being invoked. (For the time being, we assume
92 :     * that everybody has every conceivable privilege, but at
93 :     * the very least we announce which ones are being made
94 :     * use of.) *)
95 : blume 400 (Link.cleanup gp;
96 : blume 399 if StringSet.isEmpty rq then ()
97 :     else Say.say ("$Execute: required privileges are:\n" ::
98 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
99 :     case l_group gp of
100 : blume 375 NONE => false
101 : blume 518 | SOME dyn =>
102 :     (if add_bindings then
103 :     let val delta = E.mkenv { static = stat,
104 :     symbolic = sym,
105 :     dynamic = dyn }
106 :     val base = #get ER.topLevel ()
107 : blume 587 val new = E.concatEnv (delta, base)
108 : blume 518 in
109 :     #set ER.topLevel new;
110 :     Say.vsay ["[New bindings added.]\n"]
111 :     end
112 :     else ();
113 :     true))
114 : blume 587 end
115 : blume 375
116 :     val al_greg = GroupReg.new ()
117 :    
118 :     (* Instantiate the stabilization mechanism. *)
119 :     structure Stabilize =
120 : blume 403 StabilizeFn (structure MachDepVC = HostMachDepVC
121 : blume 588 structure StabModmap = StabModmap
122 : blume 403 fun recomp gp g = let
123 :     val { store, get } = BFC.new ()
124 : blume 456 val _ = init_servers g
125 : blume 403 val { group, ... } =
126 :     Compile.newTraversal (Link.evict, store, g)
127 :     in
128 : blume 450 case Servers.withServers (fn () => group gp) of
129 : blume 403 NONE => NONE
130 :     | SOME _ => SOME get
131 :     end
132 :     val getII = Compile.getII)
133 : blume 375
134 :     (* Access to the stabilization mechanism is integrated into the
135 :     * parser. I'm not sure if this is the cleanest way, but it works
136 :     * well enough. *)
137 :     structure Parse = ParseFn (structure Stabilize = Stabilize
138 : blume 588 structure StabModmap = StabModmap
139 : blume 537 fun evictStale () =
140 :     (Compile.evictStale ();
141 :     Link.evictStale ())
142 : blume 375 val pending = AutoLoad.getPending)
143 :    
144 :     local
145 : blume 592 type kernelValues = { init_group : GG.group }
146 : blume 375
147 :     val fnpolicy = FilenamePolicy.colocate
148 :     { os = os, arch = HostMachDepVC.architecture }
149 :    
150 :     val theValues = ref (NONE: kernelValues option)
151 :    
152 :     in
153 : blume 666 val penv = SrcPath.newEnv ()
154 : blume 645
155 : blume 377 (* cancelling anchors cannot affect the order of existing paths
156 :     * (it may invalidate some paths; but all other ones stay as
157 :     * they are) *)
158 : blume 666 fun setAnchor a v = SrcPath.set_anchor (penv, a, v)
159 : blume 377 (* same goes for reset because it just cancels all anchors... *)
160 : blume 666 fun resetPathConfig () = SrcPath.reset_anchors penv
161 : blume 569 (* get the current binding for an anchor *)
162 : blume 666 fun getAnchor a () = SrcPath.get_anchor (penv, a)
163 : blume 375
164 : blume 525 fun mkStdSrcPath s =
165 : blume 666 SrcPath.file
166 :     (SrcPath.standard { err = fn s => raise Fail s, env = penv }
167 :     { context = SrcPath.cwd (), spec = s })
168 : blume 525
169 : blume 479 fun getPending () = let
170 : blume 375 fun one (s, _) = let
171 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
172 :     val n = Symbol.name s
173 :     in
174 : blume 479 concat [" ", nss, " ", n, "\n"]
175 : blume 375 end
176 :     in
177 : blume 479 map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
178 : blume 375 end
179 :    
180 :     fun initPaths () = let
181 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
182 : blume 375 val p = case lpcth () of
183 :     NONE => []
184 :     | SOME f => [f]
185 : blume 433 val p = #get StdConfig.pathcfgspec () :: p
186 : blume 666 fun processOne f = SrcPath.processSpecFile (penv, f)
187 : blume 375 handle _ => ()
188 :     in
189 : blume 676 app processOne p;
190 :     SrcPath.sync ()
191 : blume 375 end
192 :    
193 : blume 537 fun getTheValues () = valOf (!theValues)
194 :     handle Option => raise Fail "CMBoot: theParam not initialized"
195 :    
196 : blume 375 fun param () = let
197 : blume 537 val v = getTheValues ()
198 : blume 375 in
199 : blume 537 { fnpolicy = fnpolicy,
200 : blume 666 penv = penv,
201 : blume 433 symval = SSV.symval,
202 : blume 592 keep_going = #get StdConfig.keep_going () }
203 : blume 375 end
204 :    
205 : blume 537 val init_group = #init_group o getTheValues
206 :    
207 : blume 507 fun dropPickles () =
208 :     if #get StdConfig.conserve_memory () then
209 :     Parse.dropPickles ()
210 :     else ()
211 :    
212 : blume 537 fun parse_arg (gr, sflag, p) =
213 :     { load_plugin = load_plugin, gr = gr, param = param (),
214 : blume 569 stabflag = sflag, group = p,
215 :     init_group = init_group (), paranoid = false }
216 : blume 537
217 :     and autoload s = let
218 : blume 525 val p = mkStdSrcPath s
219 : blume 375 in
220 : blume 537 (case Parse.parse (parse_arg (al_greg, NONE, p)) of
221 : blume 505 NONE => false
222 :     | SOME (g, _) =>
223 : blume 537 (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
224 :     true))
225 : blume 507 before dropPickles ()
226 : blume 375 end
227 :    
228 : blume 578 and run mkSrcPath sflag f s = let
229 :     val p = mkSrcPath s
230 : blume 537 val gr = GroupReg.new ()
231 : blume 375 in
232 : blume 537 (case Parse.parse (parse_arg (gr, sflag, p)) of
233 : blume 505 NONE => false
234 :     | SOME (g, gp) => f gp g)
235 : blume 507 before dropPickles ()
236 : blume 375 end
237 :    
238 : blume 578 and load_plugin context x = let
239 : blume 518 val _ = Say.vsay ["[attempting to load plugin ", x, "]\n"]
240 : blume 643 fun badname s = Say.say ["[bad plugin name: ", s, "]\n"]
241 : blume 578 fun mkSrcPath s =
242 : blume 666 SrcPath.file
243 :     (SrcPath.standard { env = penv, err = badname }
244 :     { context = context, spec = s })
245 : blume 518 val success =
246 : blume 578 run mkSrcPath NONE (make_runner false) x handle _ => false
247 : blume 518 in
248 :     if success then
249 :     Say.vsay ["[plugin ", x, " loaded successfully]\n"]
250 :     else
251 :     Say.vsay ["[unable to load plugin ", x, "]\n"];
252 :     success
253 :     end
254 :    
255 : blume 666 fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x
256 : blume 578
257 : blume 449 fun stabilize_runner gp g = true
258 :    
259 : blume 578 fun stabilize recursively =
260 :     run mkStdSrcPath (SOME recursively) stabilize_runner
261 :     val recomp = run mkStdSrcPath NONE recomp_runner
262 :     val make = run mkStdSrcPath NONE (make_runner true)
263 : blume 449
264 : blume 642
265 :     fun sources archos group = let
266 :     val policy =
267 :     case archos of
268 :     NONE => fnpolicy
269 :     | SOME ao => FilenamePolicy.colocate_generic ao
270 : blume 666 fun sourcesOf ((p, gth, _), (v, a)) =
271 : blume 642 if SrcPathSet.member (v, p) then (v, a)
272 :     else
273 :     let val v = SrcPathSet.add (v, p)
274 : blume 652 in case gth () of
275 : blume 642 GG.ERRORGROUP => (v, a)
276 :     | GG.GROUP { kind, sources, ... } => let
277 :     fun add (p, x, a) =
278 :     StringMap.insert
279 :     (a, SrcPath.osstring p, x)
280 :     val a = SrcPathMap.foldli add a sources
281 :     fun sg subgroups =
282 :     foldl sourcesOf (v, a) subgroups
283 :     in
284 :     case kind of
285 :     GG.LIB { kind, version } =>
286 :     (case kind of
287 :     GG.STABLE _ => let
288 :     val file = SrcPath.osstring p
289 :     val (a, x) =
290 :     StringMap.remove (a, file)
291 :     val sfile =
292 :     FilenamePolicy.mkStableName
293 :     policy (p, version)
294 :     in
295 :     (v,
296 :     StringMap.insert (a, sfile, x))
297 :     end
298 :     | GG.DEVELOPED d => sg (#subgroups d))
299 :     | GG.NOLIB n => sg (#subgroups n)
300 :     end
301 :     end
302 : blume 632 val p = mkStdSrcPath group
303 :     val gr = GroupReg.new ()
304 :     in
305 :     (case Parse.parse (parse_arg (gr, NONE, p)) of
306 : blume 642 SOME (g, _) => let
307 :     val (_, sm) =
308 : blume 666 sourcesOf ((p, fn () => g, []),
309 : blume 642 (SrcPathSet.empty,
310 :     StringMap.singleton
311 :     (SrcPath.osstring p,
312 :     { class = "cm",
313 :     derived = false })))
314 :     fun add (s, { class, derived }, l) =
315 :     { file = s, class = class, derived = derived } :: l
316 : blume 632 in
317 : blume 642 SOME (StringMap.foldli add [] sm)
318 :     end
319 :     | _ => NONE)
320 : blume 632 before dropPickles ()
321 :     end
322 :    
323 : blume 692 fun mk_standalone sflag { project, wrapper, target } = let
324 :     val hsfx = SMLofNJ.SysInfo.getHeapSuffix ()
325 :     fun extendTarget () =
326 :     OS.Path.joinBaseExt { base = target, ext = SOME hsfx }
327 :     val target =
328 :     case OS.Path.splitBaseExt target of
329 :     { base, ext = NONE } => extendTarget ()
330 :     | { base, ext = SOME e } =>
331 :     if e = hsfx then target else extendTarget ()
332 :     val pp = mkStdSrcPath project
333 :     val wp = mkStdSrcPath wrapper
334 :     val ts = TStamp.fmodTime target
335 : blume 537 val gr = GroupReg.new ()
336 : blume 692 fun do_wrapper () =
337 :     case Parse.parse (parse_arg (gr, NONE, wp)) of
338 :     NONE => NONE
339 :     | SOME (g, gp) =>
340 :     if recomp_runner gp g then SOME (mkBootList g)
341 :     else NONE
342 : blume 537 in
343 : blume 692 (case Parse.parse (parse_arg (gr, sflag, pp)) of
344 : blume 537 NONE => NONE
345 :     | SOME (g, gp) =>
346 :     if isSome sflag orelse recomp_runner gp g then
347 : blume 692 case (ts, !(#youngest gp)) of
348 :     (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) =>
349 :     if Time.< (tgt_t, src_t) then do_wrapper ()
350 :     else SOME []
351 :     | _ => do_wrapper ()
352 : blume 537 else NONE)
353 :     before dropPickles ()
354 :     end
355 :    
356 : blume 518 fun slave () = let
357 : blume 537 val gr = GroupReg.new ()
358 :     fun parse p = Parse.parse (parse_arg (gr, NONE, p))
359 : blume 518 in
360 : blume 666 Slave.slave { penv = penv,
361 : blume 518 parse = parse,
362 : blume 480 my_archos = my_archos,
363 :     sbtrav = Compile.newSbnodeTraversal,
364 :     make = make }
365 : blume 518 end
366 : blume 456
367 : blume 716 (* This function works on behalf of the ml-build script.
368 :     * Having it here avoids certain startup-costs and also
369 :     * keeps ML code together. (It used to be part of the
370 :     * script, but that proved difficult to maintain.) *)
371 :     fun mlbuild buildargs =
372 :     OS.Process.exit
373 :     (case buildargs of
374 :     [root, cmfile, heap, listfile, link] =>
375 :     (case mk_standalone NONE { project = root,
376 :     wrapper = cmfile,
377 :     target = heap } of
378 :     NONE => (Say.say ["Compilation failed.\n"];
379 :     OS.Process.failure)
380 :     | SOME [] => (Say.say ["Heap was already up-to-date.\n"];
381 :     OS.Process.success)
382 :     | SOME l => let
383 :     val s = TextIO.openOut listfile
384 :     fun wr str = TextIO.output (s, str ^ "\n")
385 :     val n = length l
386 :     fun maxsz (s, n) = Int.max (size s, n)
387 :     val m = foldl maxsz 0 l
388 :     in
389 :     wr (concat ["%", Int.toString n, " ",
390 :     Int.toString m]);
391 :     app wr l;
392 :     TextIO.closeOut s;
393 :     OS.Process.system (concat [link,
394 :     " @SMLboot=", listfile])
395 :     end
396 :     handle _ => OS.Process.failure)
397 :     | _ => (Say.say ["bad arguments to @CMbuild\n"];
398 :     OS.Process.failure))
399 :    
400 : blume 518 fun al_ginfo () = { param = param (),
401 :     groupreg = al_greg,
402 : blume 692 errcons = EM.defaultConsumer (),
403 :     youngest = ref TStamp.ancient }
404 : blume 518
405 :     val al_manager =
406 :     AutoLoad.mkManager { get_ginfo = al_ginfo,
407 :     dropPickles = dropPickles }
408 :    
409 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
410 :    
411 : blume 375 fun reset () =
412 : blume 399 (Compile.reset ();
413 :     Link.reset ();
414 : blume 375 AutoLoad.reset ();
415 :     Parse.reset ();
416 : blume 588 SmlInfo.reset ();
417 :     StabModmap.reset ())
418 : blume 375
419 : blume 569 fun initTheValues (bootdir, de, er, autoload_postprocess) = let
420 : blume 375 val _ = let
421 :     fun listDir ds = let
422 :     fun loop l =
423 : blume 380 case F.readDir ds of
424 : blume 375 "" => l
425 :     | x => loop (x :: l)
426 :     in
427 :     loop []
428 :     end
429 :     val fileList = SafeIO.perform
430 : blume 380 { openIt = fn () => F.openDir bootdir,
431 :     closeIt = F.closeDir,
432 : blume 375 work = listDir,
433 : blume 459 cleanup = fn _ => () }
434 : blume 380 fun isDir x = F.isDir x handle _ => false
435 : blume 375 fun subDir x = let
436 : blume 380 val d = P.concat (bootdir, x)
437 : blume 375 in
438 :     if isDir d then SOME (x, d) else NONE
439 :     end
440 :     val pairList = List.mapPartial subDir fileList
441 : blume 666 fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d)
442 : blume 375 in
443 : blume 666 app sa pairList
444 : blume 375 end
445 : blume 569
446 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
447 :     fun readpidmap s = let
448 :     fun loop m = let
449 :     fun enter (d, pids) = let
450 :     fun enter1 (hexp, e) =
451 :     case GenericVC.PersStamps.fromHex hexp of
452 :     SOME p => (DE.bind (p, DE.look de p, e)
453 :     handle DE.Unbound => e)
454 :     | NONE => e
455 :     in
456 : blume 666 SrcPathMap.insert (m, SrcPath.decode penv d,
457 : blume 569 foldl enter1 emptydyn pids)
458 :     end
459 :     in
460 :     case TextIO.inputLine s of
461 :     "" => m
462 :     | line => (case String.tokens Char.isSpace line of
463 :     d :: pids => loop (enter (d, pids))
464 :     | _ => loop m)
465 :     end
466 :     in
467 :     system_values := loop SrcPathMap.empty
468 :     end
469 :    
470 :     val _ =
471 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
472 :     closeIt = TextIO.closeIn,
473 :     work = readpidmap,
474 :     cleanup = fn _ => () }
475 :    
476 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
477 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
478 : blume 666 penv = penv,
479 : blume 433 symval = SSV.symval,
480 : blume 592 keep_going = false },
481 : blume 375 groupreg = GroupReg.new (),
482 : blume 692 errcons = EM.defaultConsumer (),
483 :     youngest = ref TStamp.ancient }
484 : blume 537 fun loadInitGroup () =
485 : blume 666 Stabilize.loadStable
486 :     { getGroup = fn _ =>
487 :     raise Fail "CMBoot: initial getGroup",
488 :     anyerrors = ref false }
489 :     (ginfo, initgspec, NONE, [])
490 : blume 375 in
491 : blume 537 case loadInitGroup () of
492 :     NONE => raise Fail "CMBoot: unable to load init group"
493 :     | SOME init_group => let
494 :     val _ = Compile.reset ()
495 :     val _ = Link.reset ()
496 : blume 375
497 : blume 537 val { exports = ctm, ... } =
498 :     Compile.newTraversal (fn _ => fn _ => (),
499 :     fn _ => (),
500 :     init_group)
501 :     val { exports = ltm, ... } = Link.newTraversal
502 :     (init_group, fn _ => raise Fail "init: get bfc?")
503 :    
504 :     fun getSymTrav (tr_m, sy) =
505 :     case SymbolMap.find (tr_m, sy) of
506 :     NONE => raise Fail "init: bogus init group (1)"
507 :     | SOME tr => tr
508 :    
509 : blume 592 val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
510 :     val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
511 : blume 537
512 :     fun doTrav t =
513 :     case t ginfo of
514 :     SOME r => r
515 :     | NONE => raise Fail "init: bogus init group (2)"
516 :    
517 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
518 :     val pervdyn = doTrav perv_lt
519 :    
520 :     val pervasive = E.mkenv { static = pervstat,
521 :     symbolic = pervsym,
522 :     dynamic = pervdyn }
523 :    
524 : blume 495 fun bare_autoload x =
525 :     (Say.say
526 :     ["!* ", x,
527 :     ": \"autoload\" not available, using \"make\"\n"];
528 :     make x)
529 :     val bare_preload =
530 :     Preload.preload { make = make,
531 :     autoload = bare_autoload }
532 :     val standard_preload =
533 :     Preload.preload { make = make, autoload = autoload }
534 : blume 375 in
535 : blume 592 #set ER.pervasive pervasive;
536 : blume 587 #set ER.topLevel E.emptyEnv;
537 : blume 592 theValues := SOME { init_group = init_group };
538 : blume 375 case er of
539 :     BARE =>
540 : blume 495 (bare_preload BtNames.bare_preloads;
541 : blume 569 system_values := SrcPathMap.empty;
542 : blume 495 NONE)
543 : blume 375 | AUTOLOAD =>
544 :     (HostMachDepVC.Interact.installCompManager
545 :     (SOME al_manager');
546 : blume 495 standard_preload BtNames.standard_preloads;
547 : blume 507 (* unconditionally drop all library pickles *)
548 :     Parse.dropPickles ();
549 : blume 495 SOME (autoload_postprocess ()))
550 : blume 375 end
551 :     end
552 :     end
553 :     in
554 : blume 495 fun init (bootdir, de, er) = let
555 :     fun procCmdLine () = let
556 :     val autoload = ignore o autoload
557 :     val make = ignore o make
558 : blume 692 fun p (f, mk, ("sml" | "sig" | "fun")) =
559 :     HostMachDepVC.Interact.useFile f
560 :     | p (f, mk, "cm") = mk f
561 :     | p (f, mk, e) = Say.say ["!* unable to process `", f,
562 : blume 495 "' (unknown extension `", e, "')\n"]
563 : blume 692 fun badopt opt f () =
564 :     Say.say ["!* bad ", opt, " option: `", f, "'\n"]
565 :     fun carg ("-D", f, _) =
566 :     let val bad = badopt "-D" f
567 :     in
568 :     case String.fields (fn c => c = #"=")
569 :     (String.extract (f, 2, NONE)) of
570 :     "" :: _ => bad ()
571 :     | [var, num] =>
572 :     (case Int.fromString num of
573 :     SOME i => #set (SSV.symval var) (SOME i)
574 :     | NONE => bad ())
575 :     | [var] => #set (SSV.symval var) (SOME 1)
576 :     | _ => bad ()
577 :     end
578 :     | carg ("-U", f, _) =
579 :     (case String.extract (f, 2, NONE) of
580 :     "" => badopt "-U" f ()
581 :     | var => #set (SSV.symval var) NONE)
582 :     | carg (_, f, mk) = p (f, mk,
583 :     String.map Char.toLower
584 :     (getOpt (OS.Path.ext f, "<none>")))
585 : blume 716
586 :     fun args ("-a" :: rest, _) = args (rest, autoload)
587 :     | args ("-m" :: rest, _) = args (rest, make)
588 :     | args ("@CMbuild" :: rest, _) = mlbuild rest
589 :     | args (f :: rest, mk) =
590 :     (carg (String.substring (f, 0, 2), f, mk)
591 :     handle General.Subscript => ();
592 :     args (rest, mk))
593 :     | args ([], _) = ()
594 : blume 495 in
595 :     case SMLofNJ.getArgs () of
596 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
597 : blume 716 | l => args (l, autoload)
598 : blume 495 end
599 : blume 448 in
600 : blume 569 initTheValues (bootdir, de, er,
601 :     fn () => (Cleanup.install initPaths;
602 :     procCmdLine))
603 : blume 448 end
604 : blume 479
605 :     structure CM :> CM = struct
606 :     type 'a controller = { get : unit -> 'a, set : 'a -> unit }
607 :    
608 :     structure Anchor = struct
609 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
610 : blume 479 val reset = resetPathConfig
611 :     end
612 :    
613 :     structure Control = struct
614 :     val keep_going = StdConfig.keep_going
615 :     val verbose = StdConfig.verbose
616 :     val parse_caching = StdConfig.parse_caching
617 :     val warn_obsolete = StdConfig.warn_obsolete
618 :     val debug = StdConfig.debug
619 : blume 505 val conserve_memory = StdConfig.conserve_memory
620 : blume 479 end
621 :    
622 :     structure Library = struct
623 : blume 666 type lib = SrcPath.file
624 : blume 479 val known = Parse.listLibs
625 :     val descr = SrcPath.descr
626 :     val osstring = SrcPath.osstring
627 :     val dismiss = Parse.dismissLib
628 : blume 632 fun unshare lib = (Link.unshare lib; dismiss lib)
629 : blume 479 end
630 :    
631 :     structure State = struct
632 :     val synchronize = SrcPath.sync
633 :     val reset = reset
634 :     val pending = getPending
635 :     end
636 :    
637 :     structure Server = struct
638 :     type server = Servers.server
639 : blume 666 fun start x = Servers.start x
640 :     before SrcPath.scheduleNotification ()
641 : blume 479 val stop = Servers.stop
642 :     val kill = Servers.kill
643 :     val name = Servers.name
644 :     end
645 :    
646 :     val autoload = autoload
647 :     val make = make
648 :     val recomp = recomp
649 :     val stabilize = stabilize
650 :    
651 : blume 642 val sources = sources
652 : blume 632
653 : blume 479 val symval = SSV.symval
654 : blume 578 val load_plugin = cwd_load_plugin
655 : blume 537 val mk_standalone = mk_standalone
656 : blume 479 end
657 : blume 525
658 : blume 578 structure Tools = ToolsFn (val load_plugin = cwd_load_plugin
659 : blume 666 val penv = penv)
660 : blume 578
661 :     val load_plugin = load_plugin
662 : blume 375 end
663 :     end

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