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 313, Thu Jun 3 09:26:34 1999 UTC revision 314, Fri Jun 4 06:41:45 1999 UTC
# Line 1  Line 1 
1  (*  (*
2   * The "generic" compilation traversal functor.   * The "generic" compilation traversal functor.
3     *  (In fact, it is probably possible to use this for things other
4     *   than compilation as well.)
5   *   *
6   * (C) 1999 Lucent Technologies, Bell Laboratories   * (C) 1999 Lucent Technologies, Bell Laboratories
7   *   *
# Line 8  Line 10 
10  local  local
11      structure GP = GeneralParams      structure GP = GeneralParams
12      structure DG = DependencyGraph      structure DG = DependencyGraph
13        structure GG = GroupGraph
14  in  in
15      functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig      functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig
16    
17          type envdelta = CT.envdelta          type envdelta = CT.envdelta
18          type benv = CT.benv          type result = CT.result
         type env = CT.env  
19    
20          val bnode : GP.info -> DG.bnode -> envdelta option          val bnode : GP.info -> DG.bnode -> envdelta option
21          val farbnode : GP.info -> DG.farbnode -> benv option          val group : GP.info -> GG.group -> result option
         val snode : GP.info -> DG.snode -> envdelta option  
         val sbnode : GP.info -> DG.sbnode -> envdelta option  
         val farsbnode : GP.info -> DG.farsbnode -> env option  
22    
23      end = struct      end = struct
24    
25          type envdelta = CT.envdelta          type envdelta = CT.envdelta
26          type env = CT.env          type env = CT.env
27          type benv = CT.benv          type benv = CT.benv
28            type result = CT.result
29    
30            (* This is to prevent re-execution of dosml if the first one failed *)
31            local
32                val failures = ref SmlInfoSet.empty
33            in
34                fun dosml (i, e, gp) =
35                    if SmlInfoSet.member (!failures, i) then NONE
36                    else case CT.dosml (i, e, gp) of
37                        SOME r => SOME r
38                      | NONE => (failures := SmlInfoSet.add (!failures, i); NONE)
39                fun clearFailures () = failures := SmlInfoSet.empty
40            end
41    
42            (* To implement "keep_going" we have two different ways to "fold"
43             * a "layer" function over a list.  The _k version is to be used
44             * if keep_going is true, otherwise the _s version applies.
45             * Note that there is a bit of typing mystery in the way I use
46             * these functions later: I had to be more verbose than I wanted
47             * to because of the "value restriction rule" in SML'97. *)
48          fun foldlayer_k layer f = let          fun foldlayer_k layer f = let
49              fun loop r [] = r              fun loop r [] = r
50                | loop NONE (h :: t) = (ignore (f h); loop NONE t)                | loop NONE (h :: t) = (ignore (f h); loop NONE t)
# Line 99  Line 117 
117          in          in
118              case e of              case e of
119                  NONE => NONE                  NONE => NONE
120                | SOME e => CT.dosml (smlinfo, e, gp)                | SOME e => dosml (smlinfo, e, gp)
121          end          end
122    
123          and sbnode gp (DG.SB_BNODE b) = bnode gp b          and sbnode gp (DG.SB_BNODE b) = bnode gp b
# Line 110  Line 128 
128                  (NONE, _) => NONE                  (NONE, _) => NONE
129                | (SOME d, NONE) => SOME (CT.nofilter d)                | (SOME d, NONE) => SOME (CT.nofilter d)
130                | (SOME d, SOME s) => SOME (CT.filter (d, s))                | (SOME d, SOME s) => SOME (CT.filter (d, s))
131    
132            fun impexp gp (n, _) = Option.map CT.env2result (farsbnode gp n)
133    
134            fun group gp (GG.GROUP { exports, ... }) = let
135                val fl =
136                    if #keep_going (#param gp) then foldlayer_k else foldlayer_s
137            in
138                (fl CT.rlayer (impexp gp)
139                              (SOME CT.empty)
140                              (SymbolMap.listItems exports))
141                before clearFailures ()
142            end
143      end      end
144  end  end

Legend:
Removed from v.313  
changed lines
  Added in v.314

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