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 299, Thu May 27 13:53:27 1999 UTC revision 433, Mon Sep 13 06:57:29 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 : GeneralParams.param -> 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 -> unit
15        val dismissLib : SrcPath.t -> unit
16  end  end
17    
18  structure CMParse :> CMPARSE = struct  functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map
19                     structure Stabilize: STABILIZE) :> PARSE = struct
20    
21      val lookAhead = 30      val lookAhead = 30
22    
23      structure S = GenericVC.Source      structure S = GenericVC.Source
24      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
25      structure SM = GenericVC.SourceMap      structure SM = GenericVC.SourceMap
26      structure P = GenericVC.Control.Print      structure GG = GroupGraph
27    
28      structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)      structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
29      structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)      structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
# Line 25  Line 32 
32                       structure Lex = CMLex                       structure Lex = CMLex
33                       structure LrParser = LrParser)                       structure LrParser = LrParser)
34    
35      fun parse param group = let      (* the "stable group cache" *)
36        val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
37          val groupreg = GroupReg.new ()      fun reset () = sgc := SrcPathMap.empty
38          val ginfo = { param = param, groupreg = groupreg }  
39        fun listLibs () = let
40          val gc = ref AbsPathMap.empty   (* the "group cache" *)          fun show (sp, _) =
41                Say.say [SrcPath.descr sp, "\n"]
42          fun mparse (group, groupstack) =      in
43              case AbsPathMap.find (!gc, group) of          SrcPathMap.appi show (!sgc)
44                  SOME g => g      end
45    
46        fun dismissLib l =
47            (sgc := #1 (SrcPathMap.remove (!sgc, l)))
48            handle LibBase.NotFound => ()
49    
50        fun parse gropt param stabflag group = let
51    
52            val stabthis = isSome stabflag
53            val staball = stabflag = SOME true
54    
55            val groupreg =
56                case gropt of
57                    SOME r => r
58                  | NONE => GroupReg.new ()
59            val errcons = EM.defaultConsumer ()
60            val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
61    
62            (* The "group cache" -- we store "group options";  having
63             * NONE registered for a group means that a previous attempt
64             * to parse it had failed. *)
65            val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)
66    
67            fun mparse (group, groupstack, pErrFlag, stabthis, curlib) =
68                case SrcPathMap.find (!sgc, group) of
69                    SOME g => SOME g
70                  | NONE =>
71                        (case SrcPathMap.find (!gc, group) of
72                             SOME gopt => gopt
73                | NONE => let                | NONE => let
74                      val g = parse' (group, groupstack)                               fun cache_nonstable gopt =
75                  in                                   (gc := SrcPathMap.insert (!gc, group, gopt);
76                      gc := AbsPathMap.insert (!gc, group, g);                                    gopt)
77                      g                               fun cache_stable g =
78                  end                                   (sgc := SrcPathMap.insert (!sgc, group, g);
79                                      SOME g)
80                                 fun isStable (GG.GROUP { kind, ... }) =
81                                     case kind of GG.STABLELIB => true | _ => false
82                                 val pres =
83                                     parse' (group, groupstack, pErrFlag,
84                                             stabthis, curlib)
85                             in
86                                 case pres of
87                                     NONE => cache_nonstable NONE
88                                   | SOME g =>
89                                         if isStable g then cache_stable g
90                                         else cache_nonstable (SOME g)
91                             end)
92    
93          and parse' (group, groupstack) = let          and parse' (group, groupstack, pErrFlag, stabthis, curlib) = let
94              (* checking for cycles among groups and printing them nicely *)              (* checking for cycles among groups and printing them nicely *)
95              fun findCycle ([], _) = []              fun findCycle ([], _) = []
96                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =                | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
97                  if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)                  if SrcPath.compare (g, group) = EQUAL then rev (h :: cyc)
98                  else findCycle (t, h :: cyc)                  else findCycle (t, h :: cyc)
99              fun report ((g, (s, p1, p2)), hist) = let              fun report ((g, (s, p1, p2)), hist) = let
100                  fun pphist pps = let                  fun pphist pps = let
# Line 56  Line 104 
104                          in                          in
105                              PrettyPrint.add_string pps s;                              PrettyPrint.add_string pps s;
106                              PrettyPrint.add_string pps ": importing ";                              PrettyPrint.add_string pps ": importing ";
107                              PrettyPrint.add_string pps (AbsPath.spec g0);                              PrettyPrint.add_string pps (SrcPath.specOf g0);
108                              PrettyPrint.add_newline pps;                              PrettyPrint.add_newline pps;
109                              loop (g, t)                              loop (g, t)
110                          end                          end
# Line 67  Line 115 
115              in              in
116                  EM.error s (p1, p2) EM.COMPLAIN                  EM.error s (p1, p2) EM.COMPLAIN
117                             ("group hierarchy forms a cycle with " ^                             ("group hierarchy forms a cycle with " ^
118                              AbsPath.spec group)                              SrcPath.specOf group)
119                             pphist                             pphist
120              end              end
121    
122                fun getStable gpath = let
123                    fun getStableSG p =
124                        mparse (p, groupstack, pErrFlag, staball, SOME gpath)
125                in
126                    Stabilize.loadStable ginfo { getGroup = getStableSG,
127                                                 anyerrors = pErrFlag } gpath
128                end
129    
130                (* We stabilize libraries only because a stable library will
131                 * encompass the contents of its sub-groups
132                 * (but not sub-libraries!). *)
133                fun stabilize (g as GG.GROUP { kind = GG.NOLIB, ... }) = SOME g
134                  | stabilize g =
135                    Stabilize.stabilize ginfo { group = g, anyerrors = pErrFlag }
136    
137              (* normal processing -- used when there is no cycle to report *)              (* normal processing -- used when there is no cycle to report *)
138              fun normal_processing () = let              fun normal_processing () = let
139                  val currentDir = AbsPath.dir group                  val context = SrcPath.sameDirContext group
140                  val context = AbsPath.relativeContext (AbsPath.dir group)  
141                  val filename = AbsPath.name group                  fun work stream = let
142                  val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])                      val source =
143                  val stream = TextIO.openIn filename                          S.newSource (SrcPath.osstring group,
144                  val errcons = { linewidth = !P.linewidth,                                       1, stream, false, errcons)
                                 flush = P.flush,  
                                 consumer = P.say }  
                 val source = S.newSource (filename, 1, stream, false, errcons)  
