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 298 - (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 298 CT.dostable (bininfo, mkenv, gp)
77 : blume 295 end
78 :     in
79 :     bn
80 :     end
81 : blume 294
82 : blume 295 and farbnode gp (f, n) =
83 :     case (bnode gp n, f) of
84 :     (NONE, _) => NONE
85 :     | (SOME d, NONE) => SOME (CT.bnofilter d)
86 :     | (SOME d, SOME s) => SOME (CT.bfilter (d, s))
87 :    
88 :     fun snode gp (DG.SNODE n) = let
89 :    
90 :     val (glob, loc) = let
91 :     val globf = farsbnode gp
92 :     val locf = Option.map CT.nofilter o snode gp
93 :     fun k f = foldlayer_k CT.layer f
94 :     fun s f = foldlayer_s CT.layer f
95 :     in
96 :     if #keep_going gp then (k globf, k locf)
97 :     else (s globf, s locf)
98 :     end
99 :    
100 :     val { smlinfo, localimports = li, globalimports = gi } = n
101 :     val pe = CT.nofilter (prim gp Primitive.pervasive)
102 :     val ge = glob (SOME pe) gi
103 :     val le = loc ge li
104 :     in
105 :     case le of
106 :     NONE => NONE
107 : blume 298 | SOME le => CT.dosml (smlinfo, le, gp)
108 : blume 295 end
109 :    
110 :     and sbnode gp (DG.SB_BNODE b) = bnode gp b
111 :     | sbnode gp (DG.SB_SNODE s) = snode gp s
112 :    
113 :     and farsbnode gp (f, n) =
114 :     case (sbnode gp n, f) of
115 :     (NONE, _) => NONE
116 :     | (SOME d, NONE) => SOME (CT.nofilter d)
117 :     | (SOME d, SOME s) => SOME (CT.filter (d, s))
118 :     end
119 : blume 294 end

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