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 299, Thu May 27 13:53:27 1999 UTC revision 355, Sat Jun 26 13:17:30 1999 UTC
# Line 13  Line 13 
13            gimports: impexp SymbolMap.map,            gimports: impexp SymbolMap.map,
14            smlfiles: SmlInfo.info list,            smlfiles: SmlInfo.info list,
15            localdefs: SmlInfo.info SymbolMap.map,            localdefs: SmlInfo.info SymbolMap.map,
16            subgroups: GroupGraph.group list }            subgroups: (SrcPath.t * GroupGraph.group) list,
17              reqpriv: GroupGraph.privileges }
18          * SymbolSet.set option          (* filter *)          * SymbolSet.set option          (* filter *)
19          * (string -> unit)              (* error *)          * (string -> unit)              (* error *)
20          * GeneralParams.info          * GeneralParams.info
21          ->          ->
22          impexp SymbolMap.map            (* exports *)          impexp SymbolMap.map            (* exports *)
23            * GroupGraph.privileges         (* required privileges (aggregate) *)
24    
25        (* for the autoloader *)
26        type looker = Symbol.symbol -> DAEnv.env
27        val look : looker -> DAEnv.env -> looker
28        val processOneSkeleton : looker -> Skeleton.decl -> unit
29  end  end
30    
31  structure BuildDepend :> BUILDDEPEND = struct  structure BuildDepend :> BUILDDEPEND = struct
# Line 34  Line 41 
41    
42      type impexp = DG.impexp      type impexp = DG.impexp
43    
44        type looker = Symbol.symbol -> DAEnv.env
45    
46      fun look otherwise DE.EMPTY s = otherwise s      fun look otherwise DE.EMPTY s = otherwise s
47        | look otherwise (DE.BINDING (s', v)) s =        | look otherwise (DE.BINDING (s', v)) s =
48          if S.eq (s, s') then v else otherwise s          if S.eq (s, s') then v else otherwise s
49        | look otherwise (DE.LAYER (e, e')) s = look (look otherwise e') e s        | look otherwise (DE.LAYER (e, e')) s = look (look otherwise e') e s
50        | look otherwise (DE.FCTENV { looker, domain }) s =        | look otherwise (DE.FCTENV looker) s =
51          (case looker s of NONE => otherwise s | SOME v => v)          (case looker s of NONE => otherwise s | SOME v => v)
52        | look otherwise (DE.FILTER (ss, e)) s =        | look otherwise (DE.FILTER (ss, e)) s =
53          if SymbolSet.member (ss, s) then look otherwise e s else otherwise s          if SymbolSet.member (ss, s) then look otherwise e s else otherwise s
54    
55        fun evalOneSkeleton lookimport = let
56            (* build the lookup function for DG.env *)
57            val lookup = look lookimport
58    
59            fun lookSymPath e (SP.SPATH []) = DE.EMPTY
60              | lookSymPath e (SP.SPATH (p as (h :: t))) = let
61                    (* again, if we don't find it here we just ignore
62                     * the problem and let the compiler catch it later *)
63                    val lookup' = look (fn _ => DE.EMPTY)
64                    fun loop (e, []) = e
65                      | loop (e, h :: t) = loop (lookup' e h, t)
66                in
67                    loop (lookup e h, t)
68                end
69    
70            (* "eval" -- compute the export environment of a skeleton *)
71            fun eval sk = let
72                fun evalDecl e (SK.Bind (name, def)) =
73                    DE.BINDING (name, evalModExp e def)
74                  | evalDecl e (SK.Local (d1, d2)) =
75                    evalDecl (DE.LAYER (evalDecl e d1, e)) d2
76                  | evalDecl e (SK.Seq l) = evalSeqDecl e l
77                  | evalDecl e (SK.Par []) = DE.EMPTY
78                  | evalDecl e (SK.Par (h :: t)) =
79                    foldl (fn (x, r) => DE.LAYER (evalDecl e x, r))
80                    (evalDecl e h) t
81                  | evalDecl e (SK.Open s) = evalModExp e s
82                  | evalDecl e (SK.Ref s) =
83                    (SS.app (ignore o lookup e) s; DE.EMPTY)
84    
85                and evalSeqDecl e [] = DE.EMPTY
86                  | evalSeqDecl e (h :: t) = let
87                        fun one (d, e') =
88                            DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e')
89                    in
90                        foldl one (evalDecl e h) t
91                    end
92    
93                and evalModExp e (SK.Var sp) = lookSymPath e sp
94                  | evalModExp e (SK.Decl l) = evalSeqDecl e l
95                  | evalModExp e (SK.Let (d, m)) =
96                    evalModExp (DE.LAYER (evalSeqDecl e d, e)) m
97                  | evalModExp e (SK.Ign1 (m1, m2)) =
98                    (ignore (evalModExp e m1); evalModExp e m2)
99            in
100                evalDecl DE.EMPTY sk
101            end
102        in
103            eval
104        end
105    
106        fun processOneSkeleton lookimport sk =
107            ignore (evalOneSkeleton lookimport sk)
108    
109      (* get the description for a symbol *)      (* get the description for a symbol *)
110      fun symDesc (s, r) =      fun symDesc (s, r) =
111          S.nameSpaceToString (S.nameSpace s) :: " " :: S.name s :: r          S.nameSpaceToString (S.nameSpace s) :: " " :: S.name s :: r
112    
113      fun build (coll, fopt, error, gp) = let      fun build (coll, fopt, error, gp) = let
114          val { imports, gimports, smlfiles, localdefs, subgroups } = coll          val { imports, gimports, smlfiles, localdefs, subgroups, reqpriv } =
115                coll
116    
117          (* the "blackboard" where analysis results are announced *)          (* the "blackboard" where analysis results are announced *)
118          (* (also used for cycle detection) *)          (* (also used for cycle detection) *)
119          val bb = ref AbsPathMap.empty          val bb = ref SmlInfoMap.empty
120          fun lock i = bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, NONE)          fun lock i = bb := SmlInfoMap.insert (!bb, i, NONE)
121          fun release (i, r) =          fun release (i, r) = (bb := SmlInfoMap.insert (!bb, i, SOME r); r)
122              (bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)          fun fetch i = SmlInfoMap.find (!bb, i)
         fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)  
123    
124          (* - get the result from the blackboard if it is there *)          (* - get the result from the blackboard if it is there *)
125          (* - otherwise trigger analysis *)          (* - otherwise trigger analysis *)
# Line 72  Line 135 
135                          fun recur (_, []) = () (* shouldn't happen *)                          fun recur (_, []) = () (* shouldn't happen *)
136                            | recur (n'', (s, i') :: r) = let                            | recur (n'', (s, i') :: r) = let
137                                  val f' = SmlInfo.sourcepath i'                                  val f' = SmlInfo.sourcepath i'
138                                  val n' = AbsPath.spec f'                                  val n' = SrcPath.specOf f'
139                                  val _ =                                  val _ =
140                                      if SmlInfo.eq (i, i') then ()                                      if SmlInfo.eq (i, i') then ()
141                                      else recur (n', r)                                      else recur (n', r)
# Line 85  Line 148 
148                              end                              end
149                      in                      in
150                          PrettyPrint.add_newline pps;                          PrettyPrint.add_newline pps;
151                          recur (AbsPath.spec f, history)                          recur (SrcPath.specOf f, history)
152                      end                      end
153                  in                  in
154                      SmlInfo.error gp i EM.COMPLAIN                      SmlInfo.error gp i EM.COMPLAIN
# Line 132  Line 195 
195              val f = SmlInfo.sourcepath i              val f = SmlInfo.sourcepath i
196              fun isSelf i' = SmlInfo.eq (i, i')              fun isSelf i' = SmlInfo.eq (i, i')
197    
             exception Lookup  
   
