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 275, Sat May 15 09:54:52 1999 UTC revision 514, Thu Dec 16 08:32:57 1999 UTC
# Line 5  Line 5 
5   *   *
6   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7   *)   *)
8  signature CMPARSE = sig  signature PARSE = sig
9      val parse : AbsPath.t -> CMSemant.group option      val parse :
10            GroupReg.groupreg option ->
11            GeneralParams.param -> bool option ->
12            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  structure CMParse :> CMPARSE = struct  functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map
20                     structure Stabilize: STABILIZE) :> PARSE = struct
21    
22      val lookAhead = 30      val lookAhead = 30
23    
24      structure S = GenericVC.Source      structure S = GenericVC.Source
25      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
26      structure SM = GenericVC.SourceMap      structure SM = GenericVC.SourceMap
27      structure P = GenericVC.Control.Print      structure GG = GroupGraph
28    
29      structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)      structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
30      structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)      structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
# Line 25  Line 33 
33                       structure Lex = CMLex                       structure Lex = CMLex
34                       structure LrParser = LrParser)                       structure LrParser = LrParser)
35    
36      fun parse' (group, groupstack) = let      (* the "stable group cache" *)
37        val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
38          val currentDir = AbsPath.dir group      fun reset () = sgc := SrcPathMap.empty
39          val context = AbsPath.relativeContext (AbsPath.dir group)  
40          val filename = AbsPath.name group      fun registerNewStable (p, g) =
41          val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])          (sgc := SrcPathMap.insert (!sgc, p, g);
42          val stream = TextIO.openIn filename           SrcPathSet.app (SmlInfo.cleanGroup true) (Reachable.groupsOf g))
43          val errcons =      fun cachedStable p = SrcPathMap.find (!sgc, p)
44              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }  
45          val source = S.newSource (filename, 1, stream, false, errcons)      fun listLibs () = map #1 (SrcPathMap.listItemsi (!sgc))
46          val sourceMap = #sourceMap source  
47          fun error region m =      fun dropPickles () = let
48              EM.error source region EM.COMPLAIN m EM.nullErrorBody          fun drop (GG.GROUP { kind = GG.STABLELIB dropper, ... }) = dropper ()
49              | drop _ = ()
50          (* recParse returns a group (not an option)      in
51           * and re-raises LrParser.ParseError.          SrcPathMap.app drop (!sgc)
52           * This exception will be handled by the surrounding      end
          * call to parse.  
          * This function is used to parse aliases and sub-groups. *)  
         fun recParse (p1, p2) p =  
             case parse' (p, (group, (source, p1, p2)) :: groupstack) of  
                 NONE => (#anyErrors source := true; CMSemant.emptyGroup)  
               | SOME res => res  
53    
54          fun doMember (p, p1, p2, c, e) =      fun dismissLib l =
55              CMSemant.member (recParse (p1, p2)) { sourcepath = p,          (sgc := #1 (SrcPathMap.remove (!sgc, l)))
56                                                    group = group,          handle LibBase.NotFound => ()
57                                                    class = c,  
58                                                    error = e }      fun parse gropt param stabflag group = let
59    
60            val stabthis = isSome stabflag
61            val staball = stabflag = SOME true
62    
63            val groupreg =
64                case gropt of
65                    SOME r => r
66                  | NONE => GroupReg.new ()
67            val errcons = EM.defaultConsumer ()
68            val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
69    
70            (* The "group cache" -- we store "group options";  having
71             * NONE registered for a group means that a previous attempt
72             * to parse it had failed. *)
73            val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)
74    
75            fun hasCycle (group, groupstack) = let
76          (* checking for cycles among groups and printing them nicely *)          (* checking for cycles among groups and printing them nicely *)
         val _ = let  
77              fun findCycle ([], _) = []              fun findCycle ([], _) = []
78                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
79                  if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)                  if SrcPath.compare (g, group) = EQUAL then rev (h :: cyc)
80                  else findCycle (t, h :: cyc)                  else findCycle (t, h :: cyc)
81              fun report ((g, (s, p1, p2)), hist) = let              fun report ((g, (s, p1, p2)), hist) = let
82                  fun pphist pps = let                  fun pphist pps = let
# Line 67  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
                             PrettyPrint.add_string pps s;  
                             PrettyPrint.add_string pps ": ";  
                             PrettyPrint.add_string pps (AbsPath.spec g0);  
