Annotation of /sml/trunk/src/cm/compile/generic.sml

Parent Directory | Revision Log

---

Revision 297 - (view) (download)

1 :	blume	295	(*
2 :			* The "generic" compilation traversal functor.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :			local
9 :			structure GP = GeneralParams
10 :	blume	294	structure DG = DependencyGraph
11 :	blume	295	in
12 :			functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig
13 :	blume	294
14 :	blume	295	type envdelta = CT.envdelta
15 :			type benv = CT.benv
16 :			type env = CT.env
17 :	blume	294
18 :	blume	295	val bnode : GP.params -> DG.bnode -> envdelta option
19 :			val farbnode : GP.params -> DG.farbnode -> benv option
20 :			val snode : GP.params -> DG.snode -> envdelta option
21 :			val sbnode : GP.params -> DG.sbnode -> envdelta option
22 :			val farsbnode : GP.params -> DG.farsbnode -> env option
23 :	blume	294
24 :	blume	295	end = struct
25 :	blume	294
26 :	blume	295	type envdelta = CT.envdelta
27 :			type env = CT.env
28 :			type benv = CT.benv
29 :
30 :			fun prim (gp: GP.params) = CT.primitive (#primconf gp)
31 :
32 :			fun foldlayer_k layer f = let
33 :			fun loop r [] = r
34 :			| loop NONE (h :: t) = (ignore (f h); loop NONE t)
35 :			| loop (SOME e) (h :: t) =
36 :			case f h of
37 :			NONE => loop NONE t
38 :			| SOME e' => loop (SOME (layer (e', e))) t
39 :			in
40 :			loop
41 :			end
42 :
43 :			fun foldlayer_s layer f NONE l = NONE
44 :			| foldlayer_s layer f (SOME i) l = let
45 :			fun loop e [] = SOME e
46 :			| loop e (h :: t) =
47 :			case f h of
48 :			NONE => NONE
49 :			| SOME e' => loop (layer (e', e)) t
50 :	blume	294	in
51 :	blume	295	loop i l
52 :	blume	294	end
53 :
54 :	blume	295	fun bnode (gp: GP.params) = let
55 :	blume	294
56 :	blume	295	val (glob, loc) = let
57 :			val globf = farbnode gp
58 :			val locf = Option.map CT.bnofilter o bnode gp
59 :			fun k f = foldlayer_k CT.blayer f
60 :			fun s f = foldlayer_s CT.blayer f
61 :	blume	294	in
62 :	blume	295	if #keep_going gp then (k globf, k locf)
63 :			else (s globf, s locf)
64 :	blume	294	end
65 :
66 :	blume	295	fun bn (DG.PNODE p) = SOME (prim gp p)
67 :			| bn (DG.BNODE n) = let
68 :			val { bininfo, localimports = li, globalimports = gi } = n
69 :			fun mkenv () = let
70 :			val pe = CT.bnofilter (prim gp Primitive.pervasive)
71 :			val ge = glob (SOME pe) gi
72 :			in
73 :			loc ge li
74 :			end
75 :			in
76 :	blume	297	case CT.lookstable (bininfo, mkenv, gp) of
77 :	blume	295	CT.FOUND e => SOME e
78 :			| CT.NOTFOUND (SOME le) => CT.dostable (bininfo, le, gp)
79 :			| CT.NOTFOUND NONE => NONE
80 :			end
81 :			in
82 :			bn
83 :			end
84 :	blume	294
85 :	blume	295	and farbnode gp (f, n) =
86 :			case (bnode gp n, f) of
87 :			(NONE, _) => NONE
88 :			| (SOME d, NONE) => SOME (CT.bnofilter d)
89 :			| (SOME d, SOME s) => SOME (CT.bfilter (d, s))
90 :
91 :			fun snode gp (DG.SNODE n) = let
92 :
93 :			val (glob, loc) = let
94 :			val globf = farsbnode gp
95 :			val locf = Option.map CT.nofilter o snode gp
96 :			fun k f = foldlayer_k CT.layer f
97 :			fun s f = foldlayer_s CT.layer f
98 :			in
99 :			if #keep_going gp then (k globf, k locf)
100 :			else (s globf, s locf)
101 :			end
102 :
103 :			val { smlinfo, localimports = li, globalimports = gi } = n
104 :			val pe = CT.nofilter (prim gp Primitive.pervasive)
105 :			val ge = glob (SOME pe) gi
106 :			val le = loc ge li
107 :			in
108 :			case le of
109 :			NONE => NONE
110 :			| SOME le =>
111 :	blume	297	(case CT.looksml (smlinfo, le, gp) of
112 :	blume	295	SOME e => SOME e
113 :			| NONE => CT.dosml (smlinfo, le, gp))
114 :			end
115 :
116 :			and sbnode gp (DG.SB_BNODE b) = bnode gp b
117 :			| sbnode gp (DG.SB_SNODE s) = snode gp s
118 :
119 :			and farsbnode gp (f, n) =
120 :			case (sbnode gp n, f) of
121 :			(NONE, _) => NONE
122 :			| (SOME d, NONE) => SOME (CT.nofilter d)
123 :			| (SOME d, SOME s) => SOME (CT.filter (d, s))
124 :			end
125 :	blume	294	end

---

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