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

Parent Directory | 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