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

Annotation of /sml/trunk/src/cm/link.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 316 - (view) (download)

1 : blume 314 (* test implementation of functor LinkCM *)
2 : blume 274
3 : blume 301 functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
4 : blume 274
5 : blume 276 local
6 :     structure YaccTool = YaccTool
7 :     structure LexTool = LexTool
8 :     structure BurgTool = BurgTool
9 :     val _ = EnvConfig.init ()
10 : blume 301
11 :     structure E = GenericVC.Environment
12 :     structure SE = GenericVC.StaticEnv
13 : blume 316 structure ER = GenericVC.EnvRef
14 :     structure BE = GenericVC.BareEnvironment
15 : blume 301 structure CMSE = GenericVC.CMStaticEnv
16 :     structure S = GenericVC.Symbol
17 :    
18 :     fun split e = let
19 :     val sym = E.symbolicPart e
20 :     val dyn = E.dynamicPart e
21 :     val stat = E.staticPart e
22 :     val bstat = CMSE.unCM stat
23 :     fun f ((s, b), (mods, nomods)) =
24 :     case S.nameSpace s of
25 :     (S.STRspace | S.SIGspace | S.FCTspace | S.FSIGspace) =>
26 :     (SE.bind (s, b, mods), nomods)
27 :     | _ => (mods, SE.bind (s, b, nomods))
28 :     val (bmods, bnomods) = SE.fold f (SE.empty, SE.empty) bstat
29 :     val mods = CMSE.CM bmods
30 :     val nomods = CMSE.CM bnomods
31 :     fun mk s = E.mkenv { static = s, dynamic = dyn, symbolic = sym }
32 :     in
33 :     { mod = mk mods, nomod = mk nomods }
34 :     end
35 :    
36 :     structure FullPersstate =
37 :     FullPersstateFn (structure MachDepVC = HostMachDepVC)
38 :    
39 :     structure Recomp = RecompFn (structure PS = FullPersstate)
40 :     structure Exec = ExecFn (structure PS = FullPersstate)
41 :    
42 :     structure RecompTraversal = CompileGenericFn (structure CT = Recomp)
43 :     structure ExecTraversal = CompileGenericFn (structure CT = Exec)
44 :    
45 : blume 310 fun bn2statenv gp i = #1 (#stat (valOf (RecompTraversal.bnode gp i)))
46 :    
47 : blume 314 val recomp_group = RecompTraversal.group
48 : blume 301
49 : blume 315 fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
50 : blume 314 (if StringSet.isEmpty rq then ()
51 :     else Say.say ("$Execute: required privileges are:\n" ::
52 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
53 : blume 315 ExecTraversal.group gp g
54 :     before FullPersstate.rememberShared ())
55 : blume 314
56 : blume 316 fun recomp_runner gp g = isSome (recomp_group gp g)
57 : blume 315
58 : blume 316 fun make_runner gp g =
59 :     case recomp_group gp g of
60 :     NONE => false
61 :     | SOME { stat, sym} =>
62 :     (case exec_group gp g of
63 :     NONE => false
64 :     | SOME dyn => let
65 :     val delta = E.mkenv { static = stat, symbolic = sym,
66 :     dynamic = dyn }
67 :     val base = #get ER.topLevel ()
68 :     val new = BE.concatEnv (ER.unCMenv delta, base)
69 :     in
70 :     #set ER.topLevel new;
71 :     Say.vsay ["[New bindings added.]\n"];
72 :     true
73 :     end)
74 :    
75 : blume 311 structure Stabilize = StabilizeFn (val bn2statenv = bn2statenv
76 : blume 316 val recomp = recomp_runner)
77 : blume 311
78 :     structure Parse = ParseFn (structure Stabilize = Stabilize)
79 : blume 316
80 :     fun stabilize_runner gp g = true
81 : blume 276 in
82 : blume 274 structure CM = struct
83 : blume 301
84 : blume 310 fun run sflag f s = let
85 : blume 274 val c = AbsPath.cwdContext ()
86 :     val p = AbsPath.native { context = AbsPath.cwdContext (),
87 :     spec = s }
88 : blume 301 val { mod = basis, nomod = perv } =
89 : blume 316 split (#get ER.pervasive ())
90 :     val corenv = #get ER.core ()
91 : blume 301 val primconf = Primitive.configuration { basis = basis }
92 :     val param = { primconf = primconf,
93 :     fnpolicy = FilenamePolicy.default,
94 : blume 314 keep_going = true,
95 : blume 301 pervasive = perv,
96 :     corenv = corenv }
97 : blume 274 in
98 : blume 314 case Parse.parse param sflag p of
99 : blume 316 NONE => false
100 : blume 314 | SOME (g, gp) => f gp g
101 : blume 274 end
102 : blume 286
103 : blume 316 fun stabilize recursively = run (SOME recursively) stabilize_runner
104 :     val recomp = run NONE recomp_runner
105 :     val make = run NONE make_runner
106 : blume 274 end
107 :    
108 :     structure CMB = struct
109 :     fun setRetargetPervStatEnv x = ()
110 :     fun wipeOut () = ()
111 :     fun make' _ = ()
112 :     end
113 : blume 276 end
114 : blume 274 end
115 :    
116 :     signature CMTOOLS = sig end
117 :     signature COMPILATION_MANAGER = sig end

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