145                  val sourceMap = #sourceMap source                  val sourceMap = #sourceMap source
146                  val _ = GroupReg.register groupreg (group, source)                  val _ = GroupReg.register groupreg (group, source)
147    
# Line 91  Line 151 
151                   * data structures. *)                   * data structures. *)
152                  fun error r m =                  fun error r m =
153                      EM.error source r EM.COMPLAIN m EM.nullErrorBody                      EM.error source r EM.COMPLAIN m EM.nullErrorBody
154                        fun obsolete r =
155                            if #get StdConfig.warn_obsolete () then
156                                EM.error source r EM.WARN
157                                  "old-style operator (obsolete)" EM.nullErrorBody
158                            else ()
159    
160                  (* recParse returns a group (not an option).                  (* recParse returns a group (not an option).
161                   * This function is used to parse aliases and sub-groups.                       * This function is used to parse sub-groups.
162                   * Errors are propagated by explicitly setting the                   * Errors are propagated by explicitly setting the
163                   * "anyErrors" flag of the parent group. *)                   * "anyErrors" flag of the parent group. *)
164                  fun recParse (p1, p2) p = let                      fun recParse (p1, p2) curlib p = let
165                      val groupstack' = (group, (source, p1, p2)) :: groupstack                          val gs' = (group, (source, p1, p2)) :: groupstack
166                            val myErrorFlag = #anyErrors source
167                  in                  in
168                      case mparse (p, groupstack') of                          case mparse (p, gs', myErrorFlag, staball, curlib) of
169                          NONE => (#anyErrors source := true;                              NONE => (myErrorFlag := true;
170                                   CMSemant.emptyGroup group)                                   CMSemant.emptyGroup group)
171                        | SOME res => res                        | SOME res => res
172                  end                  end
# Line 113  Line 179 
179                                      { sourcepath = p, class = c,                                      { sourcepath = p, class = c,
180                                        group = (group, (p1, p2)) }                                        group = (group, (p1, p2)) }
181    
182                        (* Build the argument for the lexer; the lexer's local
183                         * state is encapsulated here to make sure the parser
184                         * is re-entrant. *)
185                  val lexarg = let                  val lexarg = let
186                      (* local state *)                      (* local state *)
187                      val depth = ref 0                      val depth = ref 0
# Line 129  Line 198 
198                      end                      end
199                      (* handling strings *)                      (* handling strings *)
200                      fun newS pos =                      fun newS pos =
201                          (instring := true; curstring := []; startpos := pos)                              (instring := true;
202                                 curstring := [];
203                                 startpos := pos)
204                      fun addS c = curstring := c :: !curstring                      fun addS c = curstring := c :: !curstring
205                      fun addSC (s, offs) =                      fun addSC (s, offs) =
206                          addS (chr (ord (String.sub (s, 2)) - offs))                          addS (chr (ord (String.sub (s, 2)) - offs))
# Line 160  Line 231 
231                      end                      end
232                      (* handling line breaks *)                      (* handling line breaks *)
233                      fun newline pos = SM.newline sourceMap pos                      fun newline pos = SM.newline sourceMap pos
234                            (* handling #line directives *)
235                            fun sync (p, t) = let
236                                fun sep c = c = #"#" orelse Char.isSpace c
237                                fun cvt s = getOpt (Int.fromString s, 0)
238                                fun r (line, col, file) = SM.resynch sourceMap
239                                    (p, { fileName = file,
240                                          line = line, column = col })
241                            in
242                                case String.tokens sep t of
243                                    [_, line] =>
244                                        r (cvt line, NONE, NONE)
245                                  | [_, line, file] =>
246                                        r (cvt line, NONE, SOME file)
247                                  | [_, line, col, file] =>
248                                        r (cvt line, SOME (cvt col), SOME file)
249                                  | _ => error (p, p + size t)
250                                        "illegal #line directive"
251                            end
252                  in                  in
253                      { enterC = enterC,                      { enterC = enterC,
254                        leaveC = leaveC,                        leaveC = leaveC,
# Line 170  Line 259 
259                        getS = getS,                        getS = getS,
260                        handleEof = handleEof,                        handleEof = handleEof,
261                        newline = newline,                        newline = newline,
262                        error = error }                            obsolete = obsolete,
263                              error = error,
264                              sync = sync}
265                  end                  end
266    
267                  fun inputc k = TextIO.input stream                  fun inputc k = TextIO.input stream
# Line 180  Line 271 
271                  val (parseResult, _) =                  val (parseResult, _) =
272                      CMParse.parse (lookAhead, tokenStream,                      CMParse.parse (lookAhead, tokenStream,
273                                     fn (s,p1,p2) => error (p1, p2) s,                                     fn (s,p1,p2) => error (p1, p2) s,
274                                     (group, context, error, recParse,                                         (group, context, obsolete, error,
275                                      doMember, ginfo))                                          doMember, curlib, ginfo))
276              in              in
                 TextIO.closeIn stream;  
277                  if !(#anyErrors source) then NONE                  if !(#anyErrors source) then NONE
278                  else SOME parseResult                  else SOME parseResult
279              end              end
280                    fun openIt () = TextIO.openIn (SrcPath.osstring group)
281                    val pro =
282                        SafeIO.perform { openIt = openIt,
283                                         closeIt = TextIO.closeIn,
284                                         work = work,
285                                         cleanup = fn () => () }
286                in
287                    case pro of
288                        NONE => NONE
289                      | SOME pr =>
290                            if stabthis then stabilize pr
291                            else SOME pr
292                end
293              handle LrParser.ParseError => NONE              handle LrParser.ParseError => NONE
294          in          in
295              case findCycle (groupstack, []) of              case findCycle (groupstack, []) of
296                  h :: t => (report (h, t); NONE)                  h :: t => (report (h, t); NONE)
297                | [] => normal_processing ()                | [] =>
298          end                      (case getStable group of
299                             NONE =>
300                                 (Say.vsay ["[scanning ", SrcPath.descr group,
301                                            "]\n"];
302                                  normal_processing ())
303                           | SOME g =>
304                                 (Say.vsay ["[library ", SrcPath.descr group,
305                                            " is stable]\n"];
306                                  SOME g))
307            end
308        in
309            case mparse (group, [], ref false, stabthis, NONE) of
310                NONE => NONE
311              | SOME g => let
312                    val reach1 = Reachable.reachable g
313                    val reach2 = Reachable.reachable' (pending ())
314                    val reach = SrcPathSet.union (reach1, reach2)
315      in      in
316          mparse (group, [])                  SmlInfo.forgetAllBut reach;
317                    SOME (g, ginfo)
318                end
319      end      end
320  end  end

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

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