198              (* lookup function for things not defined in the same ML file.              (* lookup function for things not defined in the same ML file.
199               * As a side effect, this function registers local and               * As a side effect, this function registers local and
200               * global imports. *)               * global imports. *)
201              fun lookimport s = let              fun lookimport s = let
202                    fun internalError s =
203                        EM.impossible "build/lookimport/lookfar"
204                  fun lookfar () =                  fun lookfar () =
205                      case SM.find (imports, s) of                      case SM.find (imports, s) of
206                          SOME (farn, e) => (globalImport farn; e)                          SOME (farn, e) => (globalImport farn;
207                        | NONE => (SmlInfo.error gp i EM.COMPLAIN                                             look internalError e s)
208                                    (concat (AbsPath.spec f ::                        | NONE =>
209                                             ": reference to unknown " ::                              (* We could complain here about an undefined
210                                             symDesc (s, [])))                               * name.  However, since CM doesn't have the
211                                    EM.nullErrorBody;                               * proper source locations available, it is
212                                   raise Lookup)                               * better to handle this case silently and
213                                 * have the compiler catch the problem later. *)
214                                DE.EMPTY
215              in              in
216                  case SM.find (localdefs, s) of                  case SM.find (localdefs, s) of
217                      SOME i' =>                      SOME i' =>
# Line 160  Line 225 
225                    | NONE => lookfar ()                    | NONE => lookfar ()
226              end              end
227    
228              (* build the lookup function for DG.env *)              val eval = evalOneSkeleton lookimport
             val lookup_exn = look lookimport  
   
             fun lookSymPath e (SP.SPATH []) = DE.EMPTY  
               | lookSymPath e (SP.SPATH (p as (h :: t))) = let  
                     fun dotPath [] = []  
                       | dotPath [s] = [S.name s]  
                       | dotPath (h :: t) = S.name h :: "." :: dotPath t  
                     fun complain s =  
                         (SmlInfo.error gp i EM.COMPLAIN  
                           (concat  
                            (AbsPath.spec f ::  
                             ": undefined " ::  
                             symDesc (s, " in path " :: dotPath p)))  
                           EM.nullErrorBody;  
                          raise Lookup)  
                     val lookup_exn' = look complain  
                     fun loop (e, []) = e  
                       | loop (e, h :: t) = loop (lookup_exn' e h, t)  
                 in  
                     loop (lookup_exn e h, t) handle Lookup => DE.EMPTY  
                 end  
   
             fun lookup e s = lookup_exn e s handle Lookup => DE.EMPTY  
229    
230              (* "eval" -- compute the export environment of a skeleton *)              val e = case SmlInfo.skeleton gp i of
231              fun eval sk = let                  SOME sk => eval sk
232                  fun evalDecl e (SK.Bind (name, def)) =                | NONE => DE.EMPTY
                     DE.BINDING (name, evalModExp e def)  
                   | evalDecl e (SK.Local (d1, d2)) =  
                     evalDecl (DE.LAYER (evalDecl e d1, e)) d2  
                   | evalDecl e (SK.Seq l) = evalSeqDecl e l  
                   | evalDecl e (SK.Par []) = DE.EMPTY  
                   | evalDecl e (SK.Par (h :: t)) =  
                     foldl (fn (x, r) => DE.LAYER (evalDecl e x, r))  
                           (evalDecl e h) t  
                   | evalDecl e (SK.Open s) = evalModExp e s  
                   | evalDecl e (SK.Ref s) =  
                     (SS.app (ignore o lookup e) s; DE.EMPTY)  
   
                 and evalSeqDecl e [] = DE.EMPTY  
                   | evalSeqDecl e (h :: t) = let  
                         fun one (d, e') =  
                             DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e')  
                     in  
                         foldl one (evalDecl e h) t  
                     end  
   
                 and evalModExp e (SK.Var sp) = lookSymPath e sp  
                   | evalModExp e (SK.Decl l) = evalSeqDecl e l  
                   | evalModExp e (SK.Let (d, m)) =  
                     evalModExp (DE.LAYER (evalSeqDecl e d, e)) m  
                   | evalModExp e (SK.Ign1 (m1, m2)) =  
                     (ignore (evalModExp e m1); evalModExp e m2)  
             in  
                 evalDecl DE.EMPTY sk  
             end  
233    
             val e = eval (SmlInfo.skeleton gp i)  
234              val n = DG.SNODE { smlinfo = i,              val n = DG.SNODE { smlinfo = i,
235                                 localimports = !li,                                 localimports = !li,
236                                 globalimports = !gi }                                 globalimports = !gi }
# Line 284  Line 296 
296                      SS.foldl addNodeFor SM.empty ss                      SS.foldl addNodeFor SM.empty ss
297                  end                  end
298      in      in
299          exports          (exports, reqpriv)
300      end      end
301  end  end

Legend:
Removed from v.299  
changed lines
  Added in v.355

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