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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 295 - (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 :     case CT.lookstable (bininfo, mkenv) of
77 :     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 :     (case CT.looksml (smlinfo, le) of
112 :     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