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 295, Wed May 26 09:20:25 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                        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    
85            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      and farsbnode c = farnode (sbnode c)              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  end  end

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

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