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 273, Wed May 12 08:38:51 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      fun parse' (group, groupstack) = let
29          val currentDir = AbsPath.dir filename  
30          val filename = AbsPath.name filename          val currentDir = AbsPath.dir group
31            val context = AbsPath.relativeContext (AbsPath.dir group)
32            val filename = AbsPath.name group
33          val stream = TextIO.openIn filename          val stream = TextIO.openIn filename
34          val errcons =          val errcons =
35              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }              { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }
# Line 29  Line 38 
38          fun error region m =          fun error region m =
39              EM.error source region EM.COMPLAIN m EM.nullErrorBody              EM.error source region EM.COMPLAIN m EM.nullErrorBody
40    
41            (* recParse returns a group (not an option)
42             * and re-raises LrParser.ParseError.
43             * This exception will be handled by the surrounding
44             * call to parse.
45             * This function is used to parse aliases and sub-groups. *)
46            fun recParse (p1, p2) p =
47                case parse' (p, (group, (source, p1, p2)) :: groupstack) of
48                    NONE => raise LrParser.ParseError
49                  | SOME res => res
50    
51            fun doMember (p, p1, p2, c) =
52                CMSemant.member (recParse (p1, p2)) { sourcepath = p,
53                                                      group = group,
54                                                      class = c }
55    
56            (* checking for cycles among groups and printing them nicely *)
57            val _ = let
58                fun findCycle ([], _) = []
59                  | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
60                    if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
61                    else findCycle (t, h :: cyc)
62                fun report ((g, (s, p1, p2)), hist) = let
63                    fun pphist pps = let
64                        fun loop (_, []) = ()
65                          | loop (g0, (g, (s, p1, p2)) :: t) = let
66                                val s = EM.matchErrorString s (p1, p2)
67                            in
68                                PrettyPrint.add_string pps s;
69                                PrettyPrint.add_string pps ": ";
70                                PrettyPrint.add_string pps (AbsPath.spec g0);
71                                PrettyPrint.add_newline pps;
72                                loop (g, t)
73                            end
74                    in
75                        PrettyPrint.add_newline pps;
76                        PrettyPrint.begin_block pps PrettyPrint.CONSISTENT 4;
77                        loop (g, hist);
78                        PrettyPrint.end_block pps
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                end
85            in
86                case findCycle (groupstack, []) of
87                    [] => ()
88                  | h :: t => report (h, t)
89            end
90    
91          val lexarg = let          val lexarg = let
92              (* local state *)              (* local state *)
93              val depth = ref 0              val depth = ref 0
# Line 92  Line 151 
151          val (parseResult, _) =          val (parseResult, _) =
152              CMParse.parse (lookAhead, tokenStream,              CMParse.parse (lookAhead, tokenStream,
153                             fn (s,p1,p2) => error (p1, p2) s,                             fn (s,p1,p2) => error (p1, p2) s,
154                             (currentDir, error))                             (context, error, recParse, doMember))
155      in      in
156          TextIO.closeIn stream;          TextIO.closeIn stream;
157          SOME parseResult          if !(#anyErrors source) then NONE
158            else SOME parseResult
159      end handle LrParser.ParseError => NONE      end handle LrParser.ParseError => NONE
160    
161        fun parse group = parse' (group, [])
162  end  end

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

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