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 268, Mon May 10 07:00:02 1999 UTC revision 282, Wed May 19 05:14:03 1999 UTC
# Line 1  Line 1 
1    (*
2     * Parser for CM description files.
3     *
4     * (C) 1999 Lucent Technologies, Bell Laboratories
5     *
6     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7     *)
8  signature CMPARSE = sig  signature CMPARSE = sig
9      val parse : AbsPath.t -> CMSemant.group option      val parse : AbsPath.t -> CMSemant.group option
10  end  end
# Line 18  Line 25 
25                       structure Lex = CMLex                       structure Lex = CMLex
26                       structure LrParser = LrParser)                       structure LrParser = LrParser)
27    
28      fun parse filename = let      (* The error function must look for the source using the GroupReg
29          val currentDir = AbsPath.dir filename       * group register because the source must not be hard-wired into it
30          val filename = AbsPath.name filename       * (via closure creation).  The reason for this is that the error
31         * function will get cached in SmlInfo.info but the source will change
32         * when one re-runs the analysis. *)
33    
34        fun parse' (group, groupstack) = let
35    
36            val currentDir = AbsPath.dir group
37            val context = AbsPath.relativeContext (AbsPath.dir group)
38            val filename = AbsPath.name group
39            val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])
40          val stream = TextIO.openIn filename          val stream = TextIO.openIn filename
41          val errcons =          val errcons =
42              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }
43          val source = S.newSource (filename, 1, stream, false, errcons)          val source = S.newSource (filename, 1, stream, false, errcons)
44          val sourceMap = #sourceMap source          val sourceMap = #sourceMap source
45          fun error region m =          val _ = GroupReg.register (group, source)
46              EM.error source region EM.COMPLAIN m EM.nullErrorBody          fun error' region m b = let
47                val src = GroupReg.lookup group
48            in
49                EM.error src region EM.COMPLAIN m b
50            end
51            fun error region m = error' region m EM.nullErrorBody
52    
53            (* recParse returns a group (not an option)
54             * and re-raises LrParser.ParseError.
55             * This exception will be handled by the surrounding
56             * call to parse.
57             * This function is used to parse aliases and sub-groups. *)
58            fun recParse (p1, p2) p =
59                (case parse' (p, (group, (source, p1, p2)) :: groupstack) of
60                     NONE => (#anyErrors source := true; CMSemant.emptyGroup)
61                   | SOME res => res)
62                handle exn as IO.Io _ => (error (p1, p2) (General.exnMessage exn);
63                                          CMSemant.emptyGroup)
64    
65            fun doMember (p, p1, p2, c, e) =
66                CMSemant.member (recParse (p1, p2))
67                                { sourcepath = p,
68                                  group = group,
69                                  class = c,
70                                  error = e }
71    
72            (* checking for cycles among groups and printing them nicely *)
73            val _ = let
74                fun findCycle ([], _) = []
75                  | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
76                    if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
77                    else findCycle (t, h :: cyc)
78                fun report ((g, (s, p1, p2)), hist) = let
79                    fun pphist pps = let
80                        fun loop (_, []) = ()
81                          | loop (g0, (g, (s, p1, p2)) :: t) = let
82                                val s = EM.matchErrorString s (p1, p2)
83                            in
84                                PrettyPrint.add_string pps s;
85                                PrettyPrint.add_string pps ": importing ";
86                                PrettyPrint.add_string pps (AbsPath.spec g0);
87                                PrettyPrint.add_newline pps;
88                                loop (g, t)
89                            end
90                    in
91                        PrettyPrint.add_newline pps;
92                        loop (g, hist)
93                    end
94                in
95                    EM.error s (p1, p2) EM.COMPLAIN
96                       ("group hierarchy forms a cycle with " ^ AbsPath.spec group)
97                       pphist;
98                    raise LrParser.ParseError
99                end
100            in
101                case findCycle (groupstack, []) of
102                    [] => ()
103                  | h :: t => report (h, t)
104            end
105    
106          val lexarg = let          val lexarg = let
107              (* local state *)              (* local state *)
# Line 92  Line 166 
166          val (parseResult, _) =          val (parseResult, _) =
167              CMParse.parse (lookAhead, tokenStream,              CMParse.parse (lookAhead, tokenStream,
168                             fn (s,p1,p2) => error (p1, p2) s,                             fn (s,p1,p2) => error (p1, p2) s,
169                             (currentDir, error))                             (context, error', error, recParse, doMember))
170      in      in
171          TextIO.closeIn stream;          TextIO.closeIn stream;
172          SOME parseResult          if !(#anyErrors source) then NONE
173      end handle LrParser.ParseError => NONE          else SOME parseResult
174        end
175        handle LrParser.ParseError => NONE
176    
177        fun parse group = (GroupReg.clear (); parse' (group, []))
178  end  end

Legend:
Removed from v.268  
changed lines
  Added in v.282

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