Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/compile/generic.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 294, Tue May 25 09:06:06 1999 UTC revision 298, Thu May 27 09:42:28 1999 UTC
# Line 1  Line 1 
1    (*
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        structure DG = DependencyGraph
11    in
12  functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig  functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig
13    
14      type envdelta = CT.envdelta      type envdelta = CT.envdelta
15      val bnode : Primitive.configuration -> DependencyGraph.bnode -> envdelta          type benv = CT.benv
16  end = struct          type env = CT.env
17    
18      structure DG = DependencyGraph          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    
24        end = struct
25    
26      type envdelta = CT.envdelta      type envdelta = CT.envdelta
27            type env = CT.env
28            type benv = CT.benv
29    
30      infix o'          fun prim (gp: GP.params) = CT.primitive (#primconf gp)
     fun (f o' g) (x, y) = f (g x, y)  
31    
32      fun farnode near (NONE, n) = CT.nofilter (near n)          fun foldlayer_k layer f = let
33        | farnode near (SOME s, n) = CT.filter (near n, s)              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 bnode c (DG.PNODE p) = CT.primitive c p          fun foldlayer_s layer f NONE l = NONE
44        | bnode c (DG.BNODE { bininfo, localimports = li, globalimports = gi }) =            | foldlayer_s layer f (SOME i) l = let
45          case CT.lookstable bininfo of                  fun loop e [] = SOME e
46              SOME e => e                    | loop e (h :: t) =
47            | NONE => let                      case f h of
48                  val ge = foldl (CT.layer o' farbnode c) (CT.pervasive c) gi                          NONE => NONE
49                  val le = foldl (CT.layer o' (CT.nofilter o bnode c)) ge li                        | SOME e' => loop (layer (e', e)) t
                 val e = CT.dostable (bininfo, le, c)  
50              in              in
51                  CT.memostable (bininfo, e);                  loop i l
                 e  
52              end              end
53    
54      and farbnode c = farnode (bnode c)          fun bnode (gp: GP.params) = let
55    
56      fun snode c (DG.SNODE { smlinfo, localimports = li, globalimports = gi }) =              val (glob, loc) = let
57          case CT.looksml smlinfo of                  val globf = farbnode gp
58              SOME e => e                  val locf = Option.map CT.bnofilter o bnode gp
59            | NONE => let                  fun k f = foldlayer_k CT.blayer f
60                  val ge = foldl (CT.layer o' farsbnode c) (CT.pervasive c) gi                  fun s f = foldlayer_s CT.blayer f
                 val le = foldl (CT.layer o' (CT.nofilter o snode c)) ge li  
                 val e = CT.dosml (smlinfo, le, c)  
61              in              in
62                  CT.memosml (smlinfo, e);                  if #keep_going gp then (k globf, k locf)
63                  e                  else (s globf, s locf)
64              end              end
65    
66      and sbnode c (DG.SB_BNODE b) = bnode c b              fun bn (DG.PNODE p) = SOME (prim gp p)
67        | sbnode c (DG.SB_SNODE s) = snode c s                | 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                        CT.dostable (bininfo, mkenv, gp)
77                    end
78            in
79                bn
80            end
81    
82            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      and farsbnode c = farnode (sbnode c)              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                  | SOME le => CT.dosml (smlinfo, le, gp)
108            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  end  end

Legend:
Removed from v.294  
changed lines
  Added in v.298

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