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

Diff of /sml/trunk/src/cm/parse/parse.sml

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

revision 364, Fri Jul 2 07:33:12 1999 UTC revision 514, Thu Dec 16 08:32:57 1999 UTC
# Line 10  Line 10 
10          GroupReg.groupreg option ->          GroupReg.groupreg option ->
11          GeneralParams.param -> bool option ->          GeneralParams.param -> bool option ->
12          SrcPath.t -> (CMSemant.group * GeneralParams.info) option          SrcPath.t -> (CMSemant.group * GeneralParams.info) option
13        val reset : unit -> unit
14        val listLibs : unit -> SrcPath.t list
15        val dropPickles : unit -> unit
16        val dismissLib : SrcPath.t -> unit
17  end  end
18    
19  functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map  functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map
# Line 29  Line 33 
33                       structure Lex = CMLex                       structure Lex = CMLex
34                       structure LrParser = LrParser)                       structure LrParser = LrParser)
35    
36      fun parse gropt param stabflag group = let      (* the "stable group cache" *)
37        val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
38        fun reset () = sgc := SrcPathMap.empty
39    
40        fun registerNewStable (p, g) =
41            (sgc := SrcPathMap.insert (!sgc, p, g);
42             SrcPathSet.app (SmlInfo.cleanGroup true) (Reachable.groupsOf g))
43        fun cachedStable p = SrcPathMap.find (!sgc, p)
44    
45        fun listLibs () = map #1 (SrcPathMap.listItemsi (!sgc))
46    
47        fun dropPickles () = let
48            fun drop (GG.GROUP { kind = GG.STABLELIB dropper, ... }) = dropper ()
49              | drop _ = ()
50        in
51            SrcPathMap.app drop (!sgc)
52        end
53    
54          val _ = SrcPath.revalidateCwd ()      fun dismissLib l =
55            (sgc := #1 (SrcPathMap.remove (!sgc, l)))
56            handle LibBase.NotFound => ()
57    
58        fun parse gropt param stabflag group = let
59    
60          val stabthis = isSome stabflag          val stabthis = isSome stabflag
61          val staball = stabflag = SOME true          val staball = stabflag = SOME true
# Line 48  Line 72 
72           * to parse it had failed. *)           * to parse it had failed. *)
73          val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)          val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)
74    
75          fun mparse (group, groupstack, pErrFlag, stabthis) =          fun hasCycle (group, groupstack) = let
             case SrcPathMap.find (!gc, group) of  
                 SOME g => g  
               | NONE => let  
                     val g = parse' (group, groupstack, pErrFlag, stabthis)  
                 in  
                     gc := SrcPathMap.insert (!gc, group, g);  
                     g  
                 end  
   
         and parse' (group, groupstack, pErrFlag, stabthis) = let  
76              (* checking for cycles among groups and printing them nicely *)              (* checking for cycles among groups and printing them nicely *)
77              fun findCycle ([], _) = []              fun findCycle ([], _) = []
78                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
# Line 70  Line 84 
84                        | loop (g0, (g, (s, p1, p2)) :: t) = let                        | loop (g0, (g, (s, p1, p2)) :: t) = let
85                              val s = EM.matchErrorString s (p1, p2)                              val s = EM.matchErrorString s (p1, p2)
86                          in                          in
87                                PrettyPrint.add_newline pps;
88                              PrettyPrint.add_string pps s;                              PrettyPrint.add_string pps s;
89                              PrettyPrint.add_string pps ": importing ";                              PrettyPrint.add_string pps ": importing ";
90                              PrettyPrint.add_string pps (SrcPath.specOf g0);                              PrettyPrint.add_string pps (SrcPath.specOf g0);
                             PrettyPrint.add_newline pps;  
91                              loop (g, t)                              loop (g, t)
92                          end                          end
93                  in                  in
                     PrettyPrint.add_newline pps;  