87                              PrettyPrint.add_newline pps;                              PrettyPrint.add_newline pps;
88                                PrettyPrint.add_string pps s;
89                                PrettyPrint.add_string pps ": importing ";
90                                PrettyPrint.add_string pps (SrcPath.specOf g0);
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
97                  EM.error s (p1, p2) EM.COMPLAIN                  EM.error s (p1, p2) EM.COMPLAIN
98                     ("group hierarchy forms a cycle with " ^ AbsPath.spec group)                             ("group hierarchy forms a cycle with " ^
99                     pphist;                              SrcPath.specOf group)
100                  raise LrParser.ParseError                             pphist
101              end              end
102          in          in
103              case findCycle (groupstack, []) of              case findCycle (groupstack, []) of
104                  [] => ()                  h :: t => (report (h, t); true)
105                | h :: t => report (h, t)                | [] => false
106            end
107    
108            fun mparse (group, groupstack, pErrFlag, stabthis, curlib) = let
109                fun getStable stablestack gpath = let
110                    (* This is a separate "findCycle" routine that detects
111                     * cycles among stable libraries.  These cycles should
112                     * never occur unless someone purposefully renames
113                     * 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
150                    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
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
178                 * encompass the contents of its sub-groups
179                 * (but not sub-libraries!). *)
180                fun stabilize (g as GG.GROUP { kind = GG.NOLIB, ... }) = SOME g
181                  | stabilize g = let
182                        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          end
192    
193                (* normal processing -- used when there is no cycle to report *)
194                fun normal_processing () = let
195                    val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]
196    
197                    val context = SrcPath.sameDirContext group
198    
199                    fun work stream = let
200                        val source =
201                            S.newSource (SrcPath.osstring group,
202                                         1, stream, false, errcons)
203                        val sourceMap = #sourceMap source
204                        val _ = GroupReg.register groupreg (group, source)
205    
206                        (* We can hard-wire the source into this
207                         * error function because the function is only for
208                         * immediate use and doesn't get stored into persistent
209                         * data structures. *)
210                        fun error r m =
211                            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).
219                         * This function is used to parse sub-groups.
220                         * Errors are propagated by explicitly setting the
221                         * "anyErrors" flag of the parent group. *)
222                        fun recParse (p1, p2) curlib p = let
223                            val gs' = (group, (source, p1, p2)) :: groupstack
224                            val myErrorFlag = #anyErrors source
225                        in
226                            case mparse (p, gs', myErrorFlag, staball, curlib) of
227                                NONE => (myErrorFlag := true;
228                                         CMSemant.emptyGroup group)
229                              | SOME res => res
230                        end
231                        handle exn as IO.Io _ =>
232                            (error (p1, p2) (General.exnMessage exn);
233                             CMSemant.emptyGroup group)
234    
235                        fun doMember ({ name, mkpath }, p1, p2, c) =
236                            CMSemant.member (ginfo, recParse (p1, p2))
237                              { name = name, mkpath = mkpath,
238                                class = c, group = (group, (p1, p2)),
239                                context = context }
240    
241                        (* Build the argument for the lexer; the lexer's local
242                         * state is encapsulated here to make sure the parser
243                         * is re-entrant. *)
244          val lexarg = let          val lexarg = let
245              (* local state *)              (* local state *)
246              val depth = ref 0              val depth = ref 0
247              val curstring = ref []              val curstring = ref []
248              val startpos = ref 0              val startpos = ref 0
249              val instring = ref NONE                          val instring = ref false
250              (* handling comments *)              (* handling comments *)
251              fun enterC () = depth := !depth + 1              fun enterC () = depth := !depth + 1
252              fun leaveC () = let val d = !depth - 1 in depth := d; d = 0 end                          fun leaveC () = let
253                                val d = !depth - 1
254                            in
255                                depth := d;
256                                d = 0
257                            end
258              (* handling strings *)              (* handling strings *)
259              fun newS (pos, kind) =                          fun newS pos =
260                  (instring := SOME kind;                              (instring := true;
261                   curstring := [];                   curstring := [];
262                   startpos := pos)                   startpos := pos)
263              fun addS c = curstring := c :: !curstring              fun addS c = curstring := c :: !curstring
264              fun addSC (s, offs) = addS (chr (ord (String.sub (s, 2)) - offs))                          fun addSC (s, offs) =
265                                addS (chr (ord (String.sub (s, 2)) - offs))
266              fun addSN (s, pos) = let              fun addSN (s, pos) = let
267                  val ns = substring (s, 1, 3)                  val ns = substring (s, 1, 3)
268                  val n = Int.fromString ns                  val n = Int.fromString ns
# Line 115  Line 273 
273                        ("illegal decimal char spec: " ^ ns)                        ("illegal decimal char spec: " ^ ns)
274              end              end
275              fun getS (pos, tok) =              fun getS (pos, tok) =
276                  (instring := NONE;                              (instring := false;
277                   tok (implode (rev (!curstring)), !startpos, pos))                   tok (implode (rev (!curstring)), !startpos, pos))
278              (* handling EOF *)              (* handling EOF *)
279              fun handleEof () = let              fun handleEof () = let
280                  val pos = SM.lastChange sourceMap                  val pos = SM.lastChange sourceMap
281              in              in
282                  if !depth > 0 then                  if !depth > 0 then
                     error (pos, pos) "unexpected end of input in comment"  
                 else if isSome (!instring) then  
283                      error (pos, pos)                      error (pos, pos)
284                       ("unexpected end of input in " ^ valOf (!instring))                                         "unexpected end of input in comment"
285                                else if !instring then
286                                    error (pos, pos)
287                                           "unexpected end of input in string"
288                  else ();                  else ();
289                  pos                  pos
290              end              end
291              (* handling line breaks *)              (* handling line breaks *)
292              fun newline pos = SM.newline sourceMap pos              fun newline pos = SM.newline sourceMap pos
293                            (* handling #line directives *)
294                            fun sync (p, t) = let
295                                fun sep c = c = #"#" orelse Char.isSpace c
296                                fun cvt s = getOpt (Int.fromString s, 0)
297                                fun r (line, col, file) = SM.resynch sourceMap
298                                    (p, { fileName = file,
299                                          line = line, column = col })
300                            in
301                                case String.tokens sep t of
302                                    [_, line] =>
303                                        r (cvt line, NONE, NONE)
304                                  | [_, line, file] =>
305                                        r (cvt line, NONE, SOME file)
306                                  | [_, line, col, file] =>
307                                        r (cvt line, SOME (cvt col), SOME file)
308                                  | _ => error (p, p + size t)
309                                        "illegal #line directive"
310                            end
311          in          in
312              { enterC = enterC,              { enterC = enterC,
313                leaveC = leaveC,                leaveC = leaveC,
# Line 141  Line 318 
318                getS = getS,                getS = getS,
319                handleEof = handleEof,                handleEof = handleEof,
320                newline = newline,                newline = newline,
321                error = error }                            obsolete = obsolete,
322                              error = error,
323                              sync = sync}
324          end          end
325    
326          fun inputc k =                      fun inputc k = TextIO.input stream
             TextIO.input stream  
327    
328          val lexer = CMLex.makeLexer inputc lexarg          val lexer = CMLex.makeLexer inputc lexarg
329          val tokenStream = LrParser.Stream.streamify lexer          val tokenStream = LrParser.Stream.streamify lexer
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                             (context, error, recParse, doMember))                                         (group, context, obsolete, error,
334                                            doMember, curlib, ginfo))
335      in      in
         TextIO.closeIn stream;  
336          if !(#anyErrors source) then NONE          if !(#anyErrors source) then NONE
337          else SOME parseResult          else SOME parseResult
338      end      end
339                    fun openIt () = TextIO.openIn (SrcPath.osstring group)
340                    val pro =
341                        SafeIO.perform { openIt = openIt,
342                                         closeIt = TextIO.closeIn,
343                                         work = work,
344                                         cleanup = fn _ => () }
345                in
346                    case pro of
347                        NONE => NONE
348                      | SOME pr =>
349                            if stabthis then stabilize pr
350                            else (SmlInfo.cleanGroup false group; SOME pr)
351                end
352      handle LrParser.ParseError => NONE      handle LrParser.ParseError => NONE
353           | Cycle => NONE          in
354                if hasCycle (group, groupstack) then NONE
355      fun parse group = parse' (group, [])              else normal_processing ()
356            end
357        in
358            SmlInfo.newGeneration ();
359            case mparse (group, [], ref false, stabthis, NONE) of
360                NONE => NONE
361              | SOME g => SOME (g, ginfo)
362        end
363  end  end

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

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