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/depend/build.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/depend/build.sml

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

revision 278, Mon May 17 14:53:49 1999 UTC revision 279, Tue May 18 08:10:36 1999 UTC
# Line 1  Line 1 
1  structure BuildDepend = struct  signature BUILDDEPEND = sig
2        val build : { subexports: (DependencyGraph.farnode * DependencyGraph.env)
3                                    SymbolMap.map,
4                      smlfiles: SmlInfo.info list,
5                      localdefs: SmlInfo.info SymbolMap.map }
6            -> { nodemap: DependencyGraph.node SymbolMap.map,
7                 rootset: DependencyGraph.node list }
8    end
9    
10    structure BuildDepend :> BUILDDEPEND = struct
11    
12      structure S = Symbol      structure S = Symbol
13      structure SS = SymbolSet      structure SS = SymbolSet
14      structure SM = SymbolMap      structure SM = SymbolMap
15      structure SK = Skeleton      structure SK = Skeleton
16      structure DG = DependencyGraph      structure DG = DependencyGraph
17        structure EM = GenericVC.ErrorMsg
18        structure SP = GenericVC.SymPath
19    
20      fun look otherwise DG.EMPTY s = otherwise s      fun look otherwise DG.EMPTY s = otherwise s
21        | look otherwise (DG.BINDING (s', v)) s =        | look otherwise (DG.BINDING (s', v)) s =
# Line 13  Line 24 
24        | look otherwise (DG.FCTENV { looker, domain }) s =        | look otherwise (DG.FCTENV { looker, domain }) s =
25          (case looker s of NONE => otherwise s | SOME v => v)          (case looker s of NONE => otherwise s | SOME v => v)
26    
27        (* get the description for a symbol *)
28        fun symDesc (s, r) =
29            S.nameSpaceToString (S.nameSpace s) :: " " ::
30            S.name s :: r
31    
32      fun build { subexports, smlfiles, localdefs } = let      fun build { subexports, smlfiles, localdefs } = let
33    
34          (* the "blackboard" where analysis results are announced *)          (* the "blackboard" where analysis results are announced *)
# Line 24  Line 40 
40          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)
41    
42          (* the "root set" *)          (* the "root set" *)
43          val rs = ref AbsPathSet.empty          val rs = ref AbsPathMap.empty
44          fun addRoot i = rs := AbsPathSet.add (!rs, SmlInfo.sourcepath i)          fun addRoot i =
45                rs := AbsPathMap.insert (!rs, SmlInfo.sourcepath i, i)
46          fun delRoot i =          fun delRoot i =
47              (rs := AbsPathSet.delete (!rs, SmlInfo.sourcepath i))              (rs := #1 (AbsPathMap.remove (!rs, SmlInfo.sourcepath i)))
48              handle LibBase.NotFound => ()              handle LibBase.NotFound => ()
49    
50          (* - get the result from the blackboard if it is there *)          (* - get the result from the blackboard if it is there *)
# Line 40  Line 57 
57                | SOME (SOME r) => (delRoot i; r)                | SOME (SOME r) => (delRoot i; r)
58                | SOME NONE => let        (* cycle found --> error message *)                | SOME NONE => let        (* cycle found --> error message *)
59                      val f = SmlInfo.sourcepath i                      val f = SmlInfo.sourcepath i
                     fun symDesc (s, r) =  
                         S.nameSpaceToString (S.nameSpace s) :: " " ::  
                         S.name s :: r  
60                      fun pphist pps = let                      fun pphist pps = let
61                          fun recur [] = () (* shouldn't happen *)                          fun recur [] = () (* shouldn't happen *)
62                            | recur ((s, i') :: r) = let                            | recur ((s, i') :: r) = let
63                                  val f' = SmlInfo.sourcepath i'                                  val f' = SmlInfo.sourcepath i'
64                                  val _ =                                  val _ =
65                                      if AbsPath.compare (f, f') = EQUAL then ()                                      if SmlInfo.eq (i, i') then ()
66                                      else recur r                                      else recur r
67                                  val n' = AbsPath.name f'                                  val n' = AbsPath.name f'
68                                  val l =                                  val l =
# Line 64  Line 78 
78                          PrettyPrint.add_newline pps                          PrettyPrint.add_newline pps
79                      end                      end
80                  in                  in
81                      SmlInfo.error i "cyclic ML dependencies" pphist                      SmlInfo.error i "cyclic ML dependencies" pphist;
82                        release (i, (DG.NODE { smlinfo = i,
83                                               localimports = [],
84                                               globalimports = [] },
85                                     DG.EMPTY))
86                  end                  end
87    
88            (* do the actual analysis of an ML source and generate the
89             * corresponding node *)
90          and analyze (i, history) = let          and analyze (i, history) = let
91  (*          fun lookimport s =              val li = ref []
92                val gi = ref []
93    
94                (* register a local import *)
95                fun localImport (n as DG.NODE { smlinfo = i, ... }) = let
96                    fun sameNode (DG.NODE { smlinfo = i', ... }) =
97                        SmlInfo.eq (i, i')
98                in
99                    if List.exists sameNode (!li) then ()
100                    else li := n :: !li
101                end
102    
103                (* register a global import, maintain filter sets *)
104                fun globalImport (farn as DG.PNODE p) = let
105                        fun sameFarNode (DG.FARNODE _) = false
106                          | sameFarNode (DG.PNODE p') = Primitive.eq (p, p')
107                    in
108                        if List.exists sameFarNode (!gi) then ()
109                        else gi := farn :: !gi
110                    end
111                  | globalImport (farn as DG.FARNODE (f, n)) = let
112                        fun sameFarNode (DG.PNODE _) = false
113                          | sameFarNode (DG.FARNODE (_, n')) = let
114                                val DG.NODE { smlinfo = i, ... } = n
115                                val DG.NODE { smlinfo = i', ... } = n'
116                            in
117                                SmlInfo.eq (i, i')
118                            end
119                    in
120                        case List.find sameFarNode (!gi) of
121                            NONE => gi := farn :: !gi (* brand new *)
122                          | SOME (DG.FARNODE (NONE, n')) => ()
123                            (* no filter before -> no change *)
124                          | SOME (DG.FARNODE (SOME f', n')) => let
125                            (* there is a filter ...
126                             *   calculate "union-filter", see if there is
127                             *   a change, and if so, replace the filter *)
128                                fun replace filt =
129                                    gi :=
130                                       (DG.FARNODE (filt, n)) ::
131                                       (List.filter (not o sameFarNode) (!gi))
132                            in
133                                case f of
134                                    NONE => replace NONE
135                                  | SOME f =>
136                                        if SS.equal (f, f') then ()
137                                        else replace (SOME (SS.union (f, f')))
138                            end
139    
140                          | SOME (DG.PNODE _) => () (* cannot happen *)
141                    end
142    
143                val f = SmlInfo.sourcepath i
144                fun isSelf i' = SmlInfo.eq (i, i')
145    
146                (* lookup function for things not defined in the same ML file.
147                 * As a side effect, this function registers local and
148                 * global imports. *)
149                fun lookimport s = let
150                    fun lookfar () =
151                        case SM.find (subexports, s) of
152                            SOME (farn, e) => (globalImport farn; e)
153                          | NONE => (SmlInfo.error i
154                                      (concat (AbsPath.name f ::
155                                               ": reference to unknown " ::
156                                               symDesc (s, [])))
157                                      EM.nullErrorBody;
158                                     DG.EMPTY)
159                in
160                  case SM.find (localdefs, s) of                  case SM.find (localdefs, s) of
161                      SOME i' => let                      SOME i' =>
162                          val (_, e) = getResult (i', (s, i) :: history)                          if isSelf i' then lookfar ()
163                            else let
164                                val (n, e) = getResult (i', (s, i) :: history)
165                      in                      in
166                                localImport n;
167                          e                          e
168                      end                      end
169                    | NONE =>                    | NONE => lookfar ()
170                end
171    
172                (* build the lookup function for DG.env *)
173                val lookup = look lookimport
174    
175                fun lookSymPath e (SP.SPATH []) = DG.EMPTY
176                  | lookSymPath e (SP.SPATH (p as (h :: t))) = let
177                        fun dotPath [] = []
178                          | dotPath [s] = [S.name s]
179                          | dotPath (h :: t) = S.name h :: "." :: dotPath t
180                        val firstTime = ref true
181                        fun complain s =
182                            if !firstTime then
183                                (SmlInfo.error i
184                                 (concat
185                                  ("undefined " ::
186                                   symDesc (s, " in path " :: dotPath p)))
187                                 EM.nullErrorBody;
188                                 firstTime := false;
189                                 DG.EMPTY)
190                            else DG.EMPTY
191                        val lookup' = look complain
192                        fun loop (e, []) = e
193                          | loop (e, h :: t) = loop (lookup' e h, t)
194                    in
195                        loop (lookup e h, t)
196                    end
197    
198                (* "eval" -- compute the export environment of a skeleton *)
199                fun eval sk = let
200                    fun layer' f [] = DG.EMPTY
201                      | layer' f [x] = f x
202                      | layer' f (h :: t) =
203                        foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t
204    
205                    fun evalDecl e (SK.StrDecl l) = let
206                            fun one { name, def, constraint = NONE } =
207                                DG.BINDING (name, evalStrExp e def)
208                              | one { name, def, constraint = SOME constr } =
209                                (ignore (evalStrExp e def);
210                                 DG.BINDING (name, evalStrExp e constr))
211                        in
212                            layer' one l
213                        end
214                      | evalDecl e (SK.FctDecl l) = let
215                            fun one { name, def } =
216                                DG.BINDING (name, evalFctExp e def)
217                        in
218                            layer' one l
219                        end
220                      | evalDecl e (SK.LocalDecl (d1, d2)) =
221                        evalDecl (DG.LAYER (evalDecl e d1, e)) d2
222                      | evalDecl e (SK.SeqDecl l) =
223                        foldl (fn (d, e') =>
224                               DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))
225                              DG.EMPTY l
226                      | evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l
227                      | evalDecl e (SK.DeclRef s) =
228                        (SS.app (ignore o lookup e) s; DG.EMPTY)
229    
230                    and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp
231                      | evalStrExp e (SK.BaseStrExp d) = evalDecl e d
232                      | evalStrExp e (SK.AppStrExp (sp, l)) =
233                        (app (ignore o evalStrExp e) l; lookSymPath e sp)
234                      | evalStrExp e (SK.LetStrExp (d, se)) =
235                        evalStrExp (DG.LAYER (evalDecl e d, e)) se
236                      | evalStrExp e (SK.ConStrExp (se1, se2)) =
237                        (ignore (evalStrExp e se1); evalStrExp e se2)
238    
239              val lookup = look lookimport *)                  and evalFctExp e (SK.VarFctExp (sp, feopt)) =
240                        getOpt (Option.map (evalFctExp e) feopt,
241                                lookSymPath e sp)
242                      | evalFctExp e (SK.BaseFctExp x) = let
243                            val { params, body, constraint } = x
244                            val parame = evalDecl e params
245                            val bodye = DG.LAYER (parame, e)
246          in          in
247              Dummy.f ()                          getOpt (Option.map (evalStrExp bodye) constraint,
248                                    evalStrExp bodye body)
249                        end
250                      | evalFctExp e (SK.AppFctExp (sp, l, feopt)) =
251                        (app (ignore o evalStrExp e) l;
252                         getOpt (Option.map (evalFctExp e) feopt,
253                                 lookSymPath e sp))
254                      | evalFctExp e (SK.LetFctExp (d, fe)) =
255                        evalFctExp (DG.LAYER (evalDecl e d, e)) fe
256                in
257                    evalDecl DG.EMPTY sk
258                end
259    
260                val e = eval (SmlInfo.skeleton i)
261                val n = DG.NODE { smlinfo = i,
262                                  localimports = !li,
263                                  globalimports = !gi }
264            in
265                (n, e)
266          end          end
267    
268          (* run the analysis on one ML file -- causing the blackboard          (* run the analysis on one ML file -- causing the blackboard
269           * and the root set to be updated accordingly *)           * and the root set to be updated accordingly *)
270          fun doSmlFile i = ignore (getResult (i, []))          fun doSmlFile i = ignore (getResult (i, []))
271    
272            (* converting smlinfos to nodes *)
273            val i2n = #1 o valOf o valOf o fetch
274      in      in
275          Dummy.f ()          (* run the analysis *)
276            app doSmlFile smlfiles;
277            (* generate map from export symbol to node and
278             * also return the root set *)
279            { nodemap = SM.map i2n localdefs,
280              rootset = map i2n (AbsPathMap.listItems (!rs)) }
281      end      end
282  end  end

Legend:
Removed from v.278  
changed lines
  Added in v.279

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