94                      loop (g, hist)                      loop (g, hist)
95                  end                  end
96              in              in
# Line 86  Line 99 
99                              SrcPath.specOf group)                              SrcPath.specOf group)
100                             pphist                             pphist
101              end              end
102            in
103                case findCycle (groupstack, []) of
104                    h :: t => (report (h, t); true)
105                  | [] => false
106            end
107    
108              fun getStable gpath = let          fun mparse (group, groupstack, pErrFlag, stabthis, curlib) = let
109                  (* To make a cycle involving existing stable groups,              fun getStable stablestack gpath = let
110                   * one must use aliases.  The cycle will be detected                  (* This is a separate "findCycle" routine that detects
111                   * amoung those aliases... (?? - hopefully) *)                   * cycles among stable libraries.  These cycles should
112                  fun getStableSG p =                   * never occur unless someone purposefully renames
113                      mparse (p, groupstack, pErrFlag, staball)                   * stable library files in a bad way. *)
114                    fun findCycle ([], _) = NONE
115                      | findCycle (h :: t, cyc) =
116                        if SrcPath.compare (h, gpath) = EQUAL then SOME (h :: cyc)
117                        else findCycle (t, h :: cyc)
118                    fun report cyc = let
119                        fun pphist pps = let
120                            fun loop [] = ()
121                              | loop (h :: t) =
122                                (PrettyPrint.add_newline pps;
123                                 PrettyPrint.add_string pps (SrcPath.descr h);
124                                 loop t)
125                        in
126                            loop (rev cyc)
127                        end
128                    in
129                        EM.errorNoFile (errcons, pErrFlag) SM.nullRegion
130                          EM.COMPLAIN
131                          ("stable libraries form a cycle with " ^
132                           SrcPath.descr gpath)
133                          pphist
134                    end
135                    fun load () = let
136                        val go = Stabilize.loadStable ginfo
137                            { getGroup = getStable (gpath :: stablestack),
138                              anyerrors = pErrFlag }
139                            gpath
140                    in
141                        case go of
142                            NONE => NONE
143                          | SOME g =>
144                                (registerNewStable (gpath, g);
145                                 Say.vsay ["[library ", SrcPath.descr gpath,
146                                           " is stable]\n"];
147                                 SOME g)
148                    end
149              in              in
150                  Stabilize.loadStable (ginfo, getStableSG, pErrFlag) gpath                  case findCycle (stablestack, []) of
151                        NONE => (case cachedStable gpath of
152                                     SOME g => SOME g
153                                   | NONE => load ())
154                      | SOME cyc => (report cyc; NONE)
155              end              end
156            in
157                case getStable [] group of
158                    SOME g => SOME g
159                  | NONE =>
160                        (case SrcPathMap.find (!gc, group) of
161                             SOME gopt => gopt
162                           | NONE => let
163                                 val pres =
164                                     parse' (group, groupstack, pErrFlag,
165                                             stabthis, curlib)
166                             in
167                                 case cachedStable group of
168                                     NONE =>
169                                         gc := SrcPathMap.insert (!gc, group, pres)
170                                   | SOME _ => ();
171                                 pres
172                             end)
173            end
174    
175            and parse' (group, groupstack, pErrFlag, stabthis, curlib) = let
176    
177              (* We stabilize libraries only because a stable library will              (* We stabilize libraries only because a stable library will
178               * encompass the contents of its sub-groups               * encompass the contents of its sub-groups
179               * (but not sub-libraries!). *)               * (but not sub-libraries!). *)
180              fun stabilize (g as GG.GROUP { kind = GG.NOLIB, ... }) = SOME g              fun stabilize (g as GG.GROUP { kind = GG.NOLIB, ... }) = SOME g
181                | stabilize g =                | stabilize g = let
182                  Stabilize.stabilize ginfo { group = g, anyerrors = pErrFlag }                      val go = Stabilize.stabilize ginfo { group = g,
183                                                             anyerrors = pErrFlag }
184                    in
185                        case go of
186                            NONE => NONE
187                          | SOME g => (registerNewStable (group, g);
188                                       (gc := #1 (SrcPathMap.remove (!gc, group))
189                                        handle LibBase.NotFound => ());
190                                       SOME g)
191                    end
192    
193              (* normal processing -- used when there is no cycle to report *)              (* normal processing -- used when there is no cycle to report *)
194              fun normal_processing () = let              fun normal_processing () = let
195                    val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]
196    
197                  val context = SrcPath.sameDirContext group                  val context = SrcPath.sameDirContext group
198    
199                  fun work stream = let                  fun work stream = let
# Line 121  Line 209 
209                       * data structures. *)                       * data structures. *)
210                      fun error r m =                      fun error r m =
211                          EM.error source r EM.COMPLAIN m EM.nullErrorBody                          EM.error source r EM.COMPLAIN m EM.nullErrorBody
212                        fun obsolete r =
213                            if #get StdConfig.warn_obsolete () then
214                                EM.error source r EM.WARN
215                                  "old-style operator (obsolete)" EM.nullErrorBody
216                            else ()
217    
218                      (* recParse returns a group (not an option).                      (* recParse returns a group (not an option).
219                       * This function is used to parse aliases and sub-groups.                       * This function is used to parse sub-groups.
220                       * Errors are propagated by explicitly setting the                       * Errors are propagated by explicitly setting the
221                       * "anyErrors" flag of the parent group. *)                       * "anyErrors" flag of the parent group. *)
222                      fun recParse (p1, p2) p = let                      fun recParse (p1, p2) curlib p = let
223                          val groupstack' =                          val gs' = (group, (source, p1, p2)) :: groupstack
                             (group, (source, p1, p2)) :: groupstack  
