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 270, Tue May 11 07:45:42 1999 UTC revision 275, Sat May 15 09:54:52 1999 UTC
# Line 25  Line 25 
25                       structure Lex = CMLex                       structure Lex = CMLex
26                       structure LrParser = LrParser)                       structure LrParser = LrParser)
27    
28      fun parse group = let      fun parse' (group, groupstack) = let
   
         (* recParse returns a group (not an option)  
          * and re-raises LrParser.ParseError.  
          * This exception will be handled by the surrounding  
          * call to parse.  
          * This function is used to parse aliases and sub-groups. *)  
         fun recParse p =  
             case parse p of  
                 NONE => raise LrParser.ParseError  
               | SOME res => res  
   
         fun doMember (p, c) =  
             CMSemant.member recParse { sourcepath = p,  
                                        group = group,  
                                        class = c }  
29    
30          val currentDir = AbsPath.dir group          val currentDir = AbsPath.dir group
31          val context = AbsPath.relativeContext (AbsPath.dir group)          val context = AbsPath.relativeContext (AbsPath.dir group)
32          val filename = AbsPath.name group          val filename = AbsPath.name group
33            val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])
34          val stream = TextIO.openIn filename          val stream = TextIO.openIn filename
35          val errcons =          val errcons =
36              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }
# Line 53  Line 39 
39          fun error region m =          fun error region m =
40              EM.error source region EM.COMPLAIN m EM.nullErrorBody              EM.error source region EM.COMPLAIN m EM.nullErrorBody
41    
42            (* recParse returns a group (not an option)
43             * and re-raises LrParser.ParseError.
44             * This exception will be handled by the surrounding
45             * call to parse.
46             * This function is used to parse aliases and sub-groups. *)
47            fun recParse (p1, p2) p =
48                case parse' (p, (group, (source, p1, p2)) :: groupstack) of
49                    NONE => (#anyErrors source := true; CMSemant.emptyGroup)
50                  | SOME res => res
51    
52            fun doMember (p, p1, p2, c, e) =
53                CMSemant.member (recParse (p1, p2)) { sourcepath = p,
54                                                      group = group,
55                                                      class = c,
56                                                      error = e }
57    
58            (* checking for cycles among groups and printing them nicely *)
59            val _ = let
60                fun findCycle ([], _) = []
61                  | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
62                    if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
63                    else findCycle (t, h :: cyc)
64                fun report ((g, (s, p1, p2)), hist) = let
65                    fun pphist pps = let
66                        fun loop (_, []) = ()
67                          | loop (g0, (g, (s, p1, p2)) :: t) = let
68                                val s = EM.matchErrorString s (p1, p2)
69                            in
70                                PrettyPrint.add_string pps s;
71                                PrettyPrint.add_string pps ": ";
72                                PrettyPrint.add_string pps (AbsPath.spec g0);
73                                PrettyPrint.add_newline pps;
74                                loop (g, t)
75                            end
76                    in
77                        PrettyPrint.add_newline pps;
78                        loop (g, hist)
79                    end
80                in
81                    EM.error s (p1, p2) EM.COMPLAIN
82                       ("group hierarchy forms a cycle with " ^ AbsPath.spec group)
83                       pphist;
84                    raise LrParser.ParseError
85                end
86            in
87                case findCycle (groupstack, []) of
88                    [] => ()
89                  | h :: t => report (h, t)
90            end
91    
92          val lexarg = let          val lexarg = let
93              (* local state *)              (* local state *)
94              val depth = ref 0              val depth = ref 0
# Line 119  Line 155 
155                             (context, error, recParse, doMember))                             (context, error, recParse, doMember))
156      in      in
157          TextIO.closeIn stream;          TextIO.closeIn stream;
158          SOME parseResult          if !(#anyErrors source) then NONE
159      end handle LrParser.ParseError => NONE          else SOME parseResult
160        end
161        handle LrParser.ParseError => NONE
162             | Cycle => NONE
163    
164        fun parse group = parse' (group, [])
165  end  end

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

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