224                          val myErrorFlag = #anyErrors source                          val myErrorFlag = #anyErrors source
225                      in                      in
226                          case mparse (p, groupstack', myErrorFlag, staball) of                          case mparse (p, gs', myErrorFlag, staball, curlib) of
227                              NONE => (myErrorFlag := true;                              NONE => (myErrorFlag := true;
228                                       CMSemant.emptyGroup group)                                       CMSemant.emptyGroup group)
229                            | SOME res => res                            | SOME res => res
# Line 140  Line 232 
232                          (error (p1, p2) (General.exnMessage exn);                          (error (p1, p2) (General.exnMessage exn);
233                           CMSemant.emptyGroup group)                           CMSemant.emptyGroup group)
234    
235                      fun doMember (p, p1, p2, c) =                      fun doMember ({ name, mkpath }, p1, p2, c) =
236                          CMSemant.member (ginfo, recParse (p1, p2))                          CMSemant.member (ginfo, recParse (p1, p2))
237                                   { sourcepath = p, class = c,                            { name = name, mkpath = mkpath,
238                                     group = (group, (p1, p2)) }                              class = c, group = (group, (p1, p2)),
239                                context = context }
240    
241                      (* Build the argument for the lexer; the lexer's local                      (* Build the argument for the lexer; the lexer's local
242                       * state is encapsulated here to make sure the parser                       * state is encapsulated here to make sure the parser
# Line 225  Line 318 
318                            getS = getS,                            getS = getS,
319                            handleEof = handleEof,                            handleEof = handleEof,
320                            newline = newline,                            newline = newline,
321                              obsolete = obsolete,
322                            error = error,                            error = error,
323                            sync = sync}                            sync = sync}
324                      end                      end
# Line 236  Line 330 
330                      val (parseResult, _) =                      val (parseResult, _) =
331                          CMParse.parse (lookAhead, tokenStream,                          CMParse.parse (lookAhead, tokenStream,
332                                         fn (s,p1,p2) => error (p1, p2) s,                                         fn (s,p1,p2) => error (p1, p2) s,
333                                         (group, context, error, recParse,                                         (group, context, obsolete, error,
334                                          doMember, ginfo))                                          doMember, curlib, ginfo))
335                  in                  in
336                      if !(#anyErrors source) then NONE                      if !(#anyErrors source) then NONE
337                      else SOME parseResult                      else SOME parseResult
# Line 247  Line 341 
341                      SafeIO.perform { openIt = openIt,                      SafeIO.perform { openIt = openIt,
342                                       closeIt = TextIO.closeIn,                                       closeIt = TextIO.closeIn,
343                                       work = work,                                       work = work,
344                                       cleanup = fn () => () }                                       cleanup = fn _ => () }
345              in              in
346                  case pro of                  case pro of
347                      NONE => NONE                      NONE => NONE
348                    | SOME pr =>                    | SOME pr =>
349                          if stabthis then stabilize pr                          if stabthis then stabilize pr
350                          else SOME pr                          else (SmlInfo.cleanGroup false group; SOME pr)
351              end              end
352              handle LrParser.ParseError => NONE              handle LrParser.ParseError => NONE
353          in          in
354              case findCycle (groupstack, []) of              if hasCycle (group, groupstack) then NONE
355                  h :: t => (report (h, t); NONE)              else normal_processing ()
               | [] =>  
                     (case getStable group of  
                          NONE =>  
                              (Say.vsay ["[scanning ", SrcPath.descr group,  
                                         "]\n"];  
                               normal_processing ())  
                        | SOME g =>  
                              (Say.vsay ["[library ", SrcPath.descr group,  
                                         " is stable]\n"];  
                               SOME g))  
356          end          end
357      in      in
358          case mparse (group, [], ref false, stabthis) of          SmlInfo.newGeneration ();
359            case mparse (group, [], ref false, stabthis, NONE) of
360              NONE => NONE              NONE => NONE
361            | SOME g =>            | SOME g => SOME (g, ginfo)
                 if CheckSharing.check (g, ginfo) then  
                     let  
                         val reach1 = Reachable.reachable g  
                         val reach2 = Reachable.reachable' (pending ())  
                         val reach = SrcPathSet.union (reach1, reach2)  
                     in  
                         SmlInfo.forgetAllBut reach;  
                         SOME (g, ginfo)  
                     end  
                 else NONE  
362      end      end
363  end  end

Legend:
Removed from v.364  
changed lines
  Added in v